[sc-35836] Add initial oneOf schema code gen support

This uses shrubbery untagged unions to implement oneOf code gen. We could use tagged unions here but I'm not sure if doing so adds any meaningful information. Remaining notes and questions: - I don't fully understand `SchemaMap`s, so I think they may be handled incorrectly, what is there indended use, and should we try to use them here instead of inferType? If yes, is there a test case that would reveal an issue with not using them - Related to the above, should we extract/share code between `mkInlineOneOfSchema` and `mkInlineBodySchema`? - This does not implement openapi discriminators, which is where I imagine using tagged unions might become useful - This does not implement inline objects as choices for `oneOf` - Are there any other test cases we want for the initial implementation? - If we run into `anyOf` being used, it would probably be simple to have it just call out to the `oneOf` code (though hopefully no one ever uses `anyOf`...) Co-Authored-By: Tyler <[email protected]> Co-Authored-By: Janus <[email protected]>
flipstone · Mar 15, 2024 · d3750b4 · d3750b4
1 parent 60ec4db
commit d3750b4
Show file tree

Hide file tree

Showing 10 changed files with 304 additions and 19 deletions.
diff --git a/.vscode/settings.json b/.vscode/settings.json
@@ -0,0 +1,3 @@
+{
+    "haskell.serverExecutablePath": "${workspaceFolder}/.vim/haskell-language-server-wrapper",
+}
diff --git a/json-fleece-codegen-util/src/Fleece/CodeGenUtil.hs b/json-fleece-codegen-util/src/Fleece/CodeGenUtil.hs
@@ -240,6 +240,7 @@ data CodeGenDataFormat
   | CodeGenEnum TypeOptions [T.Text]
   | CodeGenObject TypeOptions [CodeGenObjectField] (Maybe CodeGenAdditionalProperties)
   | CodeGenArray TypeOptions CodeGenObjectFieldType
+  | CodeGenUnion [SchemaTypeInfo]
 
 data CodeGenObjectField = CodeGenObjectField
   { codeGenFieldName :: T.Text
@@ -1046,6 +1047,37 @@ operationParamHeader moduleName typeName paramDef =
           : map (HC.indent 2) (exportLines <> [") where"])
       )
 
+generateCodeGenDataFormat ::
+  CodeGenMap ->
+  HC.TypeName ->
+  CodeGenDataFormat ->
+  CodeGen ([HC.VarName], HC.HaskellCode)
+generateCodeGenDataFormat typeMap typeName format = do
+  case format of
+    CodeGenNewType typeOptions baseTypeInfo ->
+      pure $
+        generateFleeceNewtype
+          typeName
+          (schemaTypeExpr baseTypeInfo)
+          (schemaTypeSchema baseTypeInfo)
+          typeOptions
+    CodeGenEnum typeOptions values ->
+      pure $ generateFleeceEnum typeName values typeOptions
+    CodeGenObject typeOptions fields mbAdditionalProperties ->
+      generateFleeceObject typeMap typeName fields mbAdditionalProperties typeOptions
+    CodeGenArray typeOptions itemType ->
+      generateFleeceArray typeMap typeName itemType typeOptions
+    CodeGenUnion members ->
+      generateFleeceUnion typeName members
+
+formatRequiresDataKinds ::
+  CodeGenDataFormat ->
+  Bool
+formatRequiresDataKinds format =
+  case format of
+    CodeGenUnion _ -> True
+    _ -> False
+
 generateSchemaCode ::
   CodeGenMap ->
   CodeGenType ->
@@ -1065,28 +1097,20 @@ generateSchemaCode typeMap codeGenType = do
       codeGenTypeDataFormat codeGenType
 
   (extraExports, moduleBody) <-
-    case format of
-      CodeGenNewType typeOptions baseTypeInfo ->
-        pure $
-          generateFleeceNewtype
-            typeName
-            (schemaTypeExpr baseTypeInfo)
-            (schemaTypeSchema baseTypeInfo)
-            typeOptions
-      CodeGenEnum typeOptions values ->
-        pure $ generateFleeceEnum typeName values typeOptions
-      CodeGenObject typeOptions fields mbAdditionalProperties ->
-        generateFleeceObject typeMap typeName fields mbAdditionalProperties typeOptions
-      CodeGenArray typeOptions itemType ->
-        generateFleeceArray typeMap typeName itemType typeOptions
+    generateCodeGenDataFormat typeMap typeName format
 
   let
     header =
       schemaTypeModuleHeader moduleName typeName extraExports
 
