feat: expose type of current selection via OpenAPI (#1058)

primer-service/exe-server/Main.hs

@@ -386,6 +386,7 @@ instance ConvertLogMessage PrimerErr LogMsg where
   convert (ApplyActionError as e) = LogMsg $ show (as, e)
   convert (UndoError e) = LogMsg $ show e
   convert (RedoError e) = LogMsg $ show e
+  convert (GetTypeOrKindError sel e) = LogMsg $ show (sel, e)
 
 instance ConvertLogMessage APILog LogMsg where
   convert = LogMsg . show

primer-service/src/Primer/OpenAPI.hs

@@ -53,6 +53,7 @@ import Primer.API (
   Selection,
   Tree,
   TypeDef,
+  TypeOrKind,
   ValCon,
  )
 import Primer.API qualified as API
@@ -175,6 +176,7 @@ deriving via PrimerJSONNamed "TypeDefConsFieldSelection" (TypeDefConsFieldSelect
 deriving via PrimerJSONNamed "DefSelection" (DefSelection ID) instance ToSchema (DefSelection ID)
 deriving via PrimerJSONNamed "NodeSelection" (NodeSelection ID) instance ToSchema (NodeSelection ID)
 deriving via PrimerJSON NodeType instance ToSchema NodeType
+deriving via PrimerJSON TypeOrKind instance ToSchema TypeOrKind
 deriving via PrimerJSON Level instance ToSchema Level
 deriving via PrimerJSON NewSessionReq instance ToSchema NewSessionReq
 

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

@@ -16,7 +16,7 @@ module Primer.Servant.OpenAPI (
 import Foreword
 
 import Data.OpenApi (OpenApi, ToSchema)
-import Primer.API (ApplyActionBody, EvalFullResp, Prog, Selection)
+import Primer.API (ApplyActionBody, EvalFullResp, Prog, Selection, TypeOrKind)
 import Primer.Action.Available qualified as Available
 import Primer.App (Level)
 import Primer.Core (GVarName, ModuleName)
@@ -98,6 +98,13 @@ data SessionAPI mode = SessionAPI
           :> Get '[JSON] Prog
   , getSessionName :: GetSessionName mode
   , setSessionName :: SetSessionName mode
+  , getTypeOrKind ::
+      mode
+        :- "selection"
+          :> Summary "Get the type/kind of a particular node"
+          :> OperationId "getTypeOrKind"
+          :> ReqBody '[JSON] Selection
+          :> Get '[JSON] TypeOrKind
   , createDefinition ::
       mode
         :- "def"

primer-service/src/Primer/Server.hs

@@ -180,6 +180,7 @@ openAPISessionServer sid =
     , OpenAPI.getProgram = API.getProgram' sid
     , OpenAPI.getSessionName = API.getSessionName sid
     , OpenAPI.setSessionName = renameSession sid
+    , OpenAPI.getTypeOrKind = API.getSelectionTypeOrKind sid
     , OpenAPI.createDefinition = createDefinition sid
     , OpenAPI.typeDef = openAPITypeDefServer sid
     , OpenAPI.actions = openAPIActionServer sid
@@ -427,5 +428,6 @@ serve ss q v port origins logger = do
         ToProgActionError a ae -> err400{errBody = "Error while converting action (" <> show a <> "): " <> show ae}
         UndoError pe -> err500{errBody = "Undo failed: " <> show pe}
         RedoError pe -> err500{errBody = "Redo failed: " <> show pe}
+        GetTypeOrKindError sel pe -> err400{errBody = "Error while getting type/kind (" <> show sel <> "): " <> show pe}
       where
         encode = LT.encodeUtf8 . LT.fromStrict

primer-service/test/Tests/OpenAPI.hs

@@ -34,6 +34,7 @@ import Primer.API (
   Selection,
   Tree,
   TypeDef (..),
+  TypeOrKind (..),
   ValCon (..),
   viewTreeExpr,
   viewTreeType,
@@ -374,3 +375,5 @@ instance Arbitrary CreateTypeDefBody where
   arbitrary = CreateTypeDefBody <$> arbitrary <*> arbitrary <*> arbitrary
 instance Arbitrary NewSessionReq where
   arbitrary = NewSessionReq <$> arbitrary
+instance Arbitrary TypeOrKind where
+  arbitrary = hedgehog $ G.choice [Type <$> genTree, Kind <$> genTree]

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

@@ -408,7 +408,10 @@
                     "THole",
                     "TFun",
                     "TApp",
-                    "PatternWildcard"
+                    "PatternWildcard",
+                    "KType",
+                    "KHole",
+                    "KFun"
                 ],
                 "type": "string"
             },
@@ -891,6 +894,46 @@
                 ],
                 "type": "object"
             },
