Tagged Union Improvements

json-fleece-codegen-util/json-fleece-codegen-util.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           json-fleece-codegen-util
-version:        0.9.1.1
+version:        0.10.0.0
 description:    Please see the README on GitHub at <https://github.com/githubuser/json-fleece-codegen-util#readme>
 homepage:       https://github.com/flipstone/json-fleece#readme
 bug-reports:    https://github.com/flipstone/json-fleece/issues

json-fleece-codegen-util/package.yaml

@@ -1,5 +1,5 @@
 name:                json-fleece-codegen-util
-version:             0.9.1.1
+version:             0.10.0.0
 github:              "flipstone/json-fleece/json-fleece-codegen-util"
 license:             BSD3
 author:              "Author name here"
@@ -71,4 +71,3 @@ library:
     - Fleece.CodeGenUtil.HaskellCode
     - Fleece.CodeGenUtil.Executable
     - Fleece.CodeGenUtil.Test
-

json-fleece-codegen-util/src/Fleece/CodeGenUtil.hs

@@ -612,6 +612,7 @@ anyJSONSchemaTypeInfo =
   SchemaTypeInfo
     { schemaTypeExpr = HC.typeNameToCodeDefaultQualification (fleeceCoreType "AnyJSON")
     , schemaTypeSchema = fleeceCoreVar "anyJSON"
+    , schemaTypeObjSchema = fleeceCoreVar "anyJSON"
     }
 
 generateFleeceCode :: CodeGenMap -> CodeGen Modules
@@ -1558,7 +1559,7 @@ generateFleeceTaggedUnion typeMap typeName tagProperty members = do
         <> " "
         <> HC.typeApplication (HC.stringLiteral tag)
         <> " "
-        <> schemaTypeSchema typeInfo
+        <> schemaTypeObjSchema typeInfo
 
     taggedUnionMemberLines =
       map taggedUnionMemberLine taggedTypeInfos
@@ -1616,12 +1617,13 @@ determineDiscriminatorPropertyForObject refSet =
         UnionMemberSource -> Nothing
         TaggedUnionMemberSource property -> Just property
   in
-    case Set.toList (Set.map toDiscriminator refSet) of
+    case catMaybes $ Set.toList (Set.map toDiscriminator refSet) of
       [] -> pure Nothing
-      [oneDiscriminator] -> pure oneDiscriminator
+      [oneDiscriminator] -> pure $ Just oneDiscriminator
       multiple ->
+        -- This limitation could probably be lifted with some additional care
         codeGenError $
-          "Objects referenced from tagged unions must have consistent discriminator properties and cannot be referenced outside the union."
+          "Objects referenced from tagged unions must have consistent discriminator properties."
             <> " Found the following discriminator properties: "
             <> show multiple
 
@@ -1707,30 +1709,38 @@ generateFleeceObject typeMap references typeName rawCodeGenFields mbAdditionalPr
     fleeceFields =
       map fleeceField fields ++ fleeceAdditionalProps
 
-    fleeceSchema =
+    fleeceSchemas =
       case mbDiscriminator of
         Nothing ->
-          fleeceSchemaForType
-            typeName
-            ( fleeceCoreVar "object" <> " " <> HC.dollar
-                : "  " <> fleeceCoreVar "constructor" <> " " <> HC.typeNameToCode Nothing typeName
-                : map (HC.indent 4) fleeceFields
-            )
+          [ fleeceSchemaForType
+              typeName
+              ( fleeceCoreVar "object" <> " " <> HC.dollar
+                  : "  " <> fleeceCoreVar "constructor" <> " " <> HC.typeNameToCode Nothing typeName
+                  : map (HC.indent 4) fleeceFields
+              )
+          ]
         Just _ ->
-          fleeceObjectForType
-            typeName
-            ( fleeceCoreVar "constructor" <> " " <> HC.typeNameToCode Nothing typeName
-                : map (HC.indent 2) fleeceFields
-            )
+          [ fleeceSchemaForType
+              typeName
+              [fleeceCoreVar "object" <> " " <> HC.varNameToCode Nothing (fleeceObjSchemaNameForType typeName)]
+          , fleeceObjectForType
+              typeName
+              ( fleeceCoreVar "constructor" <> " " <> HC.typeNameToCode Nothing typeName
+                  : map (HC.indent 2) fleeceFields
+              )
+          ]
 
     extraExports =