+    pragmas =
+      HC.lines $
+        ["{-# LANGUAGE DataKinds #-}" | formatRequiresDataKinds format]
+          <> ["{-# LANGUAGE NoImplicitPrelude #-}"]
+
     code =
-      HC.declarations $
-        [ "{-# LANGUAGE NoImplicitPrelude #-}"
+      HC.declarations
+        [ pragmas
         , header
         , importDeclarations moduleName moduleBody
         , moduleBody
@@ -1249,6 +1273,53 @@ generateFleeceEnum typeName enumValues typeOptions =
   in
     ([toTextName], HC.declarations [enum, fleeceSchema])
 
+generateFleeceUnion ::
+  HC.TypeName ->
+  [SchemaTypeInfo] ->
+  CodeGen ([HC.VarName], HC.HaskellCode)
+generateFleeceUnion typeName members = do
+  let
+    mapIgnoringFirst _ [] = []
+    mapIgnoringFirst _ [x] = [x]
+    mapIgnoringFirst f (x : xs) = x : map f xs
+    unionMemberSchema schema =
+      fleeceCoreVar "unionMember" <> " " <> schema
+    unionMemberSchemas =
+      map unionMemberSchema $ schemaTypeSchema <$> members
+    unionName =
+      fleeceCoreVar "unionNamed"
+        <> " ("
+        <> fleeceCoreVar "unqualifiedName"
+        <> " "
+        <> HC.quote (HC.typeNameToCode Nothing typeName)
+        <> ") "
+        <> HC.dollar
+    fleeceSchema =
+      (if length members > 1 then HC.addReferences [HC.VarReference "Fleece.Core" Nothing "(#|)"] else id) $
+        fleeceSchemaForType
+          typeName
+          ( fleeceCoreVar "coerceSchema" <> " " <> HC.dollar
+              : HC.indent 2 unionName
+              : map (HC.indent 4) (mapIgnoringFirst (HC.indent 2 . (<>) "#| ") unionMemberSchemas)
+          )
+
+    unionNewType =
+      HC.newtype_
+        typeName
+        ("(" <> HC.typeList (schemaTypeExpr <$> members) <> ")")
+        Nothing
+
+    extraExports =
+      []
+
+    body =
+      HC.declarations
+        [ unionNewType
+        , fleeceSchema
+        ]
+
+  pure (extraExports, body)
+
 generateFleeceObject ::
   CodeGenMap ->
   HC.TypeName ->
@@ -1330,7 +1401,7 @@ generateFleeceObject typeMap typeName codeGenFields mbAdditionalProperties typeO
         , fleeceSchema
         ]
 
-  pure $ (extraExports, body)
+  pure (extraExports, body)
 
 generateFleeceArray ::
   CodeGenMap ->

diff --git a/json-fleece-codegen-util/src/Fleece/CodeGenUtil/HaskellCode.hs b/json-fleece-codegen-util/src/Fleece/CodeGenUtil/HaskellCode.hs
@@ -31,6 +31,11 @@ module Fleece.CodeGenUtil.HaskellCode
   , renderText
   , renderString
   , newline
+  , quote
+  , taggedUnion
+  , union
+  , typeList
+  , taggedUnionTypeList
   , intercalate
   , lines
   , indent
@@ -62,6 +67,7 @@ module Fleece.CodeGenUtil.HaskellCode
   , enumClass
   , boundedClass
   , preludeType
+  , shrubberyType
   ) where
 
 -- import prelude explicitly since we want to define our own 'lines' function
@@ -247,6 +253,10 @@ intercalate :: Foldable f => HaskellCode -> f HaskellCode -> HaskellCode
 intercalate sep =
   mconcat . List.intersperse sep . toList
 
