wip 2

flipstone · Mar 14, 2024 · 5e9fa1d · 5e9fa1d
1 parent 72f652f
commit 5e9fa1d
Show file tree

Hide file tree

Showing 3 changed files with 88 additions and 1 deletion.
diff --git a/json-fleece-codegen-util/src/Fleece/CodeGenUtil/HaskellCode.hs b/json-fleece-codegen-util/src/Fleece/CodeGenUtil/HaskellCode.hs
@@ -31,6 +31,9 @@ module Fleece.CodeGenUtil.HaskellCode
   , renderText
   , renderString
   , newline
+  , taggedUnion
+  , typeList
+  , taggedUnionTypeList
   , intercalate
   , lines
   , indent
@@ -62,16 +65,18 @@ module Fleece.CodeGenUtil.HaskellCode
   , enumClass
   , boundedClass
   , preludeType
+  , shrubberyType
   ) where
 
 -- 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, const, flip, fmap, id, map, maybe, mconcat, show, zip, ($), (.))
 
 import qualified Data.Char as Char
 import Data.Foldable (toList)
 import qualified Data.List as List
+import qualified Data.List.NonEmpty as NEL
 import qualified Data.NonEmptyText as NET
 import qualified Data.Set as Set
 import qualified Data.String as String
@@ -409,6 +414,46 @@ deriving_ :: [TypeName] -> HaskellCode
 deriving_ classes =
   "deriving (" <> intercalate ", " (map (typeNameToCode Nothing) classes) <> ")"
 
+taggedUnion :: TypeExpression -> TypeExpression
+taggedUnion unionName =
+  typeNameToCodeDefaultQualification (shrubberyType "TaggedUnion")
+    <> " "
+    <> unionName
+
+typeList :: TypeName -> NEL.NonEmpty TypeExpression -> HaskellCode
+typeList =
+  prefixedTypeList Nothing
+
+taggedUnionTypeList :: TypeName -> NEL.NonEmpty TypeExpression -> HaskellCode
+taggedUnionTypeList =
+  prefixedTypeList (Just $ \member -> "\"" <> member <> "\" @= ")
+
+prefixedTypeList ::
+  Maybe (HaskellCode -> HaskellCode) ->
+  TypeName ->
+  NEL.NonEmpty TypeExpression ->
+  HaskellCode
+prefixedTypeList mbPrefixFn typeListName members =
+  let
+    first = toCode $ NEL.head members
+    rest = map toCode $ NEL.tail members
+    prefix =
+      case mbPrefixFn of
+        Just prefixFn -> prefixFn
+        Nothing -> const mempty
+
+    firstMember = "[ " <> prefix first <> first
+    restMembers = map (\member -> ", \"" <> member <> member) rest
+  in
+    lines
+      [ "type "
+          <> typeNameToCode Nothing typeListName
+          <> " ="
+      , indent 2 firstMember
+      , lines $ map (indent 2) restMembers
+      , indent 2 "]"
+      ]
+
 listOf :: TypeExpression -> TypeExpression
 listOf itemName =
   TypeExpression ("[" <> toCode itemName <> "]")
@@ -528,3 +573,7 @@ boundedClass =
 preludeType :: T.Text -> TypeName
 preludeType =
   toTypeName "Prelude" Nothing
+
+shrubberyType :: T.Text -> TypeName
+shrubberyType =
+  toTypeName "Shrubbery" (Just "Shrubbery")
diff --git a/json-fleece-openapi3/examples/one-of/one-of.cabal b/json-fleece-openapi3/examples/one-of/one-of.cabal
@@ -16,6 +16,7 @@ build-type:     Simple
 
 library
   exposed-modules:
+<<<<<<< Updated upstream
       OneOfTest.Operations.GetMultiplePathsParams
       OneOfTest.Operations.GetMultiplePathsParams.Param1
       OneOfTest.Operations.GetMultiplePathsParams.Param2
@@ -147,6 +148,11 @@ library
       OneOfTest.Types.TopLevelArrayNullable.TopLevelArrayNullableItem
       OneOfTest.Types.UtcTimeType
       OneOfTest.Types.ZonedTimeType
+=======
+      OneOfTest.Types.AStringType
+      OneOfTest.Types.Obj
+      OneOfTest.Types.Obj.Foobar
+>>>>>>> Stashed changes
   other-modules:
       Paths_one_of
   hs-source-dirs:

diff --git a/json-fleece-openapi3/src/Fleece/OpenApi3.hs b/json-fleece-openapi3/src/Fleece/OpenApi3.hs
@@ -2,6 +2,10 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+<<<<<<< Updated upstream
+=======
+{-# OPTIONS_GHC -Wwarn #-}
+>>>>>>> Stashed changes
 
 module Fleece.OpenApi3
   ( generateOpenApiFleeceCode
@@ -803,6 +807,7 @@ mkOpenApiDataFormat schemaKey typeName schema =
         noRefs $ pure (CGU.nullFormat typeOptions)
       Nothing ->
         case OA._schemaOneOf schema of
+<<<<<<< Updated upstream
           Just schemas ->
             mkOneOf schemas
           Nothing ->
@@ -822,6 +827,33 @@ mkOneOf schemas =
       oa
    in do
   (maps, dataFormats) <- fmap unzip . traverse mkCodeGenDataFormat $ mapMaybe mk schemas
+=======
+          Just schemas -> mkOneOf schemas
+          Nothing -> mkOpenApiObjectFormatOrAdditionalPropertiesNewtype CGU.Type schemaKey typeName schema
+
+mkOneOf ::
+  [OA.Referenced OA.Schema] ->
+  CGU.CodeGen (SchemaMap, CGU.CodeGenDataFormat)
+mkOneOf schemas = do
+  let
+    mk :: OA.Referenced OA.Schema -> Maybe OA.Schema
+    mk schema =
+      case schema of
+        OA.Inline foo -> Just foo
+        OA.Ref ref -> Nothing -- TODO
+    mkCodeGenDataFormat ::
+      OA.Schema ->
+      CGU.CodeGen (SchemaMap, CGU.CodeGenDataFormat)
+    mkCodeGenDataFormat oa =
+      mkOpenApiDataFormat
+        "foobar" -- TODO
+        (HC.preludeType "Integer")
+        oa
+
+  (maps, dataFormats) <-
+    fmap unzip . traverse mkCodeGenDataFormat $ mapMaybe mk schemas
+
+>>>>>>> Stashed changes
   pure (Map.unions maps, CGU.CodeGenUnionMembers dataFormats)
 
 mkOpenApiStringFormat :: HC.TypeName -> OA.Schema -> CGU.CodeGen CGU.CodeGenDataFormat