From de901ea5c87dc4dc1aa1519e0a5830a3711d3c1e Mon Sep 17 00:00:00 2001 From: George Thomas Date: Tue, 4 Jul 2023 14:27:18 +0100 Subject: [PATCH 1/2] feat: "Type or kind" shows kind of subtree instead of parent type This is more intuitive and useful. Signed-off-by: George Thomas --- primer-api/src/Primer/API.hs | 11 ++++++++--- primer/src/Primer/Action/ProgError.hs | 1 + 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/primer-api/src/Primer/API.hs b/primer-api/src/Primer/API.hs index e800c9816..41721d30b 100644 --- a/primer-api/src/Primer/API.hs +++ b/primer-api/src/Primer/API.hs @@ -102,7 +102,7 @@ import Primer.API.NodeFlavor qualified as Flavor import Primer.API.RecordPair (RecordPair (RecordPair)) import Primer.Action (ActionError, ProgAction, toProgActionInput, toProgActionNoInput) import Primer.Action.Available qualified as Available -import Primer.Action.ProgError (ProgError (NodeIDNotFound, ParamNotFound)) +import Primer.Action.ProgError (ProgError (NodeIDNotFound, ParamNotFound, TypeDefConFieldNotFound)) import Primer.App ( App, DefSelection (..), @@ -142,7 +142,7 @@ import Primer.App ( unlog, ) import Primer.App qualified as App -import Primer.App.Base (TypeDefNodeSelection (..)) +import Primer.App.Base (TypeDefNodeSelection (..), getTypeDefConFieldType) import Primer.Core ( Bind' (..), CaseBranch' (..), @@ -1337,9 +1337,14 @@ getSelectionTypeOrKind = curry $ logAPI (noError GetTypeOrKind) $ \(sid, sel0) - maybe (throwM $ GetTypeOrKindError sel0 $ ParamNotFound p) (pure . Kind . viewTreeKind . snd) $ find ((== p) . fst) (astTypeDefParameters def) -- constructor node selected - return the type to which it belongs - Just (TypeDefConsNodeSelection _) -> + Just (TypeDefConsNodeSelection (TypeDefConsSelection _ Nothing)) -> pure . Type . viewTreeType' . mkIds $ foldl' (\t -> TApp () t . TVar ()) (TCon () sel.def) (map fst $ astTypeDefParameters def) + -- field node selected - return its kind + Just (TypeDefConsNodeSelection (TypeDefConsSelection c (Just s))) -> do + t0 <- maybe (throwM $ GetTypeOrKindError sel0 $ TypeDefConFieldNotFound sel.def c s.index) pure $ getTypeDefConFieldType def c s.index + t <- maybe (throwM $ GetTypeOrKindError sel0 $ NodeIDNotFound s.meta) pure $ findType s.meta t0 + pure $ viewTypeKind $ t ^. _typeMetaLens where trivialTree = Tree{nodeId = "seltype-0", childTrees = [], rightChild = Nothing, body = NoBody Flavor.EmptyHole} viewExprType :: ExprMeta -> TypeOrKind diff --git a/primer/src/Primer/Action/ProgError.hs b/primer/src/Primer/Action/ProgError.hs index d960849c6..cac4503a7 100644 --- a/primer/src/Primer/Action/ProgError.hs +++ b/primer/src/Primer/Action/ProgError.hs @@ -35,6 +35,7 @@ data ProgError ConNotSaturated ValConName | ParamNotFound TyVarName | NodeIDNotFound ID + | TypeDefConFieldNotFound TyConName ValConName Int | ValConParamClash Name | ActionError ActionError | EvalError EvalError From 26b921a12ca747793bb5a4cd41d38ced298e02cf Mon Sep 17 00:00:00 2001 From: George Thomas Date: Tue, 4 Jul 2023 14:43:57 +0100 Subject: [PATCH 2/2] refactor: DRY `getSelectionTypeOrKind` errors Signed-off-by: George Thomas --- primer-api/src/Primer/API.hs | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/primer-api/src/Primer/API.hs b/primer-api/src/Primer/API.hs index 41721d30b..46cf5d4ed 100644 --- a/primer-api/src/Primer/API.hs +++ b/primer-api/src/Primer/API.hs @@ -1302,6 +1302,7 @@ data TypeOrKind = Type Tree | Kind Tree deriving anyclass (NFData) getSelectionTypeOrKind :: + forall m l. (MonadIO m, MonadThrow m, MonadAPILog l m) => SessionId -> Selection -> @@ -1310,6 +1311,8 @@ getSelectionTypeOrKind = curry $ logAPI (noError GetTypeOrKind) $ \(sid, sel0) - prog <- getProgram sid let allDefs = progAllDefs prog allTypeDefs = progAllTypeDefsMeta prog + throw' :: ProgError -> PrimerM m a + throw' = throwM . GetTypeOrKindError sel0 case sel0 of SelectionDef sel -> do def <- snd <$> findASTDef allDefs sel.def @@ -1319,14 +1322,14 @@ getSelectionTypeOrKind = curry $ logAPI (noError GetTypeOrKind) $ \(sid, sel0) - Just NodeSelection{meta = id, nodeType} -> case nodeType of -- body node selected - get type/kind from metadata BodyNode -> - maybe (throwM noID) (pure . fst) (findNodeWithParent id $ astDefExpr def) <&> \case + maybe (throw' $ NodeIDNotFound id) (pure . fst) (findNodeWithParent id $ astDefExpr def) <&> \case ExprNode e -> viewExprType $ e ^. _exprMetaLens TypeNode t -> viewTypeKind $ t ^. _typeMetaLens CaseBindNode b -> viewExprType $ b ^. _bindMeta -- sig node selected - get kind from metadata - SigNode -> maybe (throwM noID) pure (findType id $ astDefType def) <&> \t -> viewTypeKind $ t ^. _typeMetaLens - where - noID = GetTypeOrKindError sel0 $ NodeIDNotFound id + SigNode -> + maybe (throw' $ NodeIDNotFound id) pure (findType id $ astDefType def) <&> \t -> + viewTypeKind $ t ^. _typeMetaLens SelectionTypeDef sel -> do def <- snd <$> findASTTypeDef allTypeDefs sel.def case sel.node of @@ -1334,7 +1337,7 @@ getSelectionTypeOrKind = curry $ logAPI (noError GetTypeOrKind) $ \(sid, sel0) - Nothing -> pure $ Kind $ viewTreeKind $ typeDefKind $ TypeDef.TypeDefAST def -- param node selected - return its kind Just (TypeDefParamNodeSelection p) -> - maybe (throwM $ GetTypeOrKindError sel0 $ ParamNotFound p) (pure . Kind . viewTreeKind . snd) $ + maybe (throw' $ ParamNotFound p) (pure . Kind . viewTreeKind . snd) $ find ((== p) . fst) (astTypeDefParameters def) -- constructor node selected - return the type to which it belongs Just (TypeDefConsNodeSelection (TypeDefConsSelection _ Nothing)) -> @@ -1342,8 +1345,8 @@ getSelectionTypeOrKind = curry $ logAPI (noError GetTypeOrKind) $ \(sid, sel0) - foldl' (\t -> TApp () t . TVar ()) (TCon () sel.def) (map fst $ astTypeDefParameters def) -- field node selected - return its kind Just (TypeDefConsNodeSelection (TypeDefConsSelection c (Just s))) -> do - t0 <- maybe (throwM $ GetTypeOrKindError sel0 $ TypeDefConFieldNotFound sel.def c s.index) pure $ getTypeDefConFieldType def c s.index - t <- maybe (throwM $ GetTypeOrKindError sel0 $ NodeIDNotFound s.meta) pure $ findType s.meta t0 + t0 <- maybe (throw' $ TypeDefConFieldNotFound sel.def c s.index) pure $ getTypeDefConFieldType def c s.index + t <- maybe (throw' $ NodeIDNotFound s.meta) pure $ findType s.meta t0 pure $ viewTypeKind $ t ^. _typeMetaLens where trivialTree = Tree{nodeId = "seltype-0", childTrees = [], rightChild = Nothing, body = NoBody Flavor.EmptyHole}