From 2dca202e4f367d26da8e850ead92f3a27aad7bec Mon Sep 17 00:00:00 2001 From: George Thomas Date: Wed, 7 Jun 2023 19:44:54 +0100 Subject: [PATCH] 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 Signed-off-by: Drew Hess --- primer-service/exe-server/Main.hs | 1 + primer-service/src/Primer/OpenAPI.hs | 2 + primer-service/src/Primer/Servant/OpenAPI.hs | 9 +- primer-service/src/Primer/Server.hs | 2 + primer-service/test/Tests/OpenAPI.hs | 3 + .../test/outputs/OpenAPI/openapi.json | 90 +++++++++++++- primer/src/Primer/API.hs | 112 +++++++++++++++++- primer/src/Primer/API/NodeFlavor.hs | 3 + primer/src/Primer/Action/ProgError.hs | 3 +- 9 files changed, 219 insertions(+), 6 deletions(-) diff --git a/primer-service/exe-server/Main.hs b/primer-service/exe-server/Main.hs index ca52de50c..c3006e2e0 100644 --- a/primer-service/exe-server/Main.hs +++ b/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 diff --git a/primer-service/src/Primer/OpenAPI.hs b/primer-service/src/Primer/OpenAPI.hs index 39f9bc2ff..96318e102 100644 --- a/primer-service/src/Primer/OpenAPI.hs +++ b/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 diff --git a/primer-service/src/Primer/Servant/OpenAPI.hs b/primer-service/src/Primer/Servant/OpenAPI.hs index 78aa4d195..92ca7d6d4 100644 --- a/primer-service/src/Primer/Servant/OpenAPI.hs +++ b/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" diff --git a/primer-service/src/Primer/Server.hs b/primer-service/src/Primer/Server.hs index 97a751460..8524c2a99 100644 --- a/primer-service/src/Primer/Server.hs +++ b/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 diff --git a/primer-service/test/Tests/OpenAPI.hs b/primer-service/test/Tests/OpenAPI.hs index 8fbc69286..be6fc6643 100644 --- a/primer-service/test/Tests/OpenAPI.hs +++ b/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] diff --git a/primer-service/test/outputs/OpenAPI/openapi.json b/primer-service/test/outputs/OpenAPI/openapi.json index 9c03a782e..7084e016f 100644 --- a/primer-service/test/outputs/OpenAPI/openapi.json +++ b/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", diff --git a/primer/src/Primer/API.hs b/primer/src/Primer/API.hs index fc26fc769..a8064eb3b 100644 --- a/primer/src/Primer/API.hs +++ b/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 diff --git a/primer/src/Primer/API/NodeFlavor.hs b/primer/src/Primer/API/NodeFlavor.hs index edabd9e54..0a4343530 100644 --- a/primer/src/Primer/API/NodeFlavor.hs +++ b/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) diff --git a/primer/src/Primer/Action/ProgError.hs b/primer/src/Primer/Action/ProgError.hs index 6b5ece12b..cef470806 100644 --- a/primer/src/Primer/Action/ProgError.hs +++ b/primer/src/Primer/Action/ProgError.hs @@ -4,7 +4,7 @@ import Foreword import Data.Aeson (FromJSON (..), ToJSON (..)) import Primer.Action.Errors (ActionError) -import Primer.Core.Meta (GVarName, ModuleName, TyConName, TyVarName, ValConName) +import Primer.Core.Meta (GVarName, ID, ModuleName, TyConName, TyVarName, ValConName) import Primer.Eval.EvalError (EvalError) import Primer.JSON (CustomJSON (..), PrimerJSON) import Primer.Name (Name) @@ -25,6 +25,7 @@ data ProgError ConNotSaturated ValConName | ParamNotFound TyVarName | ParamAlreadyExists TyVarName + | NodeIDNotFound ID | TyConParamClash Name | ValConParamClash Name | ActionError ActionError