Adds code-gen support for OpenAPI discriminators using Tagged Unions

Although the OpenAPI spec allows for more complicated scenarios, I've
restricted this to discriminator unions with an explicit mapping using
only schema types that are not referenced elsewhere. This allows us
to generate nearly the exact same code as we would write by hand for
handling our own tagged union schemas.

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

@@ -33,7 +33,7 @@ module Fleece.CodeGenUtil.HaskellCode
   , newline
   , quote
   , union
-  , unionTypeList
+  , taggedUnion
   , intercalate
   , lines
   , indent
@@ -57,6 +57,7 @@ module Fleece.CodeGenUtil.HaskellCode
   , enum
   , sumType
   , typeAnnotate
+  , typeApplication
   , stringLiteral
   , intLiteral
   , caseMatch
@@ -263,6 +264,10 @@ typeAnnotate :: VarName -> TypeExpression -> HaskellCode
 typeAnnotate item annotation =
   varNameToCode Nothing item <> " :: " <> toCode annotation
 
+typeApplication :: HaskellCode -> HaskellCode
+typeApplication code =
+  String.fromString "@" <> code
+
 indent :: Int -> HaskellCode -> HaskellCode
 indent n code =
   fromText (T.replicate n " ") <> code
@@ -280,8 +285,9 @@ toConstructorName typeName constructorName =
   case T.unpack constructorName of
     c : _
       | Char.isNumber c ->
-          ConstructorName . fromText $
-            Manip.toPascal (typeNameText typeName)
+          ConstructorName
+            . fromText
+            $ Manip.toPascal (typeNameText typeName)
               <> Manip.toPascal constructorName
     _ -> ConstructorName . fromText $ Manip.toPascal constructorName
 
@@ -445,18 +451,37 @@ mapOf keyName itemName =
     <> itemName
     <> ")"
 
-union :: TypeExpression
-union =
-  typeNameToCodeDefaultQualification (shrubberyType "Union")
-
-unionTypeList :: [TypeExpression] -> TypeExpression
-unionTypeList members =
+union :: [TypeExpression] -> TypeExpression
+union members =
   fromCode $
     lines
