Give title to sub-schemas of oneOf for sum types

biocad · Nov 18, 2023 · ac63e99 · ac63e99
1 parent 95a0309
commit ac63e99
Show file tree

Hide file tree

Showing 2 changed files with 33 additions and 6 deletions.
diff --git a/src/Data/OpenApi/Internal/Schema.hs b/src/Data/OpenApi/Internal/Schema.hs
@@ -27,6 +27,7 @@ import Prelude.Compat
 import Control.Lens hiding (allOf)
 import Data.Data.Lens (template)
 
+import Control.Applicative ((<|>))
 import Control.Monad
 import Control.Monad.Writer hiding (First, Last)
 import Data.Aeson (Object (..), SumEncoding (..), ToJSON (..), ToJSONKey (..),
@@ -1026,7 +1027,7 @@ instance ( GSumToSchema f
          ) => GToSchema (f :+: g)
    where
   -- Aeson does not unwrap unary record in sum types.
-  gdeclareNamedSchema opts p s = gdeclareNamedSumSchema (opts { unwrapUnaryRecords = False } )p s
+  gdeclareNamedSchema opts = gdeclareNamedSumSchema (opts { unwrapUnaryRecords = False })
 
 gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
 gdeclareNamedSumSchema opts proxy _
@@ -1055,22 +1056,29 @@ instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
 -- | Convert one component of the sum to schema, to be later combined with @oneOf@.
 gsumConToSchemaWith :: forall c f. (GToSchema (C1 c f), Constructor c) =>
   Maybe (Referenced Schema) -> SchemaOptions -> Proxy (C1 c f) -> (T.Text, Referenced Schema)
-gsumConToSchemaWith ref opts _ = (tag, schema)
+gsumConToSchemaWith ref opts _ = (tag, withTitle)
   where
+    -- Give sub-schemas @title@ attribute with constructor name, if none present.
+    -- This will look prettier in swagger-ui.
+    withTitle = case schema of
+      Inline sub -> Inline $ sub
+        & title %~ (<|> Just (T.pack constructorName))
+      s -> s
+
     schema = case sumEncoding opts of
       TaggedObject tagField contentsField ->
         case ref of
           -- If subschema is an object and constructor is a record, we add tag directly
           -- to the record, as Aeson does it.
           Just (Inline sub) | sub ^. type_ == Just OpenApiObject && isRecord -> Inline $ sub
             & required <>~ [T.pack tagField]
-            & properties . at (T.pack tagField) ?~ (Inline $ mempty & type_ ?~ OpenApiString & enum_ ?~ [String tag])
+            & properties . at (T.pack tagField) ?~ Inline (mempty & type_ ?~ OpenApiString & enum_ ?~ [String tag])
 
           -- If it is not a record, we need to put subschema into "contents" field.
           _ | not isRecord -> Inline $ mempty
             & type_ ?~ OpenApiObject
             & required .~ [T.pack tagField]
-            & properties . at (T.pack tagField) ?~ (Inline $ mempty & type_ ?~ OpenApiString & enum_ ?~ [String tag])
+            & properties . at (T.pack tagField) ?~ Inline (mempty & type_ ?~ OpenApiString & enum_ ?~ [String tag])
               -- If constructor is nullary, there is no content.
             & case ref of
                 Just r -> (properties . at (T.pack contentsField) ?~ r) . (required <>~ [T.pack contentsField])
@@ -1081,7 +1089,7 @@ gsumConToSchemaWith ref opts _ = (tag, schema)
             & allOf ?~ [Inline $ mempty
               & type_ ?~ OpenApiObject
               & required .~ (T.pack tagField : if isRecord then [] else [T.pack contentsField])
-              & properties . at (T.pack tagField) ?~ (Inline $ mempty & type_ ?~ OpenApiString & enum_ ?~ [String tag])]
+              & properties . at (T.pack tagField) ?~ Inline (mempty & type_ ?~ OpenApiString & enum_ ?~ [String tag])]
             & if isRecord
                  then allOf . _Just <>~ [refOrNullary]
                  else allOf . _Just <>~ [Inline $ mempty & type_ ?~ OpenApiObject & properties . at (T.pack contentsField) ?~ refOrNullary]
@@ -1092,7 +1100,8 @@ gsumConToSchemaWith ref opts _ = (tag, schema)
         & properties . at tag ?~ refOrNullary
       TwoElemArray -> error "unrepresentable in OpenAPI 3"
 
-    tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
+    constructorName = conName (Proxy3 :: Proxy3 c f p)
+    tag = T.pack (constructorTagModifier opts constructorName)
     isRecord = conIsRecord (Proxy3 :: Proxy3 c f p)
     refOrNullary = fromMaybe (Inline nullarySchema) ref
     refOrEnum = fromMaybe (Inline $ mempty & type_ ?~ OpenApiString & enum_ ?~ [String tag]) ref