+intercalateTypes :: Foldable f => TypeExpression -> f TypeExpression -> TypeExpression
+intercalateTypes sep =
+  mconcat . List.intersperse sep . toList
+
 lines :: Foldable f => f HaskellCode -> HaskellCode
 lines = intercalate newline
 
@@ -427,6 +437,38 @@ mapOf keyName itemName =
     <> itemName
     <> ")"
 
+taggedUnion :: TypeExpression
+taggedUnion =
+  typeNameToCodeDefaultQualification (shrubberyType "TaggedUnion")
+
+union :: TypeExpression
+union =
+  typeNameToCodeDefaultQualification (shrubberyType "Union")
+
+typeList :: [TypeExpression] -> TypeExpression
+typeList =
+  prefixedTypeList Nothing
+
+quote :: HaskellCode -> HaskellCode
+quote code =
+  "\"" <> code <> "\""
+
+taggedUnionTypeList :: [TypeExpression] -> TypeExpression
+taggedUnionTypeList =
+  prefixedTypeList (Just $ \member -> quote member <> " @= ")
+
+prefixedTypeList ::
+  Maybe (HaskellCode -> HaskellCode) ->
+  [TypeExpression] ->
+  TypeExpression
+prefixedTypeList mbPrefixFn members =
+  case mbPrefixFn of
+    Just _ -> taggedUnion
+    Nothing -> union
+    <> " '["
+    <> intercalateTypes ", " members
+    <> "]"
+
 maybeOf :: TypeExpression -> TypeExpression
 maybeOf itemName =
   typeNameToCode Nothing (preludeType "Maybe")
@@ -528,3 +570,7 @@ boundedClass =
 preludeType :: T.Text -> TypeName
 preludeType =
   toTypeName "Prelude" Nothing
