From 798e08e729a86de3bd6867fc22e984f2f6f8366f Mon Sep 17 00:00:00 2001 From: George Thomas Date: Wed, 24 May 2023 15:22:24 +0100 Subject: [PATCH] attempt to DRY action functions `Available.options`, `Action.toProgActionNoInput` and `Action.toProgActionInput` Signed-off-by: George Thomas --- primer/src/Primer/Action.hs | 115 ++++++++----------------- primer/src/Primer/Action/Available.hs | 117 +++++++++++++++++++++----- primer/src/Primer/Action/Errors.hs | 10 +-- 3 files changed, 134 insertions(+), 108 deletions(-) diff --git a/primer/src/Primer/Action.hs b/primer/src/Primer/Action.hs index 711b03c68..04cdbce1f 100644 --- a/primer/src/Primer/Action.hs +++ b/primer/src/Primer/Action.hs @@ -2,6 +2,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE RecordWildCards #-} module Primer.Action ( Action (..), @@ -46,13 +47,11 @@ import Primer.App.Base ( Selection' (..), TypeDefConsFieldSelection (..), TypeDefConsSelection (..), - TypeDefNodeSelection (..), TypeDefSelection (..), ) import Primer.Core ( Expr, Expr' (..), - GVarName, HasID, HasMetadata (_metadata), ID, @@ -921,31 +920,31 @@ toProgActionNoInput :: Either ActionError [ProgAction] toProgActionNoInput defs def0 sel0 = \case Available.MakeCase -> - toProgAction [ConstructCase] + toProg [ConstructCase] Available.MakeApp -> - toProgAction [ConstructApp, Move Child2] + toProg [ConstructApp, Move Child2] Available.MakeAPP -> - toProgAction [ConstructAPP, EnterType] + toProg [ConstructAPP, EnterType] Available.MakeAnn -> - toProgAction [ConstructAnn] + toProg [ConstructAnn] Available.RemoveAnn -> - toProgAction [RemoveAnn] + toProg [RemoveAnn] Available.LetToRec -> - toProgAction [ConvertLetToLetrec] + toProg [ConvertLetToLetrec] Available.Raise -> do id <- nodeID sel <- termSel pure [MoveToDef sel.def, CopyPasteBody (sel.def, id) [SetCursor id, Move Parent, Delete]] Available.EnterHole -> - toProgAction [EnterHole] + toProg [EnterHole] Available.RemoveHole -> - toProgAction [FinishHole] + toProg [FinishHole] Available.DeleteExpr -> - toProgAction [Delete] + toProg [Delete] Available.MakeFun -> -- We arbitrarily choose that the "construct a function type" action places the focused expression -- on the domain (left) side of the arrow. - toProgAction [ConstructArrowL, Move Child1] + toProg [ConstructArrowL, Move Child1] Available.AddInput -> do -- This action traverses the function type and adds a function arrow to the end of it, -- resulting in a new argument type. The result type is unchanged. @@ -964,15 +963,15 @@ toProgActionNoInput defs def0 sel0 = \case t -> Left $ NeedTFun t let moveToLastArg = replicate l (Move Child2) moveBack = replicate l (Move Parent) - in toProgAction $ moveToLastArg <> [ConstructArrowR] <> moveBack + in toProg $ moveToLastArg <> [ConstructArrowR] <> moveBack Available.MakeTApp -> - toProgAction [ConstructTApp, Move Child1] + toProg [ConstructTApp, Move Child1] Available.RaiseType -> do id <- nodeID sel <- termSel pure [MoveToDef sel.def, CopyPasteSig (sel.def, id) [SetCursor id, Move Parent, Delete]] Available.DeleteType -> - toProgAction [Delete] + toProg [Delete] Available.DuplicateDef -> do sel <- termSel def <- termDef @@ -997,33 +996,7 @@ toProgActionNoInput defs def0 sel0 = \case let index = length $ valConArgs vc -- for now, we always add on to the end pure [AddConField defName sel.con index $ TEmptyHole ()] where - termSel = case sel0 of - SelectionDef s -> pure s - SelectionTypeDef _ -> Left NeedTermDefSelection - nodeID = do - sel <- termSel - maybeToEither NoNodeSelection $ (.meta) <$> sel.node - typeSel = case sel0 of - SelectionDef _ -> Left NeedTypeDefSelection - SelectionTypeDef s -> pure s - typeNodeSel = do - sel <- typeSel - maybe (Left NeedTypeDefNodeSelection) (pure . (sel.def,)) sel.node - conSel = - typeNodeSel >>= \case - (s0, TypeDefConsNodeSelection s) -> pure (s0, s) - _ -> Left NeedTypeDefConsSelection - conFieldSel = do - (ty, s) <- conSel - maybe (Left NeedTypeDefConsFieldSelection) (pure . (ty,s.con,)) s.field - toProgAction actions = do - case sel0 of - SelectionDef sel -> toProg' actions sel.def <$> maybeToEither NoNodeSelection sel.node - SelectionTypeDef _ -> do - (t, c, f) <- conFieldSel - pure [ConFieldAction t c f.index $ SetCursor f.meta : actions] - termDef = first (const NeedTermDef) def0 - typeDef = either Right (Left . const NeedTypeDef) def0 + (Available.GetInfo{..}, toProg) = getInfo' sel0 def0 -- | Convert a high-level 'Available.InputAction', and associated 'Available.Option', -- to a concrete sequence of 'ProgAction's. @@ -1110,28 +1083,6 @@ toProgActionInput def0 sel0 opt0 = \case let index = length $ astTypeDefConstructors d -- for now, we always add on the end pure [AddCon sel.def index opt] where - termSel = case sel0 of - SelectionDef s -> pure s - SelectionTypeDef _ -> Left NeedTermDefSelection - nodeID = do - sel <- termSel - maybeToEither NoNodeSelection $ (.meta) <$> sel.node - typeSel = case sel0 of - SelectionDef _ -> Left NeedTypeDefSelection - SelectionTypeDef s -> pure s - typeNodeSel = do - sel <- typeSel - maybe (Left NeedTypeDefNodeSelection) (pure . (sel.def,)) sel.node - typeParamSel = - typeNodeSel >>= \case - (s0, TypeDefParamNodeSelection s) -> pure (s0, s) - _ -> Left NeedTypeDefParamSelection - conSel = - typeNodeSel >>= \case - (s0, TypeDefConsNodeSelection s) -> pure (s0, s) - _ -> Left NeedTypeDefConsSelection - termDef = first (const NeedTermDef) def0 - typeDef = either Right (Left . const NeedTypeDef) def0 optVar = case opt0.context of Just q -> GlobalVarRef $ unsafeMkGlobalName (q, opt0.option) Nothing -> LocalVarRef $ unsafeMkLocalName opt0.option @@ -1144,15 +1095,6 @@ toProgActionInput def0 sel0 opt0 = \case optGlobal = case opt0.context of Nothing -> Left $ NeedLocal opt0 Just q -> pure (q, opt0.option) - conFieldSel = do - (ty, s) <- conSel - maybe (Left NeedTypeDefConsFieldSelection) (pure . (ty,s.con,)) s.field - toProg actions = do - case sel0 of - SelectionDef sel -> toProg' actions sel.def <$> maybeToEither NoNodeSelection sel.node - SelectionTypeDef _ -> do - (t, c, f) <- conFieldSel - pure [ConFieldAction t c f.index $ SetCursor f.meta : actions] offerRefined = do id <- nodeID def <- termDef @@ -1165,11 +1107,24 @@ toProgActionInput def0 sel0 opt0 = \case _ -> False Just (sm, _) -> Left $ NeedType sm Nothing -> Left $ IDNotFound id + (Available.GetInfo{..}, toProg) = getInfo' sel0 def0 -toProg' :: [Action] -> GVarName -> NodeSelection ID -> [ProgAction] -toProg' actions defName sel = - [ MoveToDef defName - , (SetCursor sel.meta : actions) & case sel.nodeType of - SigNode -> SigAction - BodyNode -> BodyAction - ] +getInfo' :: + Selection' ID -> + Either (ASTTypeDef a) ASTDef -> + (Available.GetInfo a (Either ActionError), [Action] -> Either ActionError [ProgAction]) +getInfo' sel0 def0 = (gi, toProg) + where + gi@Available.GetInfo{..} = Available.getInfo sel0 def0 $ Left . GetInfoError + toProg actions = case sel0 of + SelectionDef _ -> do + (def, nodeSel) <- termNodeSel + pure + [ MoveToDef def + , (SetCursor nodeSel.meta : actions) & case nodeSel.nodeType of + SigNode -> SigAction + BodyNode -> BodyAction + ] + SelectionTypeDef _ -> do + (t, c, f) <- conFieldSel + pure [ConFieldAction t c f.index $ SetCursor f.meta : actions] diff --git a/primer/src/Primer/Action/Available.hs b/primer/src/Primer/Action/Available.hs index 245b0fd59..8ee576aca 100644 --- a/primer/src/Primer/Action/Available.hs +++ b/primer/src/Primer/Action/Available.hs @@ -1,5 +1,7 @@ {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoFieldSelectors #-} -- | Compute all the possible actions which can be performed on a definition. @@ -19,6 +21,9 @@ module Primer.Action.Available ( forTypeDefParamNode, forTypeDefConsNode, forTypeDefConsFieldNode, + GetInfoError (..), + getInfo, + GetInfo (..), ) where import Foreword @@ -56,6 +61,8 @@ import Primer.Core ( GlobalName (baseName, qualifiedModule), ID, ModuleName (unModuleName), + TyConName, + TyVarName, Type, Type' (..), TypeMeta, @@ -473,45 +480,43 @@ options typeDefs defs cxt level def0 sel0 = \case (first (localOpt . unLocalName) <$> locals) <> (first globalOpt <$> globals) findNode = case sel0 of - SelectionDef sel -> do - nodeSel <- sel.node - def <- eitherToMaybe def0 + SelectionDef _ -> do + (_, nodeSel) <- termNodeSel + def <- termDef case nodeSel.nodeType of BodyNode -> fst <$> findNodeWithParent nodeSel.meta (astDefExpr def) SigNode -> TypeNode <$> findType nodeSel.meta (astDefType def) - SelectionTypeDef sel -> do - (_, zT) <- conField sel + SelectionTypeDef _ -> do + (_, zT) <- conField pure $ TypeNode $ target zT genNames typeOrKind = map localOpt . flip runReader cxt <$> case sel0 of - SelectionDef sel -> do - z <- focusNode =<< sel.node + SelectionDef _ -> do + (_, nodeSel) <- termNodeSel + z <- focusNode nodeSel pure $ case z of Left zE -> generateNameExpr typeOrKind zE Right zT -> generateNameTy typeOrKind zT - SelectionTypeDef sel -> do - (_, zT) <- conField sel + SelectionTypeDef _ -> do + (_, zT) <- conField pure $ generateNameTy typeOrKind zT varsInScope = case sel0 of - SelectionDef sel -> do - nodeSel <- sel.node + SelectionDef _ -> do + (_, nodeSel) <- termNodeSel focusNode nodeSel <&> \case Left zE -> variablesInScopeExpr defs zE Right zT -> (variablesInScopeTy zT, [], []) - SelectionTypeDef sel -> do - (def, zT) <- conField sel + SelectionTypeDef _ -> do + (def, zT) <- conField pure (astTypeDefParameters def <> variablesInScopeTy zT, [], []) focusNode nodeSel = do def <- eitherToMaybe def0 case nodeSel.nodeType of BodyNode -> Left . locToEither <$> focusOn nodeSel.meta (astDefExpr def) SigNode -> fmap Right $ focusOnTy nodeSel.meta $ astDefType def - conField sel = do - (con, field) <- case sel of - TypeDefSelection _ (Just (TypeDefConsNodeSelection (TypeDefConsSelection con (Just field)))) -> - Just (con, field) - _ -> Nothing - def <- either Just (const Nothing) def0 + conField = do + def <- typeDef + (_, con, field) <- conFieldSel map (def,) $ focusOnTy field.meta =<< getTypeDefConFieldType def con field.index -- Extract the source of the function type we were checked at -- i.e. the type that a lambda-bound variable would have here @@ -530,6 +535,7 @@ options typeDefs defs cxt level def0 sel0 = \case TFun{} -> True TForall{} -> True _ -> False + GetInfo{..} :: GetInfo TypeMeta Maybe = getInfo sel0 def0 (const Nothing) sortByPriority :: Level -> @@ -580,3 +586,76 @@ sortByPriority l = AddCon -> P.addCon RenameCon -> P.rename RenameTypeParam -> P.rename + +data GetInfoError + = NeedTermDef + | NeedTypeDef + | NeedTermDefSelection + | NeedTypeDefSelection + | NeedTypeDefNodeSelection + | NeedTypeDefConsSelection + | NeedTypeDefConsFieldSelection + | NeedTypeDefParamSelection + | NoNodeSelection + deriving stock (Eq, Show, Read, Generic) + deriving (FromJSON, ToJSON) via PrimerJSON GetInfoError + +data GetInfo m f = GetInfo + { termSel :: f (DefSelection ID) + , termNodeSel :: f (GVarName, NodeSelection ID) + , nodeID :: f ID + , typeSel :: f (TypeDefSelection ID) + , typeNodeSel :: f (TyConName, TypeDefNodeSelection ID) + , conSel :: f (TyConName, TypeDefConsSelection ID) + , conFieldSel :: f (TyConName, ValConName, TypeDefConsFieldSelection ID) + , typeParamSel :: f (TyConName, TyVarName) + , termDef :: f ASTDef + , typeDef :: f (ASTTypeDef m) + } + +getInfo :: Applicative f => Selection' ID -> Either (ASTTypeDef a) ASTDef -> (forall x. GetInfoError -> f x) -> GetInfo a f +getInfo sel0 def0 = flip convertError GetInfo{..} + where + termSel = case sel0 of + SelectionDef s -> pure s + SelectionTypeDef _ -> Left NeedTermDefSelection + termNodeSel = do + sel <- termSel + maybe (Left NeedTermDefSelection) (pure . (sel.def,)) sel.node + nodeID = do + sel <- termSel + maybeToEither NoNodeSelection $ (.meta) <$> sel.node + typeSel = case sel0 of + SelectionDef _ -> Left NeedTypeDefSelection + SelectionTypeDef s -> pure s + typeNodeSel = do + sel <- typeSel + maybe (Left NeedTypeDefNodeSelection) (pure . (sel.def,)) sel.node + conSel = + typeNodeSel >>= \case + (s0, TypeDefConsNodeSelection s) -> pure (s0, s) + _ -> Left NeedTypeDefConsSelection + conFieldSel = do + (ty, s) <- conSel + maybe (Left NeedTypeDefConsFieldSelection) (pure . (ty,s.con,)) s.field + typeParamSel = + typeNodeSel >>= \case + (s0, TypeDefParamNodeSelection s) -> pure (s0, s) + _ -> Left NeedTypeDefParamSelection + termDef = first (const NeedTermDef) def0 + typeDef = either Right (Left . const NeedTypeDef) def0 + +convertError :: Applicative f => (forall x. e -> f x) -> GetInfo m (Either e) -> GetInfo m f +convertError f GetInfo{..} = + GetInfo + { termSel = either f pure termSel + , termNodeSel = either f pure termNodeSel + , nodeID = either f pure nodeID + , typeSel = either f pure typeSel + , typeNodeSel = either f pure typeNodeSel + , conSel = either f pure conSel + , conFieldSel = either f pure conFieldSel + , typeParamSel = either f pure typeParamSel + , termDef = either f pure termDef + , typeDef = either f pure typeDef + } \ No newline at end of file diff --git a/primer/src/Primer/Action/Errors.hs b/primer/src/Primer/Action/Errors.hs index 18b92789f..ff5f80426 100644 --- a/primer/src/Primer/Action/Errors.hs +++ b/primer/src/Primer/Action/Errors.hs @@ -63,15 +63,7 @@ data ActionError | NeedLocal Available.Option | NeedInt Available.Option | NeedChar Available.Option - | NeedTermDef - | NeedTypeDef - | NeedTermDefSelection - | NeedTypeDefSelection - | NeedTypeDefNodeSelection - | NeedTypeDefConsSelection - | NeedTypeDefConsFieldSelection - | NeedTypeDefParamSelection - | NoNodeSelection | ValConNotFound TyConName ValConName + | GetInfoError Available.GetInfoError deriving stock (Eq, Show, Read, Generic) deriving (FromJSON, ToJSON) via PrimerJSON ActionError