+            "TypeOrKind": {
+                "oneOf": [
+                    {
+                        "properties": {
+                            "contents": {
+                                "$ref": "#/components/schemas/Tree"
+                            },
+                            "tag": {
+                                "enum": [
+                                    "Type"
+                                ],
+                                "type": "string"
+                            }
+                        },
+                        "required": [
+                            "tag",
+                            "contents"
+                        ],
+                        "type": "object"
+                    },
+                    {
+                        "properties": {
+                            "contents": {
+                                "$ref": "#/components/schemas/Tree"
+                            },
+                            "tag": {
+                                "enum": [
+                                    "Kind"
+                                ],
+                                "type": "string"
+                            }
+                        },
+                        "required": [
+                            "tag",
+                            "contents"
+                        ],
+                        "type": "object"
+                    }
+                ]
+            },
             "UUID": {
                 "example": "00000000-0000-0000-0000-000000000000",
                 "format": "uuid",
@@ -1574,6 +1617,51 @@
                 "summary": "Redo the last undo"
             }
         },
+        "/openapi/sessions/{sessionId}/selection": {
+            "get": {
+                "operationId": "getTypeOrKind",
+                "parameters": [
+                    {
+                        "description": "The session ID",
+                        "in": "path",
+                        "name": "sessionId",
+                        "required": true,
+                        "schema": {
+                            "format": "uuid",
+                            "type": "string"
+                        }
+                    }
+                ],
+                "requestBody": {
+                    "content": {
+                        "application/json;charset=utf-8": {
+                            "schema": {
+                                "$ref": "#/components/schemas/Selection"
+                            }
+                        }
+                    }
+                },
+                "responses": {
+                    "200": {
+                        "content": {
+                            "application/json;charset=utf-8": {
+                                "schema": {
+                                    "$ref": "#/components/schemas/TypeOrKind"
+                                }
+                            }
+                        },
+                        "description": ""
+                    },
+                    "400": {
+                        "description": "Invalid `body`"
+                    },
+                    "404": {
+                        "description": "`sessionId` not found"
+                    }
+                },
+                "summary": "Get the type/kind of a particular node"
+            }
+        },
         "/openapi/sessions/{sessionId}/typedef": {
             "post": {
                 "operationId": "createTypeDef",

primer/src/Primer/API.hs

@@ -69,6 +69,8 @@ module Primer.API (
   undoAvailable,
   redoAvailable,
   Name (..),
+  TypeOrKind (..),
+  getSelectionTypeOrKind,
 ) where
 
 import Foreword
@@ -95,11 +97,12 @@ import Control.Monad.Writer (MonadWriter)
 import Control.Monad.Zip (MonadZip)
 import Data.Map qualified as Map
 import Data.Tuple.Extra (curry3)
-import Optics (ifoldr, over, traverseOf, view, (^.))
+import Optics (ifoldr, over, preview, to, traverseOf, view, (%), (^.), _Just)
 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.App (
   App,
   DefSelection (..),
@@ -112,7 +115,6 @@ import Primer.App (
   MutationRequest,
   NodeSelection (..),
   NodeType (..),
-  ProgError,
   QueryAppM,
   Question (GenerateName),
   Selection' (..),
@@ -146,6 +148,7 @@ import Primer.Core (
   CaseFallback' (CaseExhaustive, CaseFallback),
   Expr,
   Expr' (..),
+  ExprMeta,
   GVarName,
   GlobalName (..),
   HasID (..),
@@ -164,12 +167,18 @@ import Primer.Core (
   getID,
   unLocalName,
   unsafeMkLocalName,
+  _bindMeta,
+  _exprMetaLens,
+  _synthed,
+  _type,
   _typeMeta,
   _typeMetaLens,
  )
+import Primer.Core.DSL (create')
 import Primer.Core.DSL qualified as DSL
 import Primer.Core.Meta (LocalName, Pattern (PatCon, PatPrim))
 import Primer.Core.Meta qualified as Core
+import Primer.Core.Utils (generateTypeIDs)
 import Primer.Database (
   OffsetLimit,
   OpStatus,
@@ -221,8 +230,9 @@ import Primer.Log (
 import Primer.Module (moduleDefsQualified, moduleName, moduleTypesQualifiedMeta)
 import Primer.Name qualified as Name
 import Primer.Primitives (primDefType)
-import Primer.TypeDef (ASTTypeDef (..), forgetTypeDefMetadata, typeDefNameHints, typeDefParameters)
+import Primer.TypeDef (ASTTypeDef (..), forgetTypeDefMetadata, typeDefKind, typeDefNameHints, typeDefParameters)
 import Primer.TypeDef qualified as TypeDef
+import Primer.Zipper (SomeNode (..), findNodeWithParent, findType)
 import StmContainers.Map qualified as StmMap
 
 -- | The API environment.
@@ -274,6 +284,7 @@ data PrimerErr
   | ApplyActionError [ProgAction] ProgError
   | UndoError ProgError
   | RedoError ProgError
+  | GetTypeOrKindError Selection ProgError
   deriving stock (Show)
 
 instance Exception PrimerErr
@@ -399,6 +410,7 @@ data APILog
   | ApplyActionInput (ReqResp (SessionId, ApplyActionBody, Available.InputAction) Prog)
   | Undo (ReqResp SessionId Prog)
   | Redo (ReqResp SessionId Prog)
+  | GetTypeOrKind (ReqResp (SessionId, Selection) TypeOrKind)
   deriving stock (Show, Read)
 
 type MonadAPILog l m = (MonadLog (WithSeverity l) m, ConvertLogMessage APILog l)
@@ -985,6 +997,42 @@ viewTreeType' t0 = case t0 of
   where
     nodeId = t0 ^. _typeMetaLens
 
+-- | Like 'viewTreeType', but for kinds. This generates ids
+viewTreeKind :: Kind -> Tree
+viewTreeKind = flip evalState (0 :: Integer) . go
+  where
+    go k = do
+      id' <- get
+      let nodeId = "kind" <> show id'
+      modify succ
+      case k of
+        KType ->
+          pure $
+            Tree
+              { nodeId
+              , body = NoBody Flavor.KType
+              , childTrees = []
+              , rightChild = Nothing
+              }
+        KHole ->
+          pure $
+            Tree
+              { nodeId
+              , body = NoBody Flavor.KHole
+              , childTrees = []
+              , rightChild = Nothing
+              }
+        KFun k1 k2 -> do
+          k1tree <- go k1
+          k2tree <- go k2
+          pure $
+            Tree
+              { nodeId
+              , body = NoBody Flavor.KFun
+              , childTrees = [k1tree, k2tree]
+              , rightChild = Nothing
+              }
+
 globalName :: GlobalName k -> Name
 globalName n = Name{qualifiedModule = Just $ Core.qualifiedModule n, baseName = Core.baseName n}
 
@@ -1228,3 +1276,61 @@ redo =
 
 -- | 'App.Selection' without any node metadata.
 type Selection = App.Selection' ID
+
+data TypeOrKind = Type Tree | Kind Tree
+  deriving stock (Eq, Show, Read, Generic)
+  deriving (FromJSON, ToJSON) via PrimerJSON TypeOrKind
+  deriving anyclass (NFData)
+
+getSelectionTypeOrKind ::
+  (MonadIO m, MonadThrow m, MonadAPILog l m) =>
+  SessionId ->
+  Selection ->
+  PrimerM m TypeOrKind
+getSelectionTypeOrKind = curry $ logAPI (noError GetTypeOrKind) $ \(sid, sel0) -> do
+  prog <- getProgram sid
+  let allDefs = progAllDefs prog
+      allTypeDefs = progAllTypeDefsMeta prog
+  case sel0 of
+    SelectionDef sel -> do
+      def <- snd <$> findASTDef allDefs sel.def
+      case sel.node of
+        -- definition itself selected - return its declared type
+        Nothing -> pure $ Type $ viewTreeType $ astDefType def
+        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
+              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
+    SelectionTypeDef sel -> do
+      def <- snd <$> findASTTypeDef allTypeDefs sel.def
+      case sel.node of
+        -- type def itself selected - return its kind
+        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) $
+            find ((== p) . fst) (astTypeDefParameters def)
+        -- constructor node selected - return the type to which it belongs
+        Just (TypeDefConsNodeSelection _) ->
+          pure . Type . viewTreeType' . mkIds $
+            foldl' (\t -> TApp () t . TVar ()) (TCon () sel.def) (map fst $ astTypeDefParameters def)
+  where
+    trivialTree = Tree{nodeId = "seltype-0", childTrees = [], rightChild = Nothing, body = NoBody Flavor.EmptyHole}
+    viewExprType :: ExprMeta -> TypeOrKind
+    viewExprType = Type . fromMaybe trivialTree . viewExprType'
+    viewExprType' :: ExprMeta -> Maybe Tree
+    viewExprType' = preview $ _type % _Just % _synthed % to (viewTreeType' . mkIds)
+    -- 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
+    viewTypeKind :: TypeMeta -> TypeOrKind
+    viewTypeKind = Kind . fromMaybe trivialTree . viewTypeKind'
+    viewTypeKind' :: TypeMeta -> Maybe Tree
+    viewTypeKind' = preview $ _type % _Just % to viewTreeKind

primer/src/Primer/API/NodeFlavor.hs

@@ -64,6 +64,9 @@ data NodeFlavorNoBody
   | TFun
   | TApp
   | PatternWildcard
+  | KType
+  | KHole
+  | KFun
   deriving stock (Show, Read, Eq, Generic, Enum, Bounded)
   deriving (ToJSON, FromJSON) via PrimerJSON NodeFlavorNoBody
   deriving anyclass (NFData)