-      []
+      case mbDiscriminator of
+        Nothing -> []
+        Just _ ->
+          [fleeceObjSchemaNameForType typeName]
 
     body =
-      HC.declarations
+      HC.declarations $
         [ recordDecl
-        , fleeceSchema
         ]
+          <> fleeceSchemas
 
   pure (extraExports, body)
 
@@ -1814,25 +1824,24 @@ mkFleeceSchemaField typeMap moduleName codeGenField = do
 data SchemaTypeInfo = SchemaTypeInfo
   { schemaTypeExpr :: HC.TypeExpression
   , schemaTypeSchema :: HC.HaskellCode
+  , schemaTypeObjSchema :: HC.HaskellCode
   }
 
 primitiveSchemaTypeInfo :: HC.TypeName -> HC.HaskellCode -> SchemaTypeInfo
 primitiveSchemaTypeInfo typeName schema =
   SchemaTypeInfo
     { schemaTypeExpr = HC.typeNameToCodeDefaultQualification typeName
     , schemaTypeSchema = schema
+    , schemaTypeObjSchema = schema
     }
 
 inferSchemaInfoForTypeName :: HC.TypeName -> CodeGen SchemaTypeInfo
-inferSchemaInfoForTypeName typeName = do
-  let
-    schema =
-      fleeceSchemaNameForType typeName
-
+inferSchemaInfoForTypeName typeName =
   pure $
     SchemaTypeInfo
       { schemaTypeExpr = HC.typeNameToCodeDefaultQualification typeName
-      , schemaTypeSchema = HC.varNameToCodeDefaultQualification schema
+      , schemaTypeSchema = HC.varNameToCodeDefaultQualification $ fleeceSchemaNameForType typeName
+      , schemaTypeObjSchema = HC.varNameToCodeDefaultQualification $ fleeceObjSchemaNameForType typeName
       }
 
 inferTypeForInputName :: CodeSection -> T.Text -> CodeGen (HC.ModuleName, HC.TypeName)
@@ -1853,6 +1862,13 @@ fleeceSchemaNameForType typeName =
     (HC.typeNameSuggestedQualifier typeName)
     (HC.typeNameText typeName <> "Schema")
 
+fleeceObjSchemaNameForType :: HC.TypeName -> HC.VarName
+fleeceObjSchemaNameForType typeName =
+  HC.toVarName
+    (HC.typeNameModule typeName)
+    (HC.typeNameSuggestedQualifier typeName)
+    (HC.typeNameText typeName <> "ObjSchema")
+
 fleeceSchemaForType :: HC.TypeName -> [HC.HaskellCode] -> HC.HaskellCode
 fleeceSchemaForType typeName bodyLines =
   let
@@ -1878,7 +1894,7 @@ fleeceObjectForType :: HC.TypeName -> [HC.HaskellCode] -> HC.HaskellCode
 fleeceObjectForType typeName bodyLines =
   let
     schemaName =
-      fleeceSchemaNameForType typeName
+      fleeceObjSchemaNameForType typeName
 
     declType =
       HC.typeAnnotate schemaName $

json-fleece-openapi3/examples/test-cases/TestCases/Types/Bar.hs

