From 21c42142e200be92796c1fb919672aa3befeab82 Mon Sep 17 00:00:00 2001 From: Owen Graves Date: Tue, 6 Aug 2024 14:24:09 -0500 Subject: [PATCH] Support discriminated union components being referenced from other places This adds and exposes `objSchema`s so that discriminated tagged unions and normal objects can both refer to the same component. --- .../json-fleece-codegen-util.cabal | 2 +- json-fleece-codegen-util/package.yaml | 3 +- .../src/Fleece/CodeGenUtil.hs | 68 ++++++++++++------- .../test-cases/TestCases/Types/Bar.hs | 7 +- .../test-cases/TestCases/Types/Baz.hs | 7 +- .../test-cases/TestCases/Types/Foo.hs | 7 +- .../Types/ObjectWithDiscriminatedUnionRef.hs | 22 ++++++ .../TestCases/Types/OneOfWithDiscriminator.hs | 6 +- .../Types/OneOfWithDiscriminatorTypeObject.hs | 6 +- .../examples/test-cases/test-cases.cabal | 1 + .../examples/test-cases/test-cases.yaml | 6 ++ .../json-fleece-openapi3.cabal | 7 +- json-fleece-openapi3/package.yaml | 2 +- .../json-fleece-swagger2.cabal | 6 +- json-fleece-swagger2/package.yaml | 2 +- 15 files changed, 106 insertions(+), 46 deletions(-) create mode 100644 json-fleece-openapi3/examples/test-cases/TestCases/Types/ObjectWithDiscriminatedUnionRef.hs diff --git a/json-fleece-codegen-util/json-fleece-codegen-util.cabal b/json-fleece-codegen-util/json-fleece-codegen-util.cabal index 1ee6fb6..fe0ba05 100644 --- a/json-fleece-codegen-util/json-fleece-codegen-util.cabal +++ b/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 homepage: https://github.com/flipstone/json-fleece#readme bug-reports: https://github.com/flipstone/json-fleece/issues diff --git a/json-fleece-codegen-util/package.yaml b/json-fleece-codegen-util/package.yaml index 94eb425..c120f41 100644 --- a/json-fleece-codegen-util/package.yaml +++ b/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 - diff --git a/json-fleece-codegen-util/src/Fleece/CodeGenUtil.hs b/json-fleece-codegen-util/src/Fleece/CodeGenUtil.hs index 1d0509d..0d76a2f 100644 --- a/json-fleece-codegen-util/src/Fleece/CodeGenUtil.hs +++ b/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,6 +1824,7 @@ mkFleeceSchemaField typeMap moduleName codeGenField = do data SchemaTypeInfo = SchemaTypeInfo { schemaTypeExpr :: HC.TypeExpression , schemaTypeSchema :: HC.HaskellCode + , schemaTypeObjSchema :: HC.HaskellCode } primitiveSchemaTypeInfo :: HC.TypeName -> HC.HaskellCode -> SchemaTypeInfo @@ -1821,18 +1832,16 @@ 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 $ diff --git a/json-fleece-openapi3/examples/test-cases/TestCases/Types/Bar.hs b/json-fleece-openapi3/examples/test-cases/TestCases/Types/Bar.hs index ca7b3a8..c4829df 100644 --- a/json-fleece-openapi3/examples/test-cases/TestCases/Types/Bar.hs +++ b/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 \ No newline at end of file diff --git a/json-fleece-openapi3/examples/test-cases/TestCases/Types/Baz.hs b/json-fleece-openapi3/examples/test-cases/TestCases/Types/Baz.hs index d0a2b83..36d9666 100644 --- a/json-fleece-openapi3/examples/test-cases/TestCases/Types/Baz.hs +++ b/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 \ No newline at end of file diff --git a/json-fleece-openapi3/examples/test-cases/TestCases/Types/Foo.hs b/json-fleece-openapi3/examples/test-cases/TestCases/Types/Foo.hs index 732f965..340d1c7 100644 --- a/json-fleece-openapi3/examples/test-cases/TestCases/Types/Foo.hs +++ b/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 \ No newline at end of file diff --git a/json-fleece-openapi3/examples/test-cases/TestCases/Types/ObjectWithDiscriminatedUnionRef.hs b/json-fleece-openapi3/examples/test-cases/TestCases/Types/ObjectWithDiscriminatedUnionRef.hs new file mode 100644 index 0000000..de9d378 --- /dev/null +++ b/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 \ No newline at end of file diff --git a/json-fleece-openapi3/examples/test-cases/TestCases/Types/OneOfWithDiscriminator.hs b/json-fleece-openapi3/examples/test-cases/TestCases/Types/OneOfWithDiscriminator.hs index 963ba3a..c5c1747 100644 --- a/json-fleece-openapi3/examples/test-cases/TestCases/Types/OneOfWithDiscriminator.hs +++ b/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 \ No newline at end of file + FC.taggedUnionMember @"bar" Bar.barObjSchema + #@ FC.taggedUnionMember @"baz" Baz.bazObjSchema + #@ FC.taggedUnionMember @"foo" Foo.fooObjSchema \ No newline at end of file diff --git a/json-fleece-openapi3/examples/test-cases/TestCases/Types/OneOfWithDiscriminatorTypeObject.hs b/json-fleece-openapi3/examples/test-cases/TestCases/Types/OneOfWithDiscriminatorTypeObject.hs index 79d4800..3bceeeb 100644 --- a/json-fleece-openapi3/examples/test-cases/TestCases/Types/OneOfWithDiscriminatorTypeObject.hs +++ b/json-fleece-openapi3/examples/test-cases/TestCases/Types/OneOfWithDiscriminatorTypeObject.hs @@ -29,6 +29,6 @@ oneOfWithDiscriminatorTypeObjectSchema :: FC.Fleece schema => schema OneOfWithDi oneOfWithDiscriminatorTypeObjectSchema = FC.coerceSchema $ FC.taggedUnionNamed (FC.qualifiedName "TestCases.Types.OneOfWithDiscriminatorTypeObject" "OneOfWithDiscriminatorTypeObject") "type" $ - FC.taggedUnionMember @"bar" Bar.barSchema - #@ FC.taggedUnionMember @"baz" Baz.bazSchema - #@ FC.taggedUnionMember @"foo" Foo.fooSchema \ No newline at end of file + FC.taggedUnionMember @"bar" Bar.barObjSchema + #@ FC.taggedUnionMember @"baz" Baz.bazObjSchema + #@ FC.taggedUnionMember @"foo" Foo.fooObjSchema \ No newline at end of file diff --git a/json-fleece-openapi3/examples/test-cases/test-cases.cabal b/json-fleece-openapi3/examples/test-cases/test-cases.cabal index 4152673..c9d6730 100644 --- a/json-fleece-openapi3/examples/test-cases/test-cases.cabal +++ b/json-fleece-openapi3/examples/test-cases/test-cases.cabal @@ -171,6 +171,7 @@ library TestCases.Types.NameConflicts.Where TestCases.Types.NullableBoolean TestCases.Types.Num2SchemaStartingWithNumber + TestCases.Types.ObjectWithDiscriminatedUnionRef TestCases.Types.OneOfWithDiscriminator TestCases.Types.OneOfWithDiscriminatorTypeObject TestCases.Types.OneOfWithNullable diff --git a/json-fleece-openapi3/examples/test-cases/test-cases.yaml b/json-fleece-openapi3/examples/test-cases/test-cases.yaml index 05e39c9..54d561a 100644 --- a/json-fleece-openapi3/examples/test-cases/test-cases.yaml +++ b/json-fleece-openapi3/examples/test-cases/test-cases.yaml @@ -621,6 +621,12 @@ components: bar: "#/components/schemas/Bar" baz: "#/components/schemas/Baz" + ObjectWithDiscriminatedUnionRef: + type: object + properties: + bazRef: + $ref: "#/components/schemas/Baz" + Foo: type: object properties: diff --git a/json-fleece-openapi3/json-fleece-openapi3.cabal b/json-fleece-openapi3/json-fleece-openapi3.cabal index 2332855..ed31133 100644 --- a/json-fleece-openapi3/json-fleece-openapi3.cabal +++ b/json-fleece-openapi3/json-fleece-openapi3.cabal @@ -2018,6 +2018,7 @@ 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 @@ -2056,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.* @@ -2076,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) @@ -2097,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 diff --git a/json-fleece-openapi3/package.yaml b/json-fleece-openapi3/package.yaml index dd3e84e..038cc77 100644 --- a/json-fleece-openapi3/package.yaml +++ b/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 diff --git a/json-fleece-swagger2/json-fleece-swagger2.cabal b/json-fleece-swagger2/json-fleece-swagger2.cabal index 308603c..08537d0 100644 --- a/json-fleece-swagger2/json-fleece-swagger2.cabal +++ b/json-fleece-swagger2/json-fleece-swagger2.cabal @@ -85,7 +85,7 @@ library build-depends: base >=4.7 && <5 , insert-ordered-containers ==0.2.* - , json-fleece-codegen-util >=0.6 && <0.10 + , json-fleece-codegen-util >=0.6 && <0.11 , json-fleece-openapi3 ==0.4.* , openapi3 ==3.2.* , swagger2 ==2.8.* @@ -105,7 +105,7 @@ executable fleece-swagger2 ghc-options: -rtsopts -threaded build-depends: base >=4.7 && <5 - , json-fleece-codegen-util >=0.6 && <0.10 + , json-fleece-codegen-util >=0.6 && <0.11 , json-fleece-swagger2 default-language: Haskell2010 if flag(strict) @@ -127,7 +127,7 @@ test-suite json-fleece-swagger2-test , bytestring ==0.11.* , file-embed >=0.0.15 && <0.0.17 , hedgehog - , json-fleece-codegen-util >=0.6 && <0.10 + , json-fleece-codegen-util >=0.6 && <0.11 , json-fleece-swagger2 default-language: Haskell2010 if flag(strict) diff --git a/json-fleece-swagger2/package.yaml b/json-fleece-swagger2/package.yaml index 8a4eb1d..e5c8416 100644 --- a/json-fleece-swagger2/package.yaml +++ b/json-fleece-swagger2/package.yaml @@ -17,7 +17,7 @@ description: Please see the README on GitHub at = 4.7 && < 5 -- json-fleece-codegen-util >= 0.6 && < 0.10 +- json-fleece-codegen-util >= 0.6 && < 0.11 flags: strict: