Clean up oneOf code gen and support inline nullability

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

@@ -266,10 +266,8 @@ newtype CodeGenAdditionalProperties = CodeGenAdditionalProperties
 data CodeGenRefType
   = TypeReference T.Text
   | CodeGenRefMap CodeGenRefType
-  | CodeGenRefArray
-      -- | whether the array itself is nullable
-      Bool
-      CodeGenRefType
+  | CodeGenRefArray CodeGenRefType
+  | CodeGenRefNullable CodeGenRefType
 
 resolveRefTypeInfo ::
   CodeGenMap ->
@@ -285,16 +283,12 @@ resolveRefTypeInfo typeMap =
               pure (codeGenTypeSchemaInfo codeGenType)
             _ ->
               codeGenError $ "Type " <> show ref <> " not found."
-        CodeGenRefArray nullable itemType ->
-          let
-            modifier =
-              if nullable
-                then nullableTypeInfo
-                else id
-          in
-            fmap (modifier . arrayTypeInfo) (go itemType)
+        CodeGenRefArray itemType ->
+          fmap arrayTypeInfo (go itemType)
         CodeGenRefMap itemType ->
           fmap mapTypeInfo (go itemType)
+        CodeGenRefNullable itemType ->
+          fmap nullableTypeInfo (go itemType)
   in
     go
 
@@ -316,10 +310,12 @@ resolveFieldDescription typeMap =
               Nothing
             Nothing ->
               Nothing
-        CodeGenRefArray _nullable itemType ->
+        CodeGenRefArray itemType ->
           go itemType
         CodeGenRefMap itemType ->
           go itemType
+        CodeGenRefNullable itemType ->
+          go itemType
   in
     go
 
@@ -1347,7 +1343,7 @@ generateFleeceUnion typeMap typeName members = do
     unionNewType =
       HC.newtype_
         typeName
-        ("(" <> HC.typeList (schemaTypeExpr <$> typeInfos) <> ")")
+        ("(" <> HC.unionTypeList (schemaTypeExpr <$> typeInfos) <> ")")
         Nothing
 
     extraExports =
@@ -1381,18 +1377,18 @@ generateFleeceObject typeMap typeName codeGenFields mbAdditionalProperties typeO
 
   mbAdditionalPropertiesSchemaTypeInfo <- mapM (schemaInfoOrRefToSchemaTypeInfo typeMap . codeGenAdditionalPropertiesSchemaInfoOrRef) mbAdditionalProperties
 
-  additionalPropsFieldNameAndType <-
-    case mbAdditionalPropertiesSchemaTypeInfo of
-      Nothing ->
-        pure []
-      Just additionalPropsTypeInfo -> do
-        pure
+  let
+    additionalPropsFieldNameAndType =
+      case mbAdditionalPropertiesSchemaTypeInfo of
+        Nothing ->
+          []
+        Just additionalPropsTypeInfo -> do
           [
             ( additionalPropsFieldName
             , schemaTypeExpr (mapTypeInfo additionalPropsTypeInfo)
             , Nothing
             )
-          ]
+            ]
 
   let
     fieldNameAndType field =

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

@@ -32,10 +32,8 @@ module Fleece.CodeGenUtil.HaskellCode
   , renderString
   , newline
   , quote
-  , taggedUnion
   , union
-  , typeList
-  , taggedUnionTypeList
+  , unionTypeList
   , intercalate
   , lines
   , indent
@@ -73,7 +71,7 @@ module Fleece.CodeGenUtil.HaskellCode
 -- import prelude explicitly since we want to define our own 'lines' function
 
 import Data.Maybe (fromMaybe)
-import Prelude (Eq ((==)), Foldable, Int, Maybe (Just, Nothing), Monoid (mempty), Ord, Semigroup ((<>)), String, any, flip, fmap, id, map, maybe, mconcat, show, zip, ($), (.))
+import Prelude (Eq ((==)), Foldable, Int, Maybe (Just, Nothing), Monoid (mempty), Ord, Semigroup ((<>)), String, any, flip, fmap, id, map, maybe, mconcat, show, zip, ($), (+), (-), (.))
 
 import qualified Data.Char as Char
 import Data.Foldable (toList)
@@ -253,10 +251,6 @@ 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
 
@@ -437,38 +431,22 @@ mapOf keyName itemName =
     <> itemName
     <> ")"
 
-taggedUnion :: TypeExpression
-taggedUnion =
-  typeNameToCodeDefaultQualification (shrubberyType "TaggedUnion")
-
 union :: TypeExpression
 union =
   typeNameToCodeDefaultQualification (shrubberyType "Union")
 
-typeList :: [TypeExpression] -> TypeExpression
-typeList =
-  prefixedTypeList Nothing
+unionTypeList :: [TypeExpression] -> TypeExpression
+unionTypeList members =
+  fromCode $
+    lines
+      ( toCode union
+          : map (indent 2 . toCode) (delimitLines "'[ " " , " members <> ["]"])
+      )
 
 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")
@@ -486,8 +464,24 @@ eitherOf left right =
 guardParens :: TypeExpression -> TypeExpression
 guardParens name =
   let
+    removeTextInsideChars openChar closeChar t =
+      let
+        go text numParens =
+          case (T.uncons text, numParens) of
+            (Nothing, _) -> ""
+            (Just (c, rest), n) | c == openChar -> go rest (n + 1)
+            (Just (c, rest), n) | c == closeChar -> go rest (n - 1)
+            (Just (c, rest), 0) -> T.cons c $ go rest 0
+            (Just (_, rest), n) -> go rest n
+      in
+        go t (0 :: Int)
+    removeTextInsideParens = removeTextInsideChars '(' ')'
+    removeTextInsideBrackets = removeTextInsideChars '[' ']'
     needsParens =
-      T.elem ' ' (renderText name)
+      T.elem ' '
+        . removeTextInsideBrackets
+        . removeTextInsideParens
+        $ renderText name
   in
     if needsParens
       then fromCode "(" <> name <> fromCode ")"
@@ -522,7 +516,7 @@ sumType :: TypeName -> [(ConstructorName, TypeExpression)] -> Maybe [TypeName] -
 sumType typeName constructors mbDeriveClasses =
   let
     mkConstructor (conName, conArgType) =
-      toCode conName <> " " <> toCode conArgType
+      toCode conName <> " " <> toCode (guardParens conArgType)
 
     constructorLines =
       delimitLines "= " "| " (map mkConstructor constructors)

json-fleece-openapi3/examples/test-cases/TestCases/Operations/TestCases/InlineNullableIntegerArrayResponse.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module TestCases.Operations.TestCases.InlineNullableIntegerArrayResponse
+  ( operation
+  , route
+  , Responses(..)
+  , responseSchemas
+  ) where
+
+import qualified Beeline.HTTP.Client as H
+import Beeline.Routing ((/-))
+import qualified Beeline.Routing as R
+import qualified Fleece.Aeson.Beeline as FA
+import qualified Fleece.Core as FC
+import Prelude (($), Either, Eq, Integer, Show, fmap)
+
+operation ::
+  H.Operation
+    H.ContentTypeDecodingError
+    H.NoPathParams
+    H.NoQueryParams
+    H.NoHeaderParams
+    H.NoRequestBody
+    Responses
+operation =
+  H.defaultOperation
+    { H.requestRoute = route
+    , H.responseSchemas = responseSchemas
+    }
+
+route :: R.Router r => r H.NoPathParams
+route =
+  R.get $
+    R.make H.NoPathParams
+      /- "test-cases"
+      /- "inline-nullable-integer-array-response"
+
+data Responses
+  = Response200 (Either FC.Null [Either FC.Null Integer])
+  deriving (Eq, Show)
+
+responseSchemas :: [(H.StatusRange, H.ResponseBodySchema H.ContentTypeDecodingError Responses)]
+responseSchemas =
+  [ (H.Status 200, fmap Response200 (H.responseBody FA.JSON (FC.nullable (FC.list (FC.nullable FC.integer)))))
+  ]

json-fleece-openapi3/examples/test-cases/TestCases/Operations/TestCases/InlineNullableIntegerResponse.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module TestCases.Operations.TestCases.InlineNullableIntegerResponse
+  ( operation
+  , route
+  , Responses(..)
+  , responseSchemas
+  ) where
+
+import qualified Beeline.HTTP.Client as H
+import Beeline.Routing ((/-))
+import qualified Beeline.Routing as R
+import qualified Fleece.Aeson.Beeline as FA
+import qualified Fleece.Core as FC
+import Prelude (($), Either, Eq, Integer, Show, fmap)
+
+operation ::
+  H.Operation
+    H.ContentTypeDecodingError
+    H.NoPathParams
+    H.NoQueryParams
+    H.NoHeaderParams
+    H.NoRequestBody
+    Responses
+operation =
+  H.defaultOperation
+    { H.requestRoute = route
+    , H.responseSchemas = responseSchemas
+    }
+
+route :: R.Router r => r H.NoPathParams
+route =
+  R.get $
+    R.make H.NoPathParams
+      /- "test-cases"
+      /- "inline-nullable-integer-response"
+
+data Responses
+  = Response200 (Either FC.Null Integer)
+  deriving (Eq, Show)
+
+responseSchemas :: [(H.StatusRange, H.ResponseBodySchema H.ContentTypeDecodingError Responses)]
+responseSchemas =
+  [ (H.Status 200, fmap Response200 (H.responseBody FA.JSON (FC.nullable FC.integer)))
+  ]

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