+
+shrubberyType :: T.Text -> TypeName
+shrubberyType =
+  toTypeName "Shrubbery" (Just "Shrubbery")
diff --git a/json-fleece-openapi3/examples/test-cases/TestCases/Types/TopLevelOneOf.hs b/json-fleece-openapi3/examples/test-cases/TestCases/Types/TopLevelOneOf.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module TestCases.Types.TopLevelOneOf
+  ( TopLevelOneOf(..)
+  , topLevelOneOfSchema
+  ) where
+
+import qualified Data.Text as T
+import Fleece.Core ((#|))
+import qualified Fleece.Core as FC
+import Prelude (($), Eq, Integer, Show)
+import qualified Shrubbery as Shrubbery
+import qualified TestCases.Types.AStringType as AStringType
+import qualified TestCases.Types.FieldDescriptions as FieldDescriptions
+import qualified TestCases.Types.MixedInJustAdditionalPropertiesSchemaInline as MixedInJustAdditionalPropertiesSchemaInline
+import qualified TestCases.Types.Num2SchemaStartingWithNumber as Num2SchemaStartingWithNumber
+
+newtype TopLevelOneOf = TopLevelOneOf (Shrubbery.Union '[T.Text, Integer, AStringType.AStringType, Num2SchemaStartingWithNumber.Num2SchemaStartingWithNumber, [FieldDescriptions.FieldDescriptions], [[MixedInJustAdditionalPropertiesSchemaInline.MixedInJustAdditionalPropertiesSchemaInline]]])
+  deriving (Show, Eq)
+
+topLevelOneOfSchema :: FC.Fleece schema => schema TopLevelOneOf
+topLevelOneOfSchema =
+  FC.coerceSchema $
+    FC.unionNamed (FC.unqualifiedName "TopLevelOneOf") $
+      FC.unionMember FC.text
+        #| FC.unionMember FC.integer
+        #| FC.unionMember AStringType.aStringTypeSchema
+        #| FC.unionMember Num2SchemaStartingWithNumber.num2SchemaStartingWithNumberSchema
+        #| FC.unionMember (FC.list FieldDescriptions.fieldDescriptionsSchema)
+        #| FC.unionMember (FC.list (FC.list MixedInJustAdditionalPropertiesSchemaInline.mixedInJustAdditionalPropertiesSchemaInlineSchema))
diff --git a/json-fleece-openapi3/examples/test-cases/TestCases/Types/TopLevelOneOfOneOption.hs b/json-fleece-openapi3/examples/test-cases/TestCases/Types/TopLevelOneOfOneOption.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module TestCases.Types.TopLevelOneOfOneOption
+  ( TopLevelOneOfOneOption(..)
+  , topLevelOneOfOneOptionSchema
+  ) where
+
+import qualified Data.Text as T
+import qualified Fleece.Core as FC
+import Prelude (($), Eq, Show)
+import qualified Shrubbery as Shrubbery
+
+newtype TopLevelOneOfOneOption = TopLevelOneOfOneOption (Shrubbery.Union '[T.Text])
+  deriving (Show, Eq)
+
+topLevelOneOfOneOptionSchema :: FC.Fleece schema => schema TopLevelOneOfOneOption
+topLevelOneOfOneOptionSchema =
+  FC.coerceSchema $
+    FC.unionNamed (FC.unqualifiedName "TopLevelOneOfOneOption") $
+      FC.unionMember FC.text
diff --git a/json-fleece-openapi3/examples/test-cases/package.yaml b/json-fleece-openapi3/examples/test-cases/package.yaml
@@ -18,6 +18,7 @@ dependencies:
   - json-fleece-aeson-beeline >= 0.1 && < 0.2
   - beeline-routing >= 0.2.4 && < 0.3
   - beeline-http-client >= 0.8 && < 0.9
+  - shrubbery >= 0.2 && < 0.3
   - time
 
 ghc-options:

diff --git a/json-fleece-openapi3/examples/test-cases/test-cases.cabal b/json-fleece-openapi3/examples/test-cases/test-cases.cabal
@@ -145,6 +145,8 @@ library
       TestCases.Types.TopLevelArray.TopLevelArrayItem
       TestCases.Types.TopLevelArrayNullable
       TestCases.Types.TopLevelArrayNullable.TopLevelArrayNullableItem
+      TestCases.Types.TopLevelOneOf
+      TestCases.Types.TopLevelOneOfOneOption
       TestCases.Types.UtcTimeType
       TestCases.Types.ZonedTimeType
   other-modules:
@@ -160,6 +162,7 @@ library
     , json-fleece-aeson-beeline ==0.1.*
     , json-fleece-core >=0.1.3 && <0.7
     , scientific
+    , shrubbery ==0.2.*
     , text
     , time
   default-language: Haskell2010
diff --git a/json-fleece-openapi3/examples/test-cases/test-cases.yaml b/json-fleece-openapi3/examples/test-cases/test-cases.yaml
@@ -483,6 +483,25 @@ components:
         - arrayField
         - nullableArrayField
 
+    TopLevelOneOf:
+      oneOf:
+        - type: string
+        - type: integer
+        - $ref: "#/components/schemas/AStringType"
+        - $ref: "#/components/schemas/2_SchemaStartingWithNumber"
+        - items:
+            $ref: "#/components/schemas/FieldDescriptions"
+          type: array
+        - items:
+            items:
+              $ref: "#/components/schemas/MixedInJustAdditionalPropertiesSchemaInline"
+            type: array
+          type: array
+
+    TopLevelOneOfOneOption:
+      oneOf:
+        - type: string
+
     TopLevelArray:
       type: array
       description: A schema that defines a top level array

diff --git a/json-fleece-openapi3/json-fleece-openapi3.cabal b/json-fleece-openapi3/json-fleece-openapi3.cabal
@@ -1992,6 +1992,8 @@ extra-source-files:
     examples/test-cases/TestCases/Types/TopLevelArray/TopLevelArrayItem.hs
     examples/test-cases/TestCases/Types/TopLevelArrayNullable.hs
     examples/test-cases/TestCases/Types/TopLevelArrayNullable/TopLevelArrayNullableItem.hs
+    examples/test-cases/TestCases/Types/TopLevelOneOf.hs
+    examples/test-cases/TestCases/Types/TopLevelOneOfOneOption.hs
     examples/test-cases/TestCases/Types/UtcTimeType.hs
     examples/test-cases/TestCases/Types/ZonedTimeType.hs