actions

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

primer-api/src/Primer/API.hs

@@ -1199,7 +1199,9 @@ availableActions = curry3 $ logAPI (noError AvailableActions) $ \(sid, level, se
       (editable, def) <- findASTTypeDef allTypeDefs sel.def
       let getActions = case sel.node of
             Nothing -> Available.forTypeDef
-            Just (TypeDefParamNodeSelection p) -> Available.forTypeDefParamNode p
+            Just (TypeDefParamNodeSelection s) -> case s.kindMeta of
+              Nothing -> Available.forTypeDefParamNode s.param
+              Just kind -> Available.forTypeDefParamKindNode s.param kind
             Just (TypeDefConsNodeSelection s) -> case s.field of
               Nothing -> Available.forTypeDefConsNode
               Just field -> Available.forTypeDefConsFieldNode s.con field.index field.meta
@@ -1344,8 +1346,8 @@ getSelectionTypeOrKind = curry $ logAPI (noError GetTypeOrKind) $ \(sid, sel0) -
         Nothing -> pure $ Kind $ viewTreeKind' $ mkIdsK $ typeDefKind $ forgetTypeDefMetadata $ TypeDef.TypeDefAST def
         -- param node selected - return its kind
         Just (TypeDefParamNodeSelection p) ->
-          maybe (throw' $ ParamNotFound p) (pure . Kind . viewTreeKind . snd) $
-            find ((== p) . fst) (astTypeDefParameters def)
+          maybe (throw' $ ParamNotFound p.param) (pure . Kind . viewTreeKind . snd) $
+            find ((== p.param) . fst) (astTypeDefParameters def)
         -- constructor node selected - return the type to which it belongs
         Just (TypeDefConsNodeSelection (TypeDefConsSelection _ Nothing)) ->
           pure . Type . viewTreeType' . mkIds $

primer-service/src/Primer/OpenAPI.hs

@@ -66,7 +66,7 @@ import Primer.API.NodeFlavor (
  )
 import Primer.API.RecordPair (RecordPair)
 import Primer.Action.Available qualified as Available
-import Primer.App (DefSelection, NodeSelection, NodeType, TypeDefSelection)
+import Primer.App (DefSelection, NodeSelection, NodeType, TypeDefParamSelection, TypeDefSelection)
 import Primer.App.Base (Level, TypeDefConsFieldSelection (..), TypeDefConsSelection (..), TypeDefNodeSelection)
 import Primer.Core (
   GlobalName,
@@ -173,6 +173,7 @@ deriving via PrimerJSON ApplyActionBody instance ToSchema ApplyActionBody
 deriving via PrimerJSONNamed "Selection" Selection instance ToSchema Selection
 deriving via PrimerJSONNamed "TypeDefSelection" (TypeDefSelection ID) instance ToSchema (TypeDefSelection ID)
 deriving via PrimerJSONNamed "TypeDefNodeSelection" (TypeDefNodeSelection ID) instance ToSchema (TypeDefNodeSelection ID)
+deriving via PrimerJSONNamed "TypeDefParamSelection" (TypeDefParamSelection ID) instance ToSchema (TypeDefParamSelection ID)
 deriving via PrimerJSONNamed "TypeDefConsSelection" (TypeDefConsSelection ID) instance ToSchema (TypeDefConsSelection ID)
 deriving via PrimerJSONNamed "TypeDefConsFieldSelection" (TypeDefConsFieldSelection ID) instance ToSchema (TypeDefConsFieldSelection ID)
 deriving via PrimerJSONNamed "DefSelection" (DefSelection ID) instance ToSchema (DefSelection ID)

primer-service/test/Tests/OpenAPI.hs

@@ -57,9 +57,10 @@ import Primer.App (
   Selection' (..),
   TypeDefConsFieldSelection (TypeDefConsFieldSelection),
   TypeDefConsSelection (..),
+  TypeDefNodeSelection (..),
+  TypeDefParamSelection (..),
   TypeDefSelection (..),
  )
-import Primer.App.Base (TypeDefNodeSelection (..))
 import Primer.Core (GVarName, ID (ID), ModuleName, PrimCon (PrimChar, PrimInt))
 import Primer.Database (
   LastModified (..),
@@ -267,7 +268,11 @@ genTypeDefSelection =
     <$> genTyConName
     <*> G.maybe
       ( G.choice
-          [ TypeDefParamNodeSelection <$> genTyVarName
+          [ TypeDefParamNodeSelection
+              <$> ( TypeDefParamSelection
+                      <$> genTyVarName
+                      <*> G.maybe genID
+                  )
           , TypeDefConsNodeSelection
               <$> ( TypeDefConsSelection
                       <$> genValConName

primer-service/test/outputs/OpenAPI/openapi.json

@@ -318,7 +318,10 @@
                     "DeleteCon",
                     "AddConField",
                     "DeleteConField",
-                    "DeleteTypeParam"
+                    "DeleteTypeParam",
+                    "MakeKType",
+                    "MakeKFun",
+                    "DeleteKind"
                 ],
                 "type": "string"
             },
@@ -854,7 +857,7 @@
                     {
                         "properties": {
                             "contents": {
-                                "type": "string"
+                                "$ref": "#/components/schemas/TypeDefParamSelection"
                             },
                             "tag": {
                                 "enum": [
@@ -889,6 +892,22 @@
                     }
                 ]
             },
+            "TypeDefParamSelection": {
+                "properties": {
+                    "kind": {
+                        "maximum": 9223372036854775807,
+                        "minimum": -9223372036854775808,
+                        "type": "integer"
+                    },
+                    "name": {
+                        "type": "string"
+                    }
+                },
+                "required": [
+                    "name"
+                ],
+                "type": "object"
+            },
             "TypeDefSelection": {
                 "properties": {
                     "def": {

primer/src/Primer/Action.hs

@@ -52,6 +52,7 @@ import Primer.App.Base (
   TypeDefConsFieldSelection (..),
   TypeDefConsSelection (..),
   TypeDefNodeSelection (..),
+  TypeDefParamSelection (..),
   TypeDefSelection (..),
  )
 import Primer.Core (
@@ -470,6 +471,8 @@ applyAction' a = case a of
   RenameCaseBinding x -> \case
     InBind (BindCase z) -> InBind . BindCase <$> renameCaseBinding x z
     _ -> throwError $ CustomFailure a "cannot rename this node - not a case binding"
+  ConstructKType -> const $ throwError $ CustomFailure ConstructKType "type edits currently only allowed in typedefs"
+  ConstructKFun -> const $ throwError $ CustomFailure ConstructKFun "type edits currently only allowed in typedefs"
   where
     termAction f s = \case
       InExpr ze -> InExpr <$> f ze
@@ -1154,7 +1157,13 @@ toProgActionNoInput defs def0 sel0 = \case
     pure [DeleteConField t c sel.index]
   Available.DeleteTypeParam -> do
     (t, p) <- typeParamSel
-    pure [DeleteTypeParam t p]
+    pure [DeleteTypeParam t p.param]
+  Available.MakeKType -> do
+    toProgAction [ConstructKType]
+  Available.MakeKFun -> do
+    toProgAction [ConstructKFun]
+  Available.DeleteKind -> do
+    toProgAction [Delete]
   where
     termSel = case sel0 of
       SelectionDef s -> pure s
@@ -1176,15 +1185,24 @@ toProgActionNoInput defs def0 sel0 = \case
       typeNodeSel >>= \case
         (s0, TypeDefParamNodeSelection s) -> pure (s0, s)
         _ -> Left NeedTypeDefParamSelection
+    typeParamKindSel =
+      typeParamSel >>= \case
+        (t, TypeDefParamSelection p (Just id)) -> pure (t, p, id)
+        _ -> Left NeedTypeDefParamKindSelection
     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]
+        SelectionTypeDef sel -> case sel.node of
+          Just (TypeDefParamNodeSelection _) -> do
+            (t, p, id) <- typeParamKindSel
+            pure [ParamKindAction t p id actions]
+          Just (TypeDefConsNodeSelection _) -> do
+            (t, c, f) <- conFieldSel
+            pure [ConFieldAction t c f.index $ SetCursor f.meta : actions]
+          Nothing -> Left NeedTypeDefNodeSelection
     termDef = first (const NeedTermDef) def0
     typeDef = either Right (Left . const NeedTypeDef) def0
 
@@ -1280,7 +1298,7 @@ toProgActionInput def0 sel0 opt0 = \case
   Available.RenameTypeParam -> do
     opt <- optNoCxt
     (defName, sel) <- typeParamSel
-    pure [RenameTypeParam defName sel opt]
+    pure [RenameTypeParam defName sel.param opt]
   Available.AddCon -> do
     opt <- optNoCxt
     sel <- typeSel
@@ -1291,7 +1309,7 @@ toProgActionInput def0 sel0 opt0 = \case
     opt <- optNoCxt
     sel <- typeSel
     index <- length . astTypeDefParameters <$> typeDef -- for now, we always add on to the end
-    pure [AddTypeParam sel.def index opt $ C.KType ()]
+    pure [AddTypeParam sel.def index opt $ C.KHole ()]
   where
     termSel = case sel0 of
       SelectionDef s -> pure s

primer/src/Primer/Action/Actions.hs

@@ -107,6 +107,10 @@ data Action
     RenameForall Text
   | -- | Rename a case binding
     RenameCaseBinding Text
+  | -- | Construct the kind KType
+    ConstructKType
+  | -- | Construct a function kind
+    ConstructKFun
   deriving stock (Eq, Show, Read, Generic)
   deriving (FromJSON, ToJSON) via PrimerJSON Action
   deriving anyclass (NFData)

primer/src/Primer/Action/Available.hs

@@ -18,6 +18,7 @@ module Primer.Action.Available (
   options,
   forTypeDef,
   forTypeDefParamNode,
+  forTypeDefParamKindNode,
   forTypeDefConsNode,
   forTypeDefConsFieldNode,
 ) where
@@ -69,6 +70,7 @@ import Primer.Core (
   GlobalName (baseName, qualifiedModule),
   HasID (_id),
   ID,
+  Kind' (..),
   KindMeta,
   ModuleName (unModuleName),
   Pattern (PatCon, PatPrim),
@@ -162,6 +164,9 @@ data NoInputAction
   | AddConField
   | DeleteConField
   | DeleteTypeParam
+  | MakeKType
+  | MakeKFun
+  | DeleteKind
   deriving stock (Eq, Ord, Show, Read, Enum, Bounded, Generic)
   deriving (ToJSON, FromJSON) via PrimerJSON NoInputAction
 
@@ -398,6 +403,34 @@ forTypeDefParamNode paramName l Editable tydefs defs tdName td =
         )
         [NoInput DeleteTypeParam]
 
+forTypeDefParamKindNode ::
+  TyVarName ->
+  ID ->
+  Level ->
+  Editable ->
+  TypeDefMap ->
+  DefMap ->
+  TyConName ->
+  ASTTypeDef TypeMeta KindMeta ->
+  [Action]
+forTypeDefParamKindNode _ _ _ NonEditable _ _ _ _ = mempty
+forTypeDefParamKindNode paramName id l Editable tydefs defs tdName td =
+  sortByPriority
+    l
+    $ mwhen (not $ typeInUse tdName td tydefs defs)
+    $ [NoInput MakeKFun] <> case findKind id . snd =<< find ((== paramName) . fst) (astTypeDefParameters td) of
+      Nothing -> []
+      Just (KHole _) -> [NoInput MakeKType]
+      Just _ -> [NoInput DeleteKind]
+  where
+    findKind i k =
+      if getID k == i
+        then Just k
+        else case k of
+          KHole _ -> Nothing
+          KType _ -> Nothing
+          KFun _ k1 k2 -> findKind i k1 <|> findKind i k2
+
 forTypeDefConsNode ::
   Level ->
   Editable ->
@@ -700,6 +733,9 @@ sortByPriority l =
         AddConField -> P.addConField
         DeleteConField -> P.delete
         DeleteTypeParam -> P.delete
+        MakeKType -> P.ktype
+        MakeKFun -> P.kfun
+        DeleteKind -> P.delete
       Input a -> case a of
         MakeCon -> P.useSaturatedValueCon
         MakeInt -> P.makeInt

primer/src/Primer/Action/Errors.hs

@@ -76,6 +76,7 @@ data ActionError
   | NeedTypeDefConsSelection
   | NeedTypeDefConsFieldSelection
   | NeedTypeDefParamSelection
+  | NeedTypeDefParamKindSelection
   | NoNodeSelection
   | ValConNotFound TyConName ValConName
   | FieldIndexOutOfBounds ValConName Int

primer/src/Primer/Action/Priorities.hs

@@ -57,6 +57,10 @@ module Primer.Action.Priorities (
   constructTypeApp,
   constructForall,
 
+  -- * Kind actions.
+  ktype,
+  kfun,
+
   -- * Type def actions.
   addCon,
   addTypeParam,
@@ -168,3 +172,9 @@ addTypeParam _ = 8
 
 addConField :: Level -> Int
 addConField _ = 10
+
+ktype :: Level -> Int
+ktype _ = 10
+
+kfun :: Level -> Int
+kfun _ = 20

primer/src/Primer/Action/ProgAction.hs

@@ -57,6 +57,8 @@ data ProgAction
     SigAction [Action]
   | -- | Execute a sequence of actions on the type of a field of a constructor in a typedef
     ConFieldAction TyConName ValConName Int [Action]
+  | -- | Execute a sequence of actions on the kind of a parameter in a typedef
+    ParamKindAction TyConName TyVarName ID [Action]
   | SetSmartHoles SmartHoles
   | -- | CopyPaste (d,i) as
     --   remembers the tree in def d, node i

primer/src/Primer/App.hs

@@ -104,7 +104,7 @@ import Optics (
  )
 import Optics.State.Operators ((<<%=))
 import Primer.Action (
-  Action,
+  Action (..),
   ActionError (..),
   ProgAction (..),
   applyAction',
@@ -125,6 +125,7 @@ import Primer.App.Base (
   TypeDefConsFieldSelection (..),
   TypeDefConsSelection (..),
   TypeDefNodeSelection (..),
+  TypeDefParamSelection (..),
   TypeDefSelection (..),
   getTypeDefConFieldType,
  )
@@ -138,7 +139,7 @@ import Primer.Core (
   GVarName,
   GlobalName (baseName, qualifiedModule),
   ID (..),
-  Kind' (KType),
+  Kind' (..),
   KindMeta,
   LocalName (LocalName, unLocalName),
   Meta (..),
@@ -167,8 +168,9 @@ import Primer.Core (
   _type,
   _typeMetaLens,
  )
-import Primer.Core.DSL (S, create, emptyHole, tEmptyHole)
+import Primer.Core.DSL (S, create, emptyHole, khole, tEmptyHole)
 import Primer.Core.DSL qualified as DSL
+import Primer.Core.DSL.Meta (kmeta)
 import Primer.Core.Transform (renameTyVar, renameVar, unfoldTApp)
 import Primer.Core.Utils (freeVars, generateKindIDs, generateTypeIDs, regenerateExprIDs, regenerateTypeIDs, _freeTmVars, _freeTyVars, _freeVarsTy)
 import Primer.Def (
@@ -737,7 +739,7 @@ applyProgAction prog = \case
       m' <- updateTypeDef m
       pure
         ( m'
-        , Just $ SelectionTypeDef $ TypeDefSelection type_ $ Just $ TypeDefParamNodeSelection new
+        , Just $ SelectionTypeDef $ TypeDefSelection type_ $ Just $ TypeDefParamNodeSelection $ TypeDefParamSelection new Nothing
         )
     where
       updateTypeDef =
@@ -900,7 +902,7 @@ applyProgAction prog = \case
         )
         tdName
         m
-    pure (m' : ms, Just $ SelectionTypeDef $ TypeDefSelection tdName $ Just $ TypeDefParamNodeSelection paramName)
+    pure (m' : ms, Just $ SelectionTypeDef $ TypeDefSelection tdName $ Just $ TypeDefParamNodeSelection $ TypeDefParamSelection paramName Nothing)
   DeleteTypeParam tdName paramName -> editModuleCross (qualifiedModule tdName) prog $ \(m, ms) -> do
     m' <-
       alterTypeDef
@@ -987,6 +989,35 @@ applyProgAction prog = \case
                             }
                   }
           )
+  ParamKindAction tyName paramName id actions -> editModuleOfCrossType (Just tyName) prog $ \(mod, mods) defName def -> do
+    def' <-
+      def
+        & traverseOf
+          #astTypeDefParameters
+          ( maybe (throwError $ ParamNotFound paramName) pure
+              <=< findAndAdjustA
+                ((== paramName) . fst)
+                ( traverseOf _2 $
+                    flip
+                      ( foldlM $ flip \case
+                          ConstructKType -> modifyKind \_ -> KType <$> kmeta
+                          ConstructKFun -> modifyKind \k -> KFun <$> kmeta <*> khole <*> pure k
+                          Delete -> modifyKind \_ -> KHole <$> kmeta
+                          a -> const $ throwError $ ActionError $ CustomFailure a "unexpected non-kind action"
+                      )
+                      actions
+                )
+          )
+    let mod' = mod & over #moduleTypes (Map.insert defName $ TypeDefAST def')
+    pure (mod' : mods, Nothing)
+    where
+      modifyKind f k =
+        if getID k == id
+          then f k
+          else case k of
+            KHole _ -> pure k
+            KType _ -> pure k
+            KFun m k1 k2 -> KFun m <$> modifyKind f k1 <*> modifyKind f k2
   SetSmartHoles smartHoles ->
     pure $ prog & #progSmartHoles .~ smartHoles
   CopyPasteSig fromIds setup -> case mdefName of