From debdc305fb19d881655b541749b0f8b34770a6f3 Mon Sep 17 00:00:00 2001 From: Ben Price Date: Tue, 30 May 2023 18:37:45 +0100 Subject: [PATCH 1/2] 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 --- 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 | 79 +++++++++++++++- primer/src/Primer/API/NodeFlavor.hs | 3 + 8 files changed, 185 insertions(+), 4 deletions(-) diff --git a/primer-service/exe-server/Main.hs b/primer-service/exe-server/Main.hs index 14a251de3..4b4a40e72 100644 --- a/primer-service/exe-server/Main.hs +++ b/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 diff --git a/primer-service/src/Primer/OpenAPI.hs b/primer-service/src/Primer/OpenAPI.hs index 91db986b5..31cff009a 100644 --- a/primer-service/src/Primer/OpenAPI.hs +++ b/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 diff --git a/primer-service/src/Primer/Servant/OpenAPI.hs b/primer-service/src/Primer/Servant/OpenAPI.hs index 78aa4d195..18d2a6145 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 + , 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" diff --git a/primer-service/src/Primer/Server.hs b/primer-service/src/Primer/Server.hs index 1ab766ec6..0eba54bcc 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.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 diff --git a/primer-service/test/Tests/OpenAPI.hs b/primer-service/test/Tests/OpenAPI.hs index a00773e92..6246d8c37 100644 --- a/primer-service/test/Tests/OpenAPI.hs +++ b/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] diff --git a/primer-service/test/outputs/OpenAPI/openapi.json b/primer-service/test/outputs/OpenAPI/openapi.json index c4bafb2c5..522aa6ade 100644 --- a/primer-service/test/outputs/OpenAPI/openapi.json +++ b/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", diff --git a/primer/src/Primer/API.hs b/primer/src/Primer/API.hs index 76f968907..ad6d9e361 100644 --- a/primer/src/Primer/API.hs +++ b/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 diff --git a/primer/src/Primer/API/NodeFlavor.hs b/primer/src/Primer/API/NodeFlavor.hs index ad8334e96..bea78e4da 100644 --- a/primer/src/Primer/API/NodeFlavor.hs +++ b/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) From 288510691997154cb5e48bf15d8462a74c05bd33 Mon Sep 17 00:00:00 2001 From: Drew Hess Date: Wed, 7 Jun 2023 13:35:33 +0100 Subject: [PATCH 2/2] fix: work around an OpenAPI 3.0 spec issue regarding nullable results This fixes an issue where the OpenAPI schema check failed when `setSelection` returns `Nothing`. This should never happen in theory and is just a quirk of our typechecker implementation, but our OpenAPI adapter can't properly handle this scenario, and the OpenAPI 3.0 spec isn't clear how to do so, either. To work around this, we add a wrapped version of `setSelection` that converts `Nothing` results to an API error. Signed-off-by: Drew Hess --- primer-service/exe-server/Main.hs | 1 + primer-service/src/Primer/Servant/OpenAPI.hs | 2 +- primer-service/src/Primer/Server.hs | 3 ++- primer/src/Primer/API.hs | 19 +++++++++++++++++++ 4 files changed, 23 insertions(+), 2 deletions(-) diff --git a/primer-service/exe-server/Main.hs b/primer-service/exe-server/Main.hs index 4b4a40e72..8a51f0c08 100644 --- a/primer-service/exe-server/Main.hs +++ b/primer-service/exe-server/Main.hs @@ -385,6 +385,7 @@ instance ConvertLogMessage PrimerErr LogMsg where convert (UndoError e) = LogMsg $ show e convert (RedoError e) = LogMsg $ show e convert (SetSelectionError sel e) = LogMsg $ show (sel, e) + convert (SetSelectionNothing sel) = LogMsg $ show sel instance ConvertLogMessage APILog LogMsg where convert = LogMsg . show diff --git a/primer-service/src/Primer/Servant/OpenAPI.hs b/primer-service/src/Primer/Servant/OpenAPI.hs index 18d2a6145..c45ea1ad2 100644 --- a/primer-service/src/Primer/Servant/OpenAPI.hs +++ b/primer-service/src/Primer/Servant/OpenAPI.hs @@ -104,7 +104,7 @@ data SessionAPI mode = SessionAPI :> Summary "Set the current selection, and obtain the type of the selected node" :> OperationId "setSelection" :> ReqBody '[JSON] Selection - :> Post '[JSON] (Maybe TypeOrKind) + :> Post '[JSON] TypeOrKind , createDefinition :: mode :- "def" diff --git a/primer-service/src/Primer/Server.hs b/primer-service/src/Primer/Server.hs index 0eba54bcc..b2c3309e5 100644 --- a/primer-service/src/Primer/Server.hs +++ b/primer-service/src/Primer/Server.hs @@ -180,7 +180,7 @@ openAPISessionServer sid = , OpenAPI.getProgram = API.getProgram' sid , OpenAPI.getSessionName = API.getSessionName sid , OpenAPI.setSessionName = renameSession sid - , OpenAPI.setSelection = API.setSelection sid + , OpenAPI.setSelection = API.setSelection' sid , OpenAPI.createDefinition = createDefinition sid , OpenAPI.typeDef = openAPITypeDefServer sid , OpenAPI.actions = openAPIActionServer sid @@ -427,5 +427,6 @@ serve ss q v port origins logger = do 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} + SetSelectionNothing sel -> err400{errBody = "Error while setting selection (" <> show sel <> "): setSelection returned Nothing"} where encode = LT.encodeUtf8 . LT.fromStrict diff --git a/primer/src/Primer/API.hs b/primer/src/Primer/API.hs index ad6d9e361..427f95a3e 100644 --- a/primer/src/Primer/API.hs +++ b/primer/src/Primer/API.hs @@ -72,6 +72,7 @@ module Primer.API ( Name (..), TypeOrKind (..), setSelection, + setSelection', ) where import Foreword @@ -272,6 +273,7 @@ data PrimerErr | UndoError ProgError | RedoError ProgError | SetSelectionError Selection ProgError + | SetSelectionNothing Selection deriving stock (Show) instance Exception PrimerErr @@ -1246,3 +1248,20 @@ setSelection = curry $ logAPI (noError SetSelection) $ \(sid, sel) -> viewTypeKind = Kind . fromMaybe trivialTree . viewTypeKind' viewTypeKind' :: TypeMeta -> Maybe Tree viewTypeKind' = preview $ _type % _Just % to viewTreeKind + +-- | Strip 'Maybe' off of 'setSelection''s return type. +-- +-- For technical reasons owing to our typechecker's design, +-- 'setSelection' returns a 'Maybe TypeOrKind', but that curently +-- causes problems with our OpenAPI adapter due to the OpenAPI 3.0 +-- specification not properly supporting nullable results. To work +-- around this, we strip 'setSelection''s return type down to +-- 'TypeOrKind' in normal operation, and throw an error otherwise. In +-- practice, this error should never occur (though 'setSelection' may +-- of course fail for other reasons; e.g., the client attempts to +-- select invalid ID). +-- +-- When we can update to OpenAPI 3.1, or our adapter otherwise adds +-- support for nullable results, we may drop this method. +setSelection' :: (MonadIO m, MonadThrow m, MonadAPILog l m) => SessionId -> Selection -> PrimerM m TypeOrKind +setSelection' sid sel = setSelection sid sel >>= maybe (throwM $ SetSelectionNothing sel) pure