@@ -3,6 +3,7 @@
 module TestCases.Types.Bar
   ( Bar(..)
   , barSchema
+  , barObjSchema
   ) where
 
 import Fleece.Core ((#+), Object)
@@ -15,7 +16,11 @@ data Bar = Bar
   }
   deriving (Eq, Show)
 
-barSchema :: FC.Fleece schema => Object schema Bar Bar
+barSchema :: FC.Fleece schema => schema Bar
 barSchema =
+  FC.object barObjSchema
+
+barObjSchema :: FC.Fleece schema => Object schema Bar Bar
+barObjSchema =
   FC.constructor Bar
     #+ FC.optional "barName" barName BarName.barNameSchema

json-fleece-openapi3/examples/test-cases/TestCases/Types/Baz.hs

@@ -3,6 +3,7 @@
 module TestCases.Types.Baz
   ( Baz(..)
   , bazSchema
+  , bazObjSchema
   ) where
 
 import Fleece.Core ((#+), Object)
@@ -15,7 +16,11 @@ data Baz = Baz
   }
   deriving (Eq, Show)
 
-bazSchema :: FC.Fleece schema => Object schema Baz Baz
+bazSchema :: FC.Fleece schema => schema Baz
 bazSchema =
+  FC.object bazObjSchema
+
+bazObjSchema :: FC.Fleece schema => Object schema Baz Baz
+bazObjSchema =
   FC.constructor Baz
     #+ FC.optional "bazName" bazName BazName.bazNameSchema

json-fleece-openapi3/examples/test-cases/TestCases/Types/Foo.hs

@@ -3,6 +3,7 @@
 module TestCases.Types.Foo
   ( Foo(..)
   , fooSchema
+  , fooObjSchema
   ) where
 
 import Fleece.Core (Object)
@@ -12,6 +13,10 @@ import Prelude (Eq, Show)
 data Foo = Foo
   deriving (Eq, Show)
 
-fooSchema :: FC.Fleece schema => Object schema Foo Foo
+fooSchema :: FC.Fleece schema => schema Foo
 fooSchema =
+  FC.object fooObjSchema
+
+fooObjSchema :: FC.Fleece schema => Object schema Foo Foo
+fooObjSchema =
   FC.constructor Foo

json-fleece-openapi3/examples/test-cases/TestCases/Types/ObjectWithDiscriminatedUnionRef.hs

@@ -0,0 +1,22 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module TestCases.Types.ObjectWithDiscriminatedUnionRef
+  ( ObjectWithDiscriminatedUnionRef(..)
+  , objectWithDiscriminatedUnionRefSchema
+  ) where
+
+import Fleece.Core ((#+))
+import qualified Fleece.Core as FC
+import Prelude (($), Eq, Maybe, Show)
+import qualified TestCases.Types.Baz as Baz
+
+data ObjectWithDiscriminatedUnionRef = ObjectWithDiscriminatedUnionRef
+  { bazRef :: Maybe Baz.Baz
+  }
+  deriving (Eq, Show)
+
+objectWithDiscriminatedUnionRefSchema :: FC.Fleece schema => schema ObjectWithDiscriminatedUnionRef
+objectWithDiscriminatedUnionRefSchema =
+  FC.object $
+    FC.constructor ObjectWithDiscriminatedUnionRef
+      #+ FC.optional "bazRef" bazRef Baz.bazSchema

json-fleece-openapi3/examples/test-cases/TestCases/Types/OneOfWithDiscriminator.hs

@@ -29,6 +29,6 @@ oneOfWithDiscriminatorSchema :: FC.Fleece schema => schema OneOfWithDiscriminato
 oneOfWithDiscriminatorSchema =
   FC.coerceSchema $
     FC.taggedUnionNamed (FC.qualifiedName "TestCases.Types.OneOfWithDiscriminator" "OneOfWithDiscriminator") "type" $
-      FC.taggedUnionMember @"bar" Bar.barSchema
-        #@ FC.taggedUnionMember @"baz" Baz.bazSchema
-        #@ FC.taggedUnionMember @"foo" Foo.fooSchema
+      FC.taggedUnionMember @"bar" Bar.barObjSchema
+        #@ FC.taggedUnionMember @"baz" Baz.bazObjSchema
+        #@ FC.taggedUnionMember @"foo" Foo.fooObjSchema

json-fleece-openapi3/examples/test-cases/TestCases/Types/OneOfWithDiscriminatorTypeObject.hs

@@ -0,0 +1,34 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ExplicitNamespaces #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeApplications #-}
+
+module TestCases.Types.OneOfWithDiscriminatorTypeObject
+  ( OneOfWithDiscriminatorTypeObject(..)
+  , oneOfWithDiscriminatorTypeObjectSchema
+  ) where
+
+import Fleece.Core ((#@))
+import qualified Fleece.Core as FC
+import Prelude (($), Eq, Show)
+import Shrubbery (type (@=))
+import qualified Shrubbery as Shrubbery
+import qualified TestCases.Types.Bar as Bar
+import qualified TestCases.Types.Baz as Baz
+import qualified TestCases.Types.Foo as Foo
+
+newtype OneOfWithDiscriminatorTypeObject = OneOfWithDiscriminatorTypeObject (Shrubbery.TaggedUnion
+  '[ "bar" @= Bar.Bar
+   , "baz" @= Baz.Baz
+   , "foo" @= Foo.Foo
+   ])
+  deriving (Show, Eq)
+
+oneOfWithDiscriminatorTypeObjectSchema :: FC.Fleece schema => schema OneOfWithDiscriminatorTypeObject
+oneOfWithDiscriminatorTypeObjectSchema =
+  FC.coerceSchema $
+    FC.taggedUnionNamed (FC.qualifiedName "TestCases.Types.OneOfWithDiscriminatorTypeObject" "OneOfWithDiscriminatorTypeObject") "type" $
+      FC.taggedUnionMember @"bar" Bar.barObjSchema
+        #@ FC.taggedUnionMember @"baz" Baz.bazObjSchema
+        #@ FC.taggedUnionMember @"foo" Foo.fooObjSchema

json-fleece-openapi3/examples/test-cases/test-cases.cabal

@@ -171,7 +171,9 @@ library
       TestCases.Types.NameConflicts.Where
       TestCases.Types.NullableBoolean
       TestCases.Types.Num2SchemaStartingWithNumber
+      TestCases.Types.ObjectWithDiscriminatedUnionRef
       TestCases.Types.OneOfWithDiscriminator
+      TestCases.Types.OneOfWithDiscriminatorTypeObject
       TestCases.Types.OneOfWithNullable
       TestCases.Types.ReferenceOneOf
       TestCases.Types.ReferenceOneOfInsideOneOf

json-fleece-openapi3/examples/test-cases/test-cases.yaml

@@ -607,6 +607,26 @@ components:
           bar: "#/components/schemas/Bar"
           baz: "#/components/schemas/Baz"
 
+    OneOfWithDiscriminatorTypeObject:
+      type: object
+      oneOf:
+        - $ref: "#/components/schemas/Foo"
+        - $ref: "#/components/schemas/Bar"
+        - $ref: "#/components/schemas/Baz"
+
+      discriminator:
+        propertyName: "type"
+        mapping:
+          foo: "#/components/schemas/Foo"
+          bar: "#/components/schemas/Bar"
+          baz: "#/components/schemas/Baz"
+
+    ObjectWithDiscriminatedUnionRef:
+      type: object
+      properties:
+        bazRef:
+          $ref: "#/components/schemas/Baz"
+
     Foo:
       type: object
       properties:

json-fleece-openapi3/json-fleece-openapi3.cabal

@@ -2018,7 +2018,9 @@ extra-source-files:
     examples/test-cases/TestCases/Types/NameConflicts/Where.hs
     examples/test-cases/TestCases/Types/NullableBoolean.hs
     examples/test-cases/TestCases/Types/Num2SchemaStartingWithNumber.hs
+    examples/test-cases/TestCases/Types/ObjectWithDiscriminatedUnionRef.hs
     examples/test-cases/TestCases/Types/OneOfWithDiscriminator.hs
+    examples/test-cases/TestCases/Types/OneOfWithDiscriminatorTypeObject.hs
     examples/test-cases/TestCases/Types/OneOfWithNullable.hs
     examples/test-cases/TestCases/Types/ReferenceOneOf.hs
     examples/test-cases/TestCases/Types/ReferenceOneOfInsideOneOf.hs
@@ -2055,7 +2057,7 @@ library
     , base >=4.7 && <5
     , containers ==0.6.*
     , insert-ordered-containers ==0.2.*
-    , json-fleece-codegen-util ==0.9.*
+    , json-fleece-codegen-util >=0.9 && <0.11
     , mtl >=2.2 && <2.4
     , non-empty-text ==0.2.*
     , openapi3 ==3.2.*
@@ -2075,7 +2077,7 @@ executable fleece-openapi3
   ghc-options: -rtsopts -threaded
   build-depends:
       base >=4.7 && <5
-    , json-fleece-codegen-util ==0.9.*
+    , json-fleece-codegen-util >=0.9 && <0.11
     , json-fleece-openapi3
   default-language: Haskell2010
   if flag(strict)
@@ -2096,7 +2098,7 @@ test-suite json-fleece-openapi3-test
     , bytestring ==0.11.*
     , file-embed >=0.0.15 && <0.0.17
     , hedgehog
-    , json-fleece-codegen-util ==0.9.*
+    , json-fleece-codegen-util >=0.9 && <0.11
     , json-fleece-openapi3
     , yaml ==0.11.*
   default-language: Haskell2010

json-fleece-openapi3/package.yaml

@@ -45,7 +45,7 @@ when:
 
 dependencies:
   - base >= 4.7 && < 5
-  - json-fleece-codegen-util >= 0.9 && < 0.10
+  - json-fleece-codegen-util >= 0.9 && < 0.11
 
 extra-source-files:
   - examples/star-trek/codegen.dhall