WIP: Adding code-gen support for OpenAPI discriminators using Tagged …

…Unions

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
@@ -97,8 +98,8 @@ addReferences refs c =
   let
     code = toCode c
   in
-    fromCode $
-      code
+    fromCode
+      $ code
         { codeReferences = Set.fromList refs <> codeReferences code
         }
 
@@ -228,8 +229,8 @@ varNameToCodeDefaultQualification varName =
 
 fromText :: FromCode c => T.Text -> c
 fromText t =
-  fromCode $
-    HaskellCode
+  fromCode
+    $ HaskellCode
       { codeReferences = mempty
       , codeBuilder = LTB.fromText t
       }
@@ -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,9 +285,10 @@ toConstructorName typeName constructorName =
   case T.unpack constructorName of
     c : _
       | Char.isNumber c ->
-          ConstructorName . fromText $
-            Manip.toPascal (typeNameText typeName)
-              <> Manip.toPascal constructorName
+          ConstructorName
+            . fromText
+            $ Manip.toPascal (typeNameText typeName)
+            <> Manip.toPascal constructorName
     _ -> ConstructorName . fromText $ Manip.toPascal constructorName
 
 toModuleName :: T.Text -> ModuleName
@@ -445,18 +451,37 @@ mapOf keyName itemName =
     <> itemName
     <> ")"
 
-union :: TypeExpression
-union =
-  typeNameToCodeDefaultQualification (shrubberyType "Union")
-
-unionTypeList :: [TypeExpression] -> TypeExpression
-unionTypeList members =
-  fromCode $
-    lines
-      ( toCode union
+union :: [TypeExpression] -> TypeExpression
+union members =
+  fromCode
+    $ lines
+      ( 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 <> "\""
@@ -516,8 +541,8 @@ enum typeName constructors mbDeriveClasses =
       delimitLines "= " "| " (map toCode constructors)
 
     derivations =
-      deriving_ $
-        fromMaybe
+      deriving_
+        $ fromMaybe
           [eqClass, showClass, ordClass, enumClass, boundedClass]
           mbDeriveClasses
   in

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

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

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,25 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module TestCases.Types.Baz
+  ( Baz(..)
+  , bazSchema
+  ) where
+
+import Fleece.Core ((#+))
+import qualified Fleece.Core as FC
+import Prelude (($), Eq, Maybe, Show)
+import qualified TestCases.Types.Baz.BazName as BazName
+import qualified TestCases.Types.Baz.Type as Type
+
+data Baz = Baz
+  { bazName :: Maybe BazName.BazName
+  , type_ :: Maybe Type.Type
+  }
+  deriving (Eq, Show)
+
+bazSchema :: FC.Fleece schema => schema Baz
+bazSchema =
+  FC.object $
+    FC.constructor Baz
+      #+ FC.optional "bazName" bazName BazName.bazNameSchema
+      #+ FC.optional "type" type_ Type.typeSchema

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,25 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module TestCases.Types.Foo
+  ( Foo(..)
+  , fooSchema
+  ) where
+
+import Fleece.Core ((#+))
+import qualified Fleece.Core as FC
+import Prelude (($), Eq, Maybe, Show)
+import qualified TestCases.Types.Foo.FooName as FooName
+import qualified TestCases.Types.Foo.Type as Type
+
+data Foo = Foo
+  { fooName :: Maybe FooName.FooName
+  , type_ :: Maybe Type.Type
+  }
+  deriving (Eq, Show)
+
+fooSchema :: FC.Fleece schema => schema Foo
+fooSchema =
+  FC.object $
+    FC.constructor Foo
+      #+ FC.optional "fooName" fooName FooName.fooNameSchema
+      #+ FC.optional "type" type_ Type.typeSchema

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

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

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(..)