refactor: add parameter for kind meta to Expr' and Type'

This is usually instantiated to `()`, matching the previous hardcoded
choice. There are intended to be no functional changes in this commit,
it is simply setup for adding IDs to kinds in foralls (and thus to enable
actions in those positions).

(Note that there are a couple of TODOs added in comments which will be
addressed in a subsequent commit.)

Signed-off-by: Ben Price <ben@hackworthltd.com>

primer-api/src/Primer/API.hs

@@ -183,6 +183,7 @@ import Primer.Core (
   _exprMetaLens,
   _kindMeta,
   _type,
+  _typeKindMeta,
   _typeMeta,
   _typeMetaLens,
  )
@@ -409,8 +410,8 @@ data APILog
   | GetProgram' (ReqResp SessionId Prog)
   | GetProgram (ReqResp SessionId App.Prog)
   | Edit (ReqResp (SessionId, MutationRequest) (Either ProgError App.Prog))
-  | VariablesInScope (ReqResp (SessionId, (GVarName, ID)) (Either ProgError (([(TyVarName, Kind' ())], [(LVarName, Type' ())]), [(GVarName, Type' ())])))
-  | GenerateNames (ReqResp (SessionId, ((GVarName, ID), Either (Maybe (Type' ())) (Maybe (Kind' ())))) (Either ProgError [Name.Name]))
+  | VariablesInScope (ReqResp (SessionId, (GVarName, ID)) (Either ProgError (([(TyVarName, Kind' ())], [(LVarName, Type' () ())]), [(GVarName, Type' () ())])))
+  | GenerateNames (ReqResp (SessionId, ((GVarName, ID), Either (Maybe (Type' () ())) (Maybe (Kind' ())))) (Either ProgError [Name.Name]))
   | EvalStep (ReqResp (SessionId, EvalReq) (Either ProgError EvalResp))
   | EvalFull (ReqResp (SessionId, EvalFullReq) (Either ProgError App.EvalFullResp))
   | EvalFull' (ReqResp (SessionId, Maybe TerminationBound, Maybe NormalOrderOptions, GVarName) EvalFullResp)
@@ -751,7 +752,7 @@ viewProg p =
                           astTypeDefConstructors t <&> \(TypeDef.ValCon nameCon argsCon) ->
                             ValCon
                               { name = nameCon
-                              , fields = viewTreeType' . over _typeMeta (show . view _id) <$> argsCon
+                              , fields = viewTreeType' . over _typeKindMeta (const @_ @() "") . over _typeMeta (show . view _id) <$> argsCon
                               }
                   }
             )
@@ -767,10 +768,11 @@ viewProg p =
                         Def.DefPrim d' -> viewTreeType' $ labelNodes $ primDefType d'
                           where
                             labelNodes =
-                              flip evalState (0 :: Int) . traverseOf _typeMeta \() -> do
-                                n <- get
-                                put $ n + 1
-                                pure $ "primtype_" <> Name.unName (Core.baseName name) <> "_" <> show n
+                              let f () = do
+                                    n <- get
+                                    put $ n + 1
+                                    pure $ "primtype_" <> Name.unName (Core.baseName name) <> "_" <> show n
+                               in flip evalState (0 :: Int) . (traverseOf _typeKindMeta f <=< traverseOf _typeMeta f)
                   }
             )
               <$> Map.assocs (moduleDefsQualified m)
@@ -955,11 +957,11 @@ viewTreeExpr e0 = case e0 of
 
 -- | Similar to 'viewTreeExpr', but for 'Type's
 viewTreeType :: Type -> Tree
-viewTreeType = viewTreeType' . over _typeMeta (show . view _id)
+viewTreeType = viewTreeType' . over _typeKindMeta (const @_ @() "") . over _typeMeta (show . view _id)
 
 -- | Like 'viewTreeType', but with the flexibility to accept arbitrary textual node identifiers,
 -- rather than using the type's numeric IDs.
-viewTreeType' :: Type' Text -> Tree
+viewTreeType' :: Type' Text Text -> Tree
 viewTreeType' t0 = case t0 of
   TEmptyHole _ ->
     Tree
@@ -1073,14 +1075,14 @@ variablesInScope ::
   (MonadIO m, MonadThrow m, MonadAPILog l m) =>
   SessionId ->
   (GVarName, ID) ->
-  PrimerM m (Either ProgError (([(TyVarName, Kind' ())], [(LVarName, Type' ())]), [(GVarName, Type' ())]))
+  PrimerM m (Either ProgError (([(TyVarName, Kind' ())], [(LVarName, Type' () ())]), [(GVarName, Type' () ())]))
 variablesInScope = curry $ logAPI (leftResultError VariablesInScope) $ \(sid, (defname, exprid)) ->
   liftQueryAppM (handleQuestion (App.VariablesInScope defname exprid)) sid
 
 generateNames ::
   (MonadIO m, MonadThrow m, MonadAPILog l m) =>
   SessionId ->
-  ((GVarName, ID), Either (Maybe (Type' ())) (Maybe (Kind' ()))) ->
+  ((GVarName, ID), Either (Maybe (Type' () ())) (Maybe (Kind' ()))) ->
   PrimerM m (Either ProgError [Name.Name])
 generateNames = curry $ logAPI (leftResultError GenerateNames) $ \(sid, ((defname, exprid), tk)) ->
   liftQueryAppM (handleQuestion $ GenerateName defname exprid tk) sid
@@ -1379,12 +1381,12 @@ getSelectionTypeOrKind = curry $ logAPI (noError GetTypeOrKind) $ \(sid, sel0) -
     viewExprType = Type . fromMaybe trivialTree . viewExprType'
     viewExprType' :: ExprMeta -> Maybe Tree
     viewExprType' = preview $ _type % _Just % to (viewTreeType' . mkIds . getAPIType)
-    isHole :: Type' a -> Bool
+    isHole :: Type' a b -> Bool
     isHole = \case
       THole{} -> True
       TEmptyHole{} -> True
       _ -> False
-    getAPIType :: TypeCache -> Type' ()
+    getAPIType :: TypeCache -> Type' () ()
     getAPIType = \case
       TCSynthed t -> t
       TCChkedAt t -> t
@@ -1396,8 +1398,8 @@ getSelectionTypeOrKind = curry $ logAPI (noError GetTypeOrKind) $ \(sid, sel0) -
         -- if neither is a hole (in which case the two are consistent), we choose the synthed type
         | otherwise -> tcSynthed
     -- We prefix ids to keep them unique from other ids in the emitted program
-    mkIds :: Type' () -> Type' Text
-    mkIds = over _typeMeta (("seltype-" <>) . show . getID) . create' . generateTypeIDs
+    mkIds :: Type' () () -> Type' Text Text
+    mkIds = over _typeKindMeta (const @_ @() "") . over _typeMeta (("seltype-" <>) . show . getID) . create' . generateTypeIDs
     mkIdsK :: Kind' () -> Kind' Text
     mkIdsK = over _kindMeta (("selkind-" <>) . show . getID) . create' . generateKindIDs
     viewTypeKind :: TypeMeta -> TypeOrKind

primer-service/src/Primer/Client.hs

@@ -149,13 +149,13 @@ edit sid req = apiClient // API.sessionsAPI // API.sessionAPI /: sid // API.edit
 variablesInScope ::
   SessionId ->
   (GVarName, ID) ->
-  ClientM (Either ProgError (([(TyVarName, Kind' ())], [(LVarName, Type' ())]), [(GVarName, Type' ())]))
+  ClientM (Either ProgError (([(TyVarName, Kind' ())], [(LVarName, Type' () ())]), [(GVarName, Type' () ())]))
 variablesInScope sid ctx = apiClient // API.sessionsAPI // API.sessionAPI /: sid // API.questionAPI // API.variablesInScope /: ctx
 
 -- | As 'Primer.API.generateNames'.
 generateNames ::
   SessionId ->
-  ((GVarName, ID), Either (Maybe (Type' ())) (Maybe (Kind' ()))) ->
+  ((GVarName, ID), Either (Maybe (Type' () ())) (Maybe (Kind' ()))) ->
   ClientM (Either ProgError [Name])
 generateNames sid ctx = apiClient // API.sessionsAPI // API.sessionAPI /: sid // API.questionAPI // API.generateNames /: ctx
 

primer-service/src/Primer/Servant/API.hs

@@ -161,7 +161,7 @@ data QuestionAPI mode = QuestionAPI
         :- "variables-in-scope"
           :> Summary "Ask what variables are in scope for the given node ID"
           :> ReqBody '[JSON] (GVarName, ID)
-          :> Post '[JSON] (Either ProgError (([(TyVarName, Kind' ())], [(LVarName, Type' ())]), [(GVarName, Type' ())]))
+          :> Post '[JSON] (Either ProgError (([(TyVarName, Kind' ())], [(LVarName, Type' () ())]), [(GVarName, Type' () ())]))
   , generateNames ::
       mode
         :- "generate-names"
@@ -172,7 +172,7 @@ data QuestionAPI mode = QuestionAPI
               \(since it doesn't modify any state) but we need \
               \to provide a request body, which isn't well \
               \supported for GET requests."
-          :> ReqBody '[JSON] ((GVarName, ID), Either (Maybe (Type' ())) (Maybe (Kind' ())))
+          :> ReqBody '[JSON] ((GVarName, ID), Either (Maybe (Type' () ())) (Maybe (Kind' ())))
           :> Post '[JSON] (Either ProgError [Name])
   }
   deriving stock (Generic)

primer/gen/Primer/Gen/Core/Typed.hs

@@ -125,9 +125,9 @@ types/expressions, but it is easy to have a post-processing step of adding IDs
 and empty TypeCaches to everything.
 -}
 
-type TypeG = Type' ()
+type TypeG = Type' () ()
 
-type ExprG = Expr' () ()
+type ExprG = Expr' () () ()
 
 newtype WT a = WT {unWT :: ReaderT Cxt TestM a}
   deriving newtype

primer/src/Primer/Action/Errors.hs

@@ -45,7 +45,7 @@ data ActionError
   | CaseBranchAlreadyExists Pattern
   | CaseBranchNotExist Pattern
   | -- | Attempted to add a branch for an unexpected ctor
-    CaseBranchNotCon Pattern (Type' ())
+    CaseBranchNotCon Pattern (Type' () ())
   | -- TODO: semantic errors.
     -- https://github.com/hackworthltd/primer/issues/8
     SaturatedApplicationError (Either Text TypeError)
@@ -62,7 +62,7 @@ data ActionError
     -- The extra unit is to avoid having two constructors with a single
     -- TypeError field, breaking our MonadNestedError machinery...
     ImportFailed () TypeError
-  | NeedTFun (Type' ())
+  | NeedTFun (Type' () ())
   | NeedType SomeNode
   | NeedGlobal Available.Option
   | NeedLocal Available.Option

primer/src/Primer/Action/ProgAction.hs

@@ -44,7 +44,7 @@ data ProgAction
   | -- | Delete the value constructor with the given name, from the given type
     DeleteCon TyConName ValConName
   | -- | Add a new field, at the given index, to the given constructor
-    AddConField TyConName ValConName Int (Type' ())
+    AddConField TyConName ValConName Int (Type' () ())
   | -- | Delete the field at the given index of the given value constructor, in the given type
     DeleteConField TyConName ValConName Int
   | -- | Add a parameter at the given position, with the given name and kind, in the given type

primer/src/Primer/App.hs

@@ -715,7 +715,7 @@ applyProgAction prog = \case
                   TCEmb (TCBoth t1 t2) -> TCEmb (TCBoth (updateType t1) (updateType t2))
             )
       updateName n = if n == old then new else n
-      updateType :: Data a => Type' a -> Type' a
+      updateType :: (Data a, Data b) => Type' a b -> Type' a b
       updateType = transform $ over (#_TCon % _2) updateName
   RenameCon type_ old (unsafeMkGlobalName . (fmap unName (unModuleName (qualifiedModule type_)),) -> new) ->
     editModuleCross (qualifiedModule type_) prog $ \(m, ms) -> do
@@ -1832,7 +1832,7 @@ alterTypeDef f type_ m = do
 transformCaseBranches ::
   MonadEdit m ProgError =>
   TyConName ->
-  (Maybe (Type' ()) -> ([CaseBranch], CaseFallback) -> m ([CaseBranch], CaseFallback)) ->
+  (Maybe (Type' () ()) -> ([CaseBranch], CaseFallback) -> m ([CaseBranch], CaseFallback)) ->
   Expr ->
   m Expr
 transformCaseBranches type_ f = transformM $ \case
@@ -1853,7 +1853,7 @@ transformCaseBranches type_ f = transformM $ \case
 transformNamedCaseBranches ::
   MonadEdit m ProgError =>
   TyConName ->
-  (Maybe (Type' ()) -> [CaseBranch] -> m [CaseBranch]) ->
+  (Maybe (Type' () ()) -> [CaseBranch] -> m [CaseBranch]) ->
   Expr ->
   m Expr
 transformNamedCaseBranches type_ f = transformCaseBranches type_ (\m (bs, fb) -> (,fb) <$> f m bs)
@@ -1865,7 +1865,7 @@ transformNamedCaseBranch ::
   TyConName ->
   ValConName ->
   -- This only supports ADT case branches, since we cannot edit primitives
-  (Maybe (Type' ()) -> CaseBranch -> m CaseBranch) ->
+  (Maybe (Type' () ()) -> CaseBranch -> m CaseBranch) ->
   Expr ->
   m Expr
 transformNamedCaseBranch type_ con f = transformNamedCaseBranches type_ $ \m ->

primer/src/Primer/App/Base.hs

@@ -147,7 +147,7 @@ data NodeSelection a = NodeSelection
 instance HasID a => HasID (NodeSelection a) where
   _id = lens (getID . (.meta)) (flip $ over #meta . set _id)
 
-getTypeDefConFieldType :: ASTTypeDef a b -> ValConName -> Int -> Maybe (Type' a)
+getTypeDefConFieldType :: ASTTypeDef a b -> ValConName -> Int -> Maybe (Type' a ())
 getTypeDefConFieldType def con index =
   flip atMay index . valConArgs
     =<< find ((== con) . valConName) (astTypeDefConstructors def)