feat: expose type of current selection via OpenAPI

This adds a new endpoint to the OpenAPI, but does not change any
existing endpoints.

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

primer-service/exe-server/Main.hs

@@ -384,6 +384,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 (SetSelectionError sel e) = LogMsg $ show (sel, e)
 
 instance ConvertLogMessage APILog LogMsg where
   convert = LogMsg . show

primer-service/src/Primer/OpenAPI.hs

@@ -46,6 +46,7 @@ import Primer.API (
   Prog,
   Selection (..),
   Tree,
+  TypeOrKind,
  )
 import Primer.API qualified as API
 import Primer.API.NodeFlavor (
@@ -149,6 +150,7 @@ deriving via PrimerJSON ApplyActionBody instance ToSchema ApplyActionBody
 deriving via PrimerJSON Selection instance ToSchema Selection
 deriving via PrimerJSON NodeSelection instance ToSchema NodeSelection
 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
+  , setSelection ::
+      mode
+        :- "selection"
+          :> Summary "Set the current selection, and obtain the type of the selected node"
+          :> OperationId "setSelection"
+          :> ReqBody '[JSON] Selection
+          :> Post '[JSON] (Maybe 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.setSelection = API.setSelection sid
     , OpenAPI.createDefinition = createDefinition sid
     , OpenAPI.typeDef = openAPITypeDefServer sid
     , OpenAPI.actions = openAPIActionServer sid
@@ -425,5 +426,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}
+        SetSelectionError sel pe -> err400{errBody = "Error while setting selection (" <> show sel <> "): " <> show pe}
       where
         encode = LT.encodeUtf8 . LT.fromStrict

primer-service/test/Tests/OpenAPI.hs

@@ -34,6 +34,7 @@ import Primer.API (
   Prog (Prog),
   Selection (..),
   Tree,
+  TypeOrKind (..),
   viewTreeExpr,
   viewTreeType,
  )
@@ -328,3 +329,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

@@ -382,7 +382,10 @@
                     "TEmptyHole",
                     "THole",
                     "TFun",
-                    "TApp"
+                    "TApp",
+                    "KType",
+                    "KHole",
+                    "KFun"
                 ],
                 "type": "string"
             },
@@ -716,6 +719,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",
@@ -1371,6 +1414,51 @@
                 "summary": "Redo the last undo"
             }
         },
+        "/openapi/sessions/{sessionId}/selection": {
+            "post": {
+                "operationId": "setSelection",
+                "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": "Set the current selection, and obtain the type of the selected node"
+            }
+        },
         "/openapi/sessions/{sessionId}/typedef": {
             "post": {
                 "operationId": "createTypeDef",

primer/src/Primer/API.hs

@@ -70,6 +70,8 @@ module Primer.API (
   undoAvailable,
   redoAvailable,
   Name (..),
+  TypeOrKind (..),
+  setSelection,
 ) where
 
 import Foreword
@@ -96,10 +98,10 @@ 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 (Action (SetCursor), ActionError, ProgAction (BodyAction, MoveToDef, SigAction), toProgActionInput, toProgActionNoInput)
 import Primer.Action.Available qualified as Available
 import Primer.App (
   App,
@@ -139,6 +141,7 @@ import Primer.Core (
   CaseBranch' (..),
   Expr,
   Expr' (..),
+  ExprMeta,
   GVarName,
   GlobalName (..),
   HasID (..),
@@ -152,16 +155,21 @@ import Primer.Core (
   TyVarName,
   Type,
   Type' (..),
+  TypeMeta,
   ValConName,
   getID,
   unLocalName,
   unsafeMkLocalName,
+  _synthed,
+  _type,
   _typeMeta,
   _typeMetaLens,
  )
+import Primer.Core.DSL (create')
 import Primer.Core.DSL qualified as DSL
 import Primer.Core.Meta (LocalName)
 import Primer.Core.Meta qualified as Core
+import Primer.Core.Utils (generateTypeIDs)
 import Primer.Database (
   OffsetLimit,
   OpStatus,
@@ -263,6 +271,7 @@ data PrimerErr
   | ApplyActionError [ProgAction] ProgError
   | UndoError ProgError
   | RedoError ProgError
+  | SetSelectionError Selection ProgError
   deriving stock (Show)
 
 instance Exception PrimerErr
@@ -388,6 +397,7 @@ data APILog
   | ApplyActionInput (ReqResp (SessionId, ApplyActionBody, Available.InputAction) Prog)
   | Undo (ReqResp SessionId Prog)
   | Redo (ReqResp SessionId Prog)
+  | SetSelection (ReqResp (SessionId, Selection) (Maybe TypeOrKind))
   deriving stock (Show, Read)
 
 type MonadAPILog l m = (MonadLog (WithSeverity l) m, ConvertLogMessage APILog l)
@@ -910,6 +920,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}
 
@@ -1171,3 +1217,32 @@ data NodeSelection = NodeSelection
 
 viewNodeSelection :: App.NodeSelection -> NodeSelection
 viewNodeSelection sel@App.NodeSelection{nodeType} = NodeSelection{nodeType, id = getID sel}
+
+data TypeOrKind = Type Tree | Kind Tree
+  deriving stock (Eq, Show, Read, Generic)
+  deriving (FromJSON, ToJSON) via PrimerJSON TypeOrKind
+  deriving anyclass (NFData)
+
+setSelection :: (MonadIO m, MonadThrow m, MonadAPILog l m) => SessionId -> Selection -> PrimerM m (Maybe TypeOrKind)
+setSelection = curry $ logAPI (noError SetSelection) $ \(sid, sel) ->
+  edit sid (App.Edit $ MoveToDef sel.def : selNode sel)
+    >>= either (throwM . SetSelectionError sel) (pure . (viewTypeOrKind <=< progSelection))
+  where
+    selNode sel = case sel.node of
+      Nothing -> []
+      Just NodeSelection{id, nodeType = BodyNode} -> [BodyAction [SetCursor id]]
+      Just NodeSelection{id, nodeType = SigNode} -> [SigAction [SetCursor id]]
+    viewTypeOrKind :: App.Selection -> Maybe TypeOrKind
+    viewTypeOrKind sel = either viewExprType viewTypeKind . (.meta) <$> sel.selectedNode
+    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

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