@@ -0,0 +1,35 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module TestCases.Types.OneOfWithNullable
+  ( OneOfWithNullable(..)
+  , oneOfWithNullableSchema
+  ) where
+
+import qualified Data.Text as T
+import Fleece.Core ((#|))
+import qualified Fleece.Core as FC
+import Prelude (($), Either, Eq, Integer, Show)
+import qualified Shrubbery as Shrubbery
+import qualified TestCases.Types.AStringType as AStringType
+
+newtype OneOfWithNullable = OneOfWithNullable (Shrubbery.Union
+  '[ Integer
+   , Either FC.Null T.Text
+   , Either FC.Null [Either FC.Null T.Text]
+   , [AStringType.AStringType]
+   , Either FC.Null [AStringType.AStringType]
+   , [Either FC.Null [AStringType.AStringType]]
+  ])
+  deriving (Show, Eq)
+
+oneOfWithNullableSchema :: FC.Fleece schema => schema OneOfWithNullable
+oneOfWithNullableSchema =
+  FC.coerceSchema $
+    FC.unionNamed (FC.qualifiedName "TestCases.Types.OneOfWithNullable" "OneOfWithNullable") $
+      FC.unionMember FC.integer
+        #| FC.unionMember (FC.nullable FC.text)
+        #| FC.unionMember (FC.nullable (FC.list (FC.nullable FC.text)))
+        #| FC.unionMember (FC.list AStringType.aStringTypeSchema)
+        #| FC.unionMember (FC.nullable (FC.list AStringType.aStringTypeSchema))
+        #| FC.unionMember (FC.list (FC.nullable (FC.list AStringType.aStringTypeSchema)))

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

@@ -13,7 +13,11 @@ import qualified Shrubbery as Shrubbery
 import qualified TestCases.Types.ReferenceOneOf as ReferenceOneOf
 import qualified TestCases.Types.TopLevelOneOfOneOption as TopLevelOneOfOneOption
 
-newtype ReferenceOneOfInsideOneOf = ReferenceOneOfInsideOneOf (Shrubbery.Union '[ReferenceOneOf.ReferenceOneOf, TopLevelOneOfOneOption.TopLevelOneOfOneOption, [TopLevelOneOfOneOption.TopLevelOneOfOneOption]])
+newtype ReferenceOneOfInsideOneOf = ReferenceOneOfInsideOneOf (Shrubbery.Union
+  '[ ReferenceOneOf.ReferenceOneOf
+   , TopLevelOneOfOneOption.TopLevelOneOfOneOption
+   , [TopLevelOneOfOneOption.TopLevelOneOfOneOption]
+  ])
   deriving (Show, Eq)
 
 referenceOneOfInsideOneOfSchema :: FC.Fleece schema => schema ReferenceOneOfInsideOneOf

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

@@ -16,7 +16,15 @@ 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, [T.Text], AStringType.AStringType, Num2SchemaStartingWithNumber.Num2SchemaStartingWithNumber, [FieldDescriptions.FieldDescriptions], [[MixedInJustAdditionalPropertiesSchemaInline.MixedInJustAdditionalPropertiesSchemaInline]]])
+newtype TopLevelOneOf = TopLevelOneOf (Shrubbery.Union
+  '[ T.Text
+   , Integer
+   , [T.Text]
+   , AStringType.AStringType
+   , Num2SchemaStartingWithNumber.Num2SchemaStartingWithNumber
+   , [FieldDescriptions.FieldDescriptions]
+   , [[MixedInJustAdditionalPropertiesSchemaInline.MixedInJustAdditionalPropertiesSchemaInline]]
+  ])
   deriving (Show, Eq)
 
 topLevelOneOfSchema :: FC.Fleece schema => schema TopLevelOneOf

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

@@ -11,7 +11,9 @@ import qualified Fleece.Core as FC
 import Prelude (($), Eq, Show)
 import qualified Shrubbery as Shrubbery
 
-newtype TopLevelOneOfOneOption = TopLevelOneOfOneOption (Shrubbery.Union '[T.Text])
+newtype TopLevelOneOfOneOption = TopLevelOneOfOneOption (Shrubbery.Union
+  '[ T.Text
+  ])
   deriving (Show, Eq)
 
 topLevelOneOfOneOptionSchema :: FC.Fleece schema => schema TopLevelOneOfOneOption

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

@@ -44,6 +44,8 @@ library
       TestCases.Operations.TestCases.InlineInt32Response
       TestCases.Operations.TestCases.InlineInt64Response
       TestCases.Operations.TestCases.InlineIntegerResponse
+      TestCases.Operations.TestCases.InlineNullableIntegerArrayResponse
+      TestCases.Operations.TestCases.InlineNullableIntegerResponse
       TestCases.Operations.TestCases.InlineObjectAdditionalPropertiesJsonResponse
       TestCases.Operations.TestCases.InlineObjectJsonResponse
       TestCases.Operations.TestCases.InlineObjectStringArrayResponse
@@ -139,6 +141,7 @@ library
       TestCases.Types.NameConflicts.Type
       TestCases.Types.NameConflicts.Where
       TestCases.Types.Num2SchemaStartingWithNumber
+      TestCases.Types.OneOfWithNullable
       TestCases.Types.ReferenceOneOf
       TestCases.Types.ReferenceOneOfInsideOneOf
       TestCases.Types.StringParam