attempt to DRY action functions

`Available.options`, `Action.toProgActionNoInput` and `Action.toProgActionInput`

Signed-off-by: George Thomas <[email protected]>

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]

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
+    }

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