diff --git a/test/Data/OpenApi/CommonTestTypes.hs b/test/Data/OpenApi/CommonTestTypes.hs
@@ -277,6 +277,7 @@ characterSchemaJSON = [aesonQQ|
         "tag",
         "contents"
       ],
+      "title": "PC",
       "type": "object",
       "properties": {
         "tag": {
@@ -296,6 +297,7 @@ characterSchemaJSON = [aesonQQ|
         "npcPosition",
         "tag"
       ],
+      "title": "NPC",
       "type": "object",
       "properties": {
         "tag": {
@@ -326,6 +328,7 @@ characterInlinedSchemaJSON = [aesonQQ|
         "tag",
         "contents"
       ],
+      "title": "PC",
       "type": "object",
       "properties": {
         "tag": {
@@ -367,6 +370,7 @@ characterInlinedSchemaJSON = [aesonQQ|
         "npcPosition",
         "tag"
       ],
+      "title": "NPC",
       "type": "object",
       "properties": {
         "tag": {
@@ -410,6 +414,7 @@ characterInlinedPlayerSchemaJSON = [aesonQQ|
         "tag",
         "contents"
       ],
+      "title": "PC",
       "type": "object",
       "properties": {
         "tag": {
@@ -437,6 +442,7 @@ characterInlinedPlayerSchemaJSON = [aesonQQ|
         "npcPosition",
         "tag"
       ],
+      "title": "NPC",
       "type": "object",
       "properties": {
         "tag": {
@@ -636,6 +642,7 @@ lightSchemaJSON = [aesonQQ|
       "required": [
         "tag"
       ],
+      "title": "NoLight",
       "type": "object",
       "properties": {
         "tag": {
@@ -651,6 +658,7 @@ lightSchemaJSON = [aesonQQ|
         "tag",
         "contents"
       ],
+      "title": "LightFreq",
       "type": "object",
       "properties": {
         "tag": {
@@ -670,6 +678,7 @@ lightSchemaJSON = [aesonQQ|
         "tag",
         "contents"
       ],
+      "title": "LightColor",
       "type": "object",
       "properties": {
         "tag": {
@@ -688,6 +697,7 @@ lightSchemaJSON = [aesonQQ|
         "waveLength",
         "tag"
       ],
+      "title": "LightWaveLength",
       "type": "object",
       "properties": {
         "tag": {
@@ -714,6 +724,7 @@ lightInlinedSchemaJSON = [aesonQQ|
       "required": [
         "tag"
       ],
+      "title": "NoLight",
       "type": "object",
       "properties": {
         "tag": {
@@ -729,6 +740,7 @@ lightInlinedSchemaJSON = [aesonQQ|
         "tag",
         "contents"
       ],
+      "title": "LightFreq",
       "type": "object",
       "properties": {
         "tag": {
@@ -748,6 +760,7 @@ lightInlinedSchemaJSON = [aesonQQ|
         "tag",
         "contents"
       ],
+      "title": "LightColor",
       "type": "object",
       "properties": {
         "tag": {
@@ -771,6 +784,7 @@ lightInlinedSchemaJSON = [aesonQQ|
         "waveLength",
         "tag"
       ],
+      "title": "LightWaveLength",
       "type": "object",
       "properties": {
         "tag": {
@@ -914,6 +928,7 @@ predicateSchemaDeclareJSON = [aesonQQ|
             "tag": { "enum": ["PredicateNoun"], "type": "string" }
           },
           "required": ["tag", "contents"],
+          "title": "PredicateNoun",
           "type": "object"
         },
         {
@@ -922,6 +937,7 @@ predicateSchemaDeclareJSON = [aesonQQ|
             "tag": { "enum": ["PredicateOmitted"], "type": "string" }
           },
           "required": ["tag", "contents"],
+          "title": "PredicateOmitted",
           "type": "object"
         }
       ]
@@ -953,6 +969,7 @@ predicateSchemaDeclareJSON = [aesonQQ|
             "tag": { "enum": ["ModifierNoun"], "type": "string" }
           },
           "required": ["tag", "contents"],
+          "title": "ModifierNoun",
           "type": "object"
         },
         {
@@ -961,6 +978,7 @@ predicateSchemaDeclareJSON = [aesonQQ|
             "tag": { "enum": ["ModifierOmitted"], "type": "string" }
           },
           "required": ["tag", "contents"],
+          "title": "ModifierOmitted",
           "type": "object"
         }
       ]