Merge pull request #829 from hackworthltd/georgefst/structured-textbody

feat!: Use structured text for names in trees, instead of hardcoding dot

Author: georgefst

primer-service/src/Primer/OpenAPI.hs

@@ -50,6 +50,7 @@ import Primer.API (
   Selection (..),
   Tree,
  )
+import Primer.API qualified as API
 import Primer.Action.Available qualified as Available
 import Primer.App (NodeType)
 import Primer.App.Base (Level)
@@ -59,6 +60,7 @@ import Primer.Core (
   ID (..),
   LVarName,
   ModuleName,
+  PrimCon,
  )
 import Primer.Database (
   LastModified,
@@ -121,6 +123,8 @@ deriving via GlobalName 'ADefName instance ToSchema (GlobalName 'AValCon)
 
 deriving via Name instance (ToSchema LVarName)
 deriving via PrimerJSON Tree instance ToSchema Tree
+deriving via PrimerJSON API.Name instance ToSchema API.Name
+deriving via PrimerJSON PrimCon instance ToSchema PrimCon
 deriving via PrimerJSON NodeBody instance ToSchema NodeBody
 deriving via PrimerJSON NodeFlavor instance ToSchema NodeFlavor
 deriving via PrimerJSON Def instance ToSchema Def

primer-service/test/Tests/OpenAPI.hs

@@ -48,6 +48,7 @@ import Primer.Database (
   safeMkSessionName,
  )
 import Primer.Gen.API (genExprTreeOpts)
+import Primer.Gen.API qualified as API
 import Primer.Gen.Core.Raw (
   ExprGen,
   evalExprGen,
@@ -171,7 +172,7 @@ tasty_NodeBody :: Property
 tasty_NodeBody =
   testToJSON $
     G.choice
-      [ TextBody <$> G.text (R.linear 1 20) G.unicode
+      [ TextBody <$> API.genName
       , BoxBody <$> genTree
       , pure NoBody
       ]

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

@@ -232,6 +232,24 @@
                 ],
                 "type": "object"
             },
+            "Name": {
+                "properties": {
+                    "baseName": {
+                        "type": "string"
+                    },
+                    "qualifiedModule": {
+                        "items": {
+                            "type": "string"
+                        },
+                        "minItems": 1,
+                        "type": "array"
+                    }
+                },
+                "required": [
+                    "baseName"
+                ],
+                "type": "object"
+            },
             "NewSessionReq": {
                 "properties": {
                     "name": {
@@ -270,7 +288,7 @@
                     {
                         "properties": {
                             "contents": {
-                                "type": "string"
+                                "$ref": "#/components/schemas/Name"
                             },
                             "tag": {
                                 "enum": [
@@ -285,6 +303,24 @@
                         ],
                         "type": "object"
                     },
+                    {
+                        "properties": {
+                            "contents": {
+                                "$ref": "#/components/schemas/PrimCon"
+                            },
+                            "tag": {
+                                "enum": [
+                                    "PrimBody"
+                                ],
+                                "type": "string"
+                            }
+                        },
+                        "required": [
+                            "tag",
+                            "contents"
+                        ],
+                        "type": "object"
+                    },
                     {
                         "properties": {
                             "contents": {
@@ -484,6 +520,50 @@
                 ],
                 "type": "object"
             },
+            "PrimCon": {
+                "oneOf": [
+                    {
+                        "properties": {
+                            "contents": {
+                                "example": "?",
+                                "maxLength": 1,
+                                "minLength": 1,
+                                "type": "string"
+                            },
+                            "tag": {
+                                "enum": [
+                                    "PrimChar"
+                                ],
+                                "type": "string"
+                            }
+                        },
+                        "required": [
+                            "tag",
+                            "contents"
+                        ],
+                        "type": "object"
+                    },
+                    {
+                        "properties": {
+                            "contents": {
+                                "type": "integer"
+                            },
+                            "tag": {
+                                "enum": [
+                                    "PrimInt"
+                                ],
+                                "type": "string"
+                            }
+                        },
+                        "required": [
+                            "tag",
+                            "contents"
+                        ],
+                        "type": "object"
+                    }
+                ],
+                "type": "object"
+            },
             "Prog": {
                 "properties": {
                     "modules": {

primer/gen/Primer/Gen/API.hs

@@ -1,14 +1,27 @@
+{-# LANGUAGE RecordWildCards #-}
+
 module Primer.Gen.API (
   genExprTreeOpts,
+  genName,
 ) where
 
 import Foreword
 
 import Hedgehog (MonadGen)
+import Hedgehog.Gen qualified as G
 import Hedgehog.Gen qualified as Gen
-import Primer.API (ExprTreeOpts (..))
+import Hedgehog.Range qualified as R
+import Primer.API (ExprTreeOpts (..), Name (..))
+import Primer.Gen.Core.Raw qualified as Raw
+import Primer.Name (unsafeMkName)
 
 genExprTreeOpts :: MonadGen m => m ExprTreeOpts
 genExprTreeOpts = do
   patternsUnder <- Gen.bool
   pure ExprTreeOpts{patternsUnder}
+
+genName :: MonadGen m => m Name
+genName = do
+  baseName <- unsafeMkName <$> G.text (R.linear 1 20) G.unicode
+  qualifiedModule <- G.maybe Raw.genModuleName
+  pure Name{..}