-      ( toCode union
+      ( typeNameToCodeDefaultQualification (shrubberyType "Union")
           : map (indent 2 . toCode) (delimitLines "'[ " " , " members <> [" ]"])
       )
 
+taggedUnion :: [(T.Text, TypeExpression)] -> TypeExpression
+taggedUnion members =
+  let
+    mkMemberExpression (tag, typeExpr) =
+      stringLiteral tag
+        <> " "
+        <> shrubberyTagAssignment
+        <> " "
+        <> toCode typeExpr
+
+    memberExpressions =
+      fmap mkMemberExpression members
+  in
+    fromCode $
+      lines
+        ( typeNameToCodeDefaultQualification (shrubberyType "TaggedUnion")
+            : map (indent 2 . toCode) (delimitLines "'[ " " , " memberExpressions <> [" ]"])
+        )
+
+shrubberyTagAssignment :: HaskellCode
+shrubberyTagAssignment =
+  addReferences [VarReference "Shrubbery" Nothing "type (@=)"] "@="
+
 quote :: HaskellCode -> HaskellCode
 quote code =
   "\"" <> code <> "\""

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

@@ -0,0 +1,21 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module TestCases.Types.Bar
+  ( Bar(..)
+  , barSchema
+  ) where
+
+import Fleece.Core ((#+), Object)
+import qualified Fleece.Core as FC
+import Prelude (Eq, Maybe, Show)
+import qualified TestCases.Types.Bar.BarName as BarName
+
+data Bar = Bar
+  { barName :: Maybe BarName.BarName
+  }
+  deriving (Eq, Show)
+
+barSchema :: FC.Fleece schema => Object schema Bar Bar
+barSchema =
+  FC.constructor Bar
+    #+ FC.optional "barName" barName BarName.barNameSchema

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

@@ -0,0 +1,17 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module TestCases.Types.Bar.BarName
+  ( BarName(..)
+  , barNameSchema
+  ) where
+
+import qualified Data.Text as T
+import qualified Fleece.Core as FC
+import Prelude (Eq, Show)
+
+newtype BarName = BarName T.Text
+  deriving (Show, Eq)
+
+barNameSchema :: FC.Fleece schema => schema BarName
+barNameSchema =
+  FC.coerceSchema FC.text

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

@@ -0,0 +1,17 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module TestCases.Types.Bar.Type
+  ( Type(..)
+  , typeSchema
+  ) where
+
+import qualified Data.Text as T
+import qualified Fleece.Core as FC
+import Prelude (Eq, Show)
+
+newtype Type = Type T.Text
+  deriving (Show, Eq)
+
+typeSchema :: FC.Fleece schema => schema Type
+typeSchema =
+  FC.coerceSchema FC.text

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

@@ -0,0 +1,21 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module TestCases.Types.Baz
+  ( Baz(..)
+  , bazSchema
+  ) where
+
+import Fleece.Core ((#+), Object)
+import qualified Fleece.Core as FC
+import Prelude (Eq, Maybe, Show)
+import qualified TestCases.Types.Baz.BazName as BazName
+
+data Baz = Baz
+  { bazName :: Maybe BazName.BazName
+  }
+  deriving (Eq, Show)
+
+bazSchema :: FC.Fleece schema => Object schema Baz Baz
+bazSchema =
+  FC.constructor Baz
+    #+ FC.optional "bazName" bazName BazName.bazNameSchema

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

@@ -0,0 +1,17 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module TestCases.Types.Baz.BazName
+  ( BazName(..)
+  , bazNameSchema
+  ) where
+
+import qualified Data.Text as T
+import qualified Fleece.Core as FC
+import Prelude (Eq, Show)
+
+newtype BazName = BazName T.Text
+  deriving (Show, Eq)
+
+bazNameSchema :: FC.Fleece schema => schema BazName
+bazNameSchema =
+  FC.coerceSchema FC.text

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

@@ -0,0 +1,17 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module TestCases.Types.Baz.Type
+  ( Type(..)
+  , typeSchema
+  ) where
+
+import qualified Data.Text as T
+import qualified Fleece.Core as FC
+import Prelude (Eq, Show)
+
+newtype Type = Type T.Text
+  deriving (Show, Eq)
+
+typeSchema :: FC.Fleece schema => schema Type
+typeSchema =
+  FC.coerceSchema FC.text

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

@@ -0,0 +1,17 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module TestCases.Types.Foo
+  ( Foo(..)
+  , fooSchema
+  ) where
+
+import Fleece.Core (Object)
+import qualified Fleece.Core as FC
+import Prelude (Eq, Show)
+
+data Foo = Foo
+  deriving (Eq, Show)
+
+fooSchema :: FC.Fleece schema => Object schema Foo Foo
+fooSchema =
+  FC.constructor Foo

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

@@ -0,0 +1,17 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module TestCases.Types.Foo.Type
+  ( Type(..)
+  , typeSchema
+  ) where
+
+import qualified Data.Text as T
+import qualified Fleece.Core as FC
+import Prelude (Eq, Show)
+
+newtype Type = Type T.Text
+  deriving (Show, Eq)
+
+typeSchema :: FC.Fleece schema => schema Type
+typeSchema =
+  FC.coerceSchema FC.text

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

@@ -0,0 +1,34 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ExplicitNamespaces #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeApplications #-}
+
+module TestCases.Types.OneOfWithDiscriminator
+  ( OneOfWithDiscriminator(..)
+  , oneOfWithDiscriminatorSchema
+  ) 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 OneOfWithDiscriminator = OneOfWithDiscriminator (Shrubbery.TaggedUnion
+  '[ "bar" @= Bar.Bar
+   , "baz" @= Baz.Baz
+   , "foo" @= Foo.Foo
+   ])
+  deriving (Show, Eq)
+
+oneOfWithDiscriminatorSchema :: FC.Fleece schema => schema OneOfWithDiscriminator
+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

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

@@ -1,5 +1,5 @@
-{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE DataKinds #-}
 
 module TestCases.Types.OneOfWithNullable
   ( OneOfWithNullable(..)

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

@@ -1,5 +1,5 @@
-{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE DataKinds #-}
 
 module TestCases.Types.ReferenceOneOfInsideOneOf
   ( ReferenceOneOfInsideOneOf(..)

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

@@ -1,5 +1,5 @@
-{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE DataKinds #-}
 
 module TestCases.Types.TopLevelOneOf
   ( TopLevelOneOf(..)

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

@@ -1,5 +1,5 @@
-{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE DataKinds #-}
 
 module TestCases.Types.TopLevelOneOfOneOption
   ( TopLevelOneOfOneOption(..)

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

@@ -78,6 +78,12 @@ library
       TestCases.Operations.TestCases.QueryParams.StringParam
       TestCases.Operations.TestCases.RequestBody
       TestCases.Types.AStringType
+      TestCases.Types.Bar
+      TestCases.Types.Bar.BarName
+      TestCases.Types.Bar.Type
+      TestCases.Types.Baz
+      TestCases.Types.Baz.BazName
+      TestCases.Types.Baz.Type
       TestCases.Types.CustomDateFormat
       TestCases.Types.DateTimeFormats
       TestCases.Types.DateTimeFormats.CustomLocalTimeField
@@ -104,6 +110,8 @@ library
       TestCases.Types.FieldTestCases.OptionalNullableField
       TestCases.Types.FieldTestCases.RequiredField
       TestCases.Types.FieldTestCases.RequiredNullableField
+      TestCases.Types.Foo
+      TestCases.Types.Foo.Type
       TestCases.Types.JustAdditionalPropertiesSchemaInline
       TestCases.Types.JustAdditionalPropertiesSchemaInlineItem
       TestCases.Types.JustAdditionalPropertiesSchemaRef
@@ -151,6 +159,7 @@ library
       TestCases.Types.NameConflicts.Type
       TestCases.Types.NameConflicts.Where
       TestCases.Types.Num2SchemaStartingWithNumber
+      TestCases.Types.OneOfWithDiscriminator
       TestCases.Types.OneOfWithNullable
       TestCases.Types.ReferenceOneOf
       TestCases.Types.ReferenceOneOfInsideOneOf

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

@@ -580,6 +580,41 @@ components:
       oneOf:
         - type: string
 
+    OneOfWithDiscriminator:
+      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"
+
+    Foo:
+      type: object
+      properties:
+        type:
+          type: string
+
+    Bar:
+      type: object
+      properties:
+        type:
+          type: string
+        barName:
+          type: string
+
+    Baz:
+      type: object
+      properties:
+        type:
+          type: string
+        bazName:
+          type: string
+
     TopLevelArray:
       type: array
       description: A schema that defines a top level array