DRY Available.options, Action.toProgActionNoInput and Action.toProgActionInput

primer-service/exe-server/Main.hs

@@ -344,7 +344,9 @@ instance ConvertLogMessage SomeException LogMsg where
 instance ConvertLogMessage PrimerErr LogMsg where
   convert (DatabaseErr e) = LogMsg e
   convert (UnknownDef e) = LogMsg $ show e
+  convert (UnknownTypeDef e) = LogMsg $ show e
   convert (UnexpectedPrimDef e) = LogMsg $ show e
+  convert (UnexpectedPrimTypeDef e) = LogMsg $ show e
   convert (AddDefError m n e) = LogMsg $ show (m, n, e)
   convert (AddTypeDefError tc vcs e) = LogMsg $ show (tc, vcs, e)
   convert (ActionOptionsNoID e) = LogMsg $ show e

primer-service/src/Primer/OpenAPI.hs

@@ -10,6 +10,12 @@ module Primer.OpenAPI (
 import Foreword
 
 import Data.Aeson (
+  FromJSON,
+  GFromJSON,
+  GToEncoding,
+  GToJSON,
+  ToJSON,
+  Zero,
   toJSON,
  )
 import Data.OpenApi (
@@ -27,6 +33,7 @@ import Data.OpenApi.Internal.Schema (
   rename,
   timeSchema,
  )
+import Data.Text qualified as T
 import Data.Time (
   UTCTime (..),
   fromGregorian,
@@ -42,10 +49,11 @@ import Primer.API (
   Module,
   NewSessionReq,
   NodeBody,
-  NodeSelection (..),
   Prog,
-  Selection (..),
+  Selection,
   Tree,
+  TypeDef,
+  ValCon,
  )
 import Primer.API qualified as API
 import Primer.API.NodeFlavor (
@@ -56,25 +64,30 @@ import Primer.API.NodeFlavor (
  )
 import Primer.API.RecordPair (RecordPair)
 import Primer.Action.Available qualified as Available
-import Primer.App (NodeType)
-import Primer.App.Base (Level)
+import Primer.App (DefSelection, NodeSelection, NodeType, TypeDefSelection)
+import Primer.App.Base (Level, TypeDefConsFieldSelection (..), TypeDefConsSelection (..), TypeDefNodeSelection)
 import Primer.Core (
   GlobalName,
   GlobalNameKind (ADefName, ATyCon, AValCon),
   ID (..),
   LVarName,
   ModuleName,
   PrimCon,
+  TyVarName,
  )
 import Primer.Database (
   LastModified,
   Session,
   SessionName,
  )
-import Primer.JSON (CustomJSON, PrimerJSON)
+import Primer.JSON (CustomJSON (CustomJSON), PrimerJSON)
 import Primer.Name (Name)
 import Servant.API (FromHttpApiData (parseQueryParam), ToHttpApiData (toQueryParam))
 
+newtype PrimerJSONNamed (s :: Symbol) a = PrimerJSONNamed a
+deriving via PrimerJSON a instance (Generic a, GFromJSON Zero (Rep a)) => FromJSON (PrimerJSONNamed s a)
+deriving via PrimerJSON a instance (Generic a, GToJSON Zero (Rep a), GToEncoding Zero (Rep a)) => ToJSON (PrimerJSONNamed s a)
+
 -- $orphanInstances
 --
 -- We define some OpenApi orphan instances in primer-service, to avoid
@@ -89,6 +102,12 @@ instance
   where
   declareNamedSchema _ = genericDeclareNamedSchema (fromAesonOptions (aesonOptions @os)) (Proxy @a)
 
+instance
+  (Typeable a, Generic a, GToSchema (Rep a), KnownSymbol s) =>
+  ToSchema (PrimerJSONNamed s a)
+  where
+  declareNamedSchema _ = rename (Just $ T.pack $ symbolVal $ Proxy @s) <$> declareNamedSchema (Proxy @(PrimerJSON a))
+
 instance ToSchema SessionName
 deriving via PrimerJSON Session instance ToSchema Session
 
@@ -120,12 +139,12 @@ deriving via Text instance (ToSchema Name)
 -- at the openapi level, so api consumers do not have to deal with
 -- three identical types. Note that our openapi interface is a
 -- simplified view, so this collapse is in the correct spirit.
-instance ToSchema (GlobalName 'ADefName) where
-  declareNamedSchema _ = rename (Just "GlobalName") <$> declareNamedSchema (Proxy @(PrimerJSON (GlobalName 'ADefName)))
+deriving via PrimerJSONNamed "GlobalName" (GlobalName 'ADefName) instance ToSchema (GlobalName 'ADefName)
 deriving via GlobalName 'ADefName instance ToSchema (GlobalName 'ATyCon)
 deriving via GlobalName 'ADefName instance ToSchema (GlobalName 'AValCon)
 
 deriving via Name instance (ToSchema LVarName)
+deriving via Name instance (ToSchema TyVarName)
 deriving via PrimerJSON (RecordPair a b) instance (ToSchema a, ToSchema b) => ToSchema (RecordPair a b)
 deriving via PrimerJSON Tree instance ToSchema Tree
 deriving via PrimerJSON API.Name instance ToSchema API.Name
@@ -135,6 +154,8 @@ deriving via PrimerJSON NodeFlavorTextBody instance ToSchema NodeFlavorTextBody
 deriving via PrimerJSON NodeFlavorPrimBody instance ToSchema NodeFlavorPrimBody
 deriving via PrimerJSON NodeFlavorBoxBody instance ToSchema NodeFlavorBoxBody
 deriving via PrimerJSON NodeFlavorNoBody instance ToSchema NodeFlavorNoBody
+deriving via PrimerJSON TypeDef instance ToSchema TypeDef
+deriving via PrimerJSON ValCon instance ToSchema ValCon
 deriving via PrimerJSON Def instance ToSchema Def
 deriving via NonEmpty Name instance ToSchema ModuleName
 deriving via PrimerJSON Module instance ToSchema Module
@@ -146,8 +167,13 @@ deriving via PrimerJSON Available.FreeInput instance ToSchema Available.FreeInpu
 deriving via PrimerJSON Available.Options instance ToSchema Available.Options
 deriving via PrimerJSON Available.Action instance ToSchema Available.Action
 deriving via PrimerJSON ApplyActionBody instance ToSchema ApplyActionBody
-deriving via PrimerJSON Selection instance ToSchema Selection
-deriving via PrimerJSON NodeSelection instance ToSchema NodeSelection
+deriving via PrimerJSONNamed "Selection" Selection instance ToSchema Selection
+deriving via PrimerJSONNamed "TypeDefSelection" (TypeDefSelection ID) instance ToSchema (TypeDefSelection ID)
+deriving via PrimerJSONNamed "TypeDefNodeSelection" (TypeDefNodeSelection ID) instance ToSchema (TypeDefNodeSelection ID)
+deriving via PrimerJSONNamed "TypeDefConsSelection" (TypeDefConsSelection ID) instance ToSchema (TypeDefConsSelection ID)
+deriving via PrimerJSONNamed "TypeDefConsFieldSelection" (TypeDefConsFieldSelection ID) instance ToSchema (TypeDefConsFieldSelection ID)
+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 Level instance ToSchema Level
 deriving via PrimerJSON NewSessionReq instance ToSchema NewSessionReq

primer-service/src/Primer/Server.hs

@@ -343,6 +343,8 @@ serve ss q v port logger = do
         DatabaseErr msg -> err500{errBody = encode msg}
         UnknownDef d -> err404{errBody = "Unknown definition: " <> encode (globalNamePretty d)}
         UnexpectedPrimDef d -> err400{errBody = "Unexpected primitive definition: " <> encode (globalNamePretty d)}
+        UnknownTypeDef d -> err404{errBody = "Unknown type definition: " <> encode (globalNamePretty d)}
+        UnexpectedPrimTypeDef d -> err400{errBody = "Unexpected primitive type definition: " <> encode (globalNamePretty d)}
         AddDefError m md pe -> err400{errBody = "Error while adding definition (" <> s <> "): " <> show pe}
           where
             s = encode $ case md of

primer-service/test/Tests/OpenAPI.hs

@@ -30,10 +30,11 @@ import Primer.API (
   Module (Module),
   NewSessionReq (..),
   NodeBody (BoxBody, NoBody, PrimBody, TextBody),
-  NodeSelection (..),
   Prog (Prog),
-  Selection (..),
+  Selection,
   Tree,
+  TypeDef (..),
+  ValCon (..),
   viewTreeExpr,
   viewTreeType,
  )
@@ -45,7 +46,17 @@ import Primer.API.NodeFlavor (
  )
 import Primer.API.RecordPair (RecordPair (RecordPair))
 import Primer.Action.Available qualified as Available
-import Primer.App (Level, NodeType)
+import Primer.App (
+  DefSelection (..),
+  Level,
+  NodeSelection (..),
+  NodeType,
+  Selection' (..),
+  TypeDefConsFieldSelection (TypeDefConsFieldSelection),
+  TypeDefConsSelection (..),
+  TypeDefSelection (..),
+ )
+import Primer.App.Base (TypeDefNodeSelection (..))
 import Primer.Core (GVarName, ID (ID), ModuleName, PrimCon (PrimChar, PrimInt))
 import Primer.Database (
   LastModified (..),
@@ -64,6 +75,7 @@ import Primer.Gen.Core.Raw (
   genModuleName,
   genName,
   genTyConName,
+  genTyVarName,
   genType,
   genValConName,
  )
@@ -207,6 +219,18 @@ tasty_NodeFlavorNoBody = testToJSON $ G.enumBounded @_ @NodeFlavorNoBody
 genDef :: ExprGen Def
 genDef = Def <$> genGVarName <*> genExprTree <*> G.maybe genTypeTree
 
+genTypeDef :: ExprGen TypeDef
+genTypeDef =
+  TypeDef
+    <$> genTyConName
+    <*> G.list (R.linear 0 3) genTyVarName
+    <*> G.list (R.linear 0 3) genName
+    <*> G.maybe
+      ( G.list
+          (R.linear 0 3)
+          (ValCon <$> genValConName <*> G.list (R.linear 0 3) genTypeTree)
+      )
+
 tasty_Def :: Property
 tasty_Def = testToJSON $ evalExprGen 0 genDef
 
@@ -215,7 +239,7 @@ genModule =
   Module
     <$> genModuleName
     <*> G.bool
-    <*> G.list (R.linear 0 3) genTyConName
+    <*> G.list (R.linear 0 3) genTypeDef
     <*> G.list (R.linear 0 3) genDef
 
 tasty_Module :: Property
@@ -224,11 +248,33 @@ tasty_Module = testToJSON $ evalExprGen 0 genModule
 genNodeType :: ExprGen NodeType
 genNodeType = G.enumBounded
 
-genNodeSelection :: ExprGen NodeSelection
+genNodeSelection :: ExprGen (NodeSelection ID)
 genNodeSelection = NodeSelection <$> genNodeType <*> genID
 
+genDefSelection :: ExprGen (DefSelection ID)
+genDefSelection = DefSelection <$> genGVarName <*> G.maybe genNodeSelection
+
+genTypeDefSelection :: ExprGen (TypeDefSelection ID)
+genTypeDefSelection =
+  TypeDefSelection
+    <$> genTyConName
+    <*> G.maybe
+      ( G.choice
+          [ TypeDefParamNodeSelection <$> genTyVarName
+          , TypeDefConsNodeSelection
+              <$> ( TypeDefConsSelection
+                      <$> genValConName
+                      <*> G.maybe (TypeDefConsFieldSelection <$> G.integral (R.linear 0 3) <*> genID)
+                  )
+          ]
+      )
+
 genSelection :: ExprGen Selection
-genSelection = Selection <$> genGVarName <*> G.maybe genNodeSelection
+genSelection =
+  G.choice
+    [ SelectionDef <$> genDefSelection
+    , SelectionTypeDef <$> genTypeDefSelection
+    ]
 
 genProg :: Gen Prog
 genProg = evalExprGen 0 $ Prog <$> G.list (R.linear 0 3) genModule <*> G.maybe genSelection <*> G.bool <*> G.bool
@@ -307,7 +353,7 @@ instance Arbitrary ApplyActionBody where
   arbitrary = ApplyActionBody <$> arbitrary <*> arbitrary
 instance Arbitrary Selection where
   arbitrary = hedgehog $ evalExprGen 0 genSelection
-instance Arbitrary NodeSelection where
+instance Arbitrary (NodeSelection ID) where
   arbitrary = hedgehog $ evalExprGen 0 genNodeSelection
 instance Arbitrary a => Arbitrary (NonEmpty a) where
   arbitrary = (:|) <$> arbitrary <*> arbitrary