diff --git a/json-spec-elm.cabal b/json-spec-elm.cabal --- a/json-spec-elm.cabal +++ b/json-spec-elm.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: json-spec-elm -version: 0.3.0.4 +version: 0.4.0.0 synopsis: Elm code generate for `json-spec`. description: Produce elm types, encoders, and decoders from a @@ -12,7 +12,7 @@ license-file: LICENSE author: Rick Owens maintainer: rick@owensmurray.com -copyright: 2022 Rick Owens +copyright: 2024 Rick Owens category: JSON, Elm build-type: Simple extra-source-files: @@ -22,22 +22,19 @@ common dependencies build-depends: , base >= 4.17.2.1 && < 4.20 - , bound >= 2.0.7 && < 2.1 , containers >= 0.6.7 && < 0.7 , elm-syntax >= 0.3.2.0 && < 0.4 - , json-spec >= 0.2.1.0 && < 0.3 - , mtl >= 2.2.2 && < 2.4 - , prettyprinter >= 1.7.1 && < 1.8 + , json-spec >= 0.3.0.0 && < 0.4 , text >= 2.0.2 && < 2.2 - , unordered-containers >= 0.2.19.1 && < 0.3 common warnings ghc-options: + -Wall -Wmissing-deriving-strategies -Wmissing-export-lists -Wmissing-import-lists -Wredundant-constraints - -Wall + -Wunused-packages library import: dependencies, warnings @@ -47,6 +44,9 @@ -- other-extensions: hs-source-dirs: src default-language: Haskell2010 + build-depends: + , bound >= 2.0.7 && < 2.1 + , mtl >= 2.2.2 && < 2.4 test-suite test import: dependencies, warnings @@ -56,7 +56,9 @@ default-language: Haskell2010 build-depends: , json-spec-elm - , directory >= 1.3.7.1 && < 1.4 - , hspec >= 2.11.1 && < 2.12 - , process >= 1.6.16.0 && < 1.7 + , directory >= 1.3.7.1 && < 1.4 + , hspec >= 2.11.1 && < 2.12 + , prettyprinter >= 1.7.1 && < 1.8 + , process >= 1.6.16.0 && < 1.7 + , unordered-containers >= 0.2.19.1 && < 0.3 diff --git a/src/Data/JsonSpec/Elm.hs b/src/Data/JsonSpec/Elm.hs --- a/src/Data/JsonSpec/Elm.hs +++ b/src/Data/JsonSpec/Elm.hs @@ -73,7 +73,7 @@ > (Named "AnInt" JsonInt) > ( JsonEither > JsonFloat -- note the omitted name - > ( Named "AString" JsonString) + > ( Named "AString" JsonString) > ) > ) @@ -85,7 +85,7 @@ > | AString String == Producing actual Elm code - + This package gets you as far as having a collection of 'Definition's in hand, which come from the 'elm-syntax' package. You will need to use the pretty printing @@ -104,9 +104,10 @@ import Bound (Scope(Scope), Var(B), abstract1, closed, toScope) import Control.Monad.Writer (MonadTrans(lift), MonadWriter(tell), Writer, execWriter) -import Data.JsonSpec (Specification(JsonArray, JsonBool, JsonDateTime, - JsonEither, JsonInt, JsonLet, JsonNullable, JsonNum, JsonObject, - JsonRef, JsonString, JsonTag)) +import Data.JsonSpec (FieldSpec(Optional, Required), + Specification(JsonArray, JsonBool, JsonDateTime, JsonEither, JsonInt, + JsonLet, JsonNullable, JsonNum, JsonObject, JsonRef, JsonString, + JsonTag)) import Data.Proxy (Proxy(Proxy)) import Data.Set (Set) import Data.String (IsString(fromString)) @@ -118,9 +119,10 @@ import Language.Elm.Expression ((|>), Expression, if_) import Language.Elm.Name (Constructor, Qualified) import Language.Elm.Type (Type) -import Prelude (Applicative(pure), Foldable(foldl, foldr), Functor(fmap), - Maybe(Just, Nothing), Monad((>>)), Semigroup((<>)), Show(show), ($), - (++), (.), (<$>), Int, error, fst, snd, zip) +import Prelude (Applicative(pure), Bool(False, True), Foldable(foldl, + foldr), Functor(fmap), Maybe(Just, Nothing), Monad((>>)), + Semigroup((<>)), Show(show), ($), (++), (.), (<$>), Int, error, fst, + snd, zip) import qualified Data.Char as Char import qualified Data.Set as Set import qualified Data.Text as Text @@ -146,9 +148,9 @@ execWriter $ typeOf @spec >> decoderOf @spec -class Record (spec :: [(Symbol, Specification)]) where +class Record (spec :: [FieldSpec]) where recordDefs :: forall v. Definitions [(Name.Field, Type v)] - recordEncoders :: Definitions [(Text, Name.Field, Expression Void)] + recordEncoders :: Definitions [(Bool, Text, Name.Field, Expression Void)] recordDecoders :: Definitions [(Text, Expression Void)] instance Record '[] where recordDefs = pure [] @@ -160,7 +162,7 @@ , Record more ) => - Record ( '(name, spec) : more ) + Record ( Required name spec : more ) where recordDefs = do type_ <- typeOf @spec @@ -169,7 +171,7 @@ recordEncoders = do encoder <- encoderOf @spec moreFields <- recordEncoders @more - pure $ (sym @name, fieldName (sym @name), encoder) : moreFields + pure $ (True, sym @name, fieldName (sym @name), encoder) : moreFields recordDecoders = do dec <- decoderOf @spec more <- recordDecoders @more @@ -177,6 +179,30 @@ ( sym @name , "Json.Decode.field" `a` Expr.String (sym @name) `a` dec ) : more +instance + ( HasType spec + , KnownSymbol name + , Record more + ) + => + Record ( Optional name spec : more ) + where + recordDefs = do + type_ <- ta "Maybe.Maybe" <$> typeOf @spec + moreFields <- recordDefs @more + pure $ (fieldName (sym @name), type_) : moreFields + recordEncoders = do + encoder <- encoderOf @spec + moreFields <- recordEncoders @more + pure $ (False, sym @name, fieldName (sym @name), encoder) : moreFields + recordDecoders = do + dec <- decoderOf @spec + more <- recordDecoders @more + pure $ + ( sym @name + , "Json.Decode.maybe" + `a` ("Json.Decode.field" `a` Expr.String (sym @name) `a` dec) + ) : more {-| @@ -233,21 +259,36 @@ ("Json.Decode.succeed" `a` recordConstructor (fst <$> decoders)) (snd <$> decoders) encoderOf = do - fields <- recordEncoders @fields - pure $ - Expr.Lam . toScope $ - "Json.Encode.object" `a` - Expr.List - [ Expr.apps "Basics.," [ - Expr.String jsonField, - Expr.bind Expr.Global absurd encoder `a` - (Expr.Proj elmField `a` Expr.Var var) - ] - | (jsonField, elmField, encoder) <- fields - ] - where - var :: Bound.Var () a - var = B () + fields <- recordEncoders @fields + pure $ + lam (\var -> + "Json.Encode.object" `a` + ( + "List.filterMap" + `a` "Basics.identity" + `a` Expr.List + [ if required then + "Maybe.Just" `a` + Expr.apps "Basics.," + [ + Expr.String jsonField, + fmap absurd encoder `a` + (Expr.Proj elmField `a` var) + ] + else + "Maybe.map" + `a` lam (\inner -> + Expr.apps "Basics.," + [ + Expr.String jsonField, + fmap absurd encoder `a` inner + ] + ) + `a` (Expr.Proj elmField `a` var) + | (required, jsonField, elmField, encoder) <- fields + ] + ) + ) instance (HasType spec) => HasType (JsonArray spec) where typeOf = do elemType <- typeOf @spec @@ -279,7 +320,7 @@ [ "Json.Encode.null" , Expr.apps "Maybe.map" - [ Expr.bind Expr.Global absurd encoder + [ fmap absurd encoder , Expr.Var (B ()) ] ] @@ -642,6 +683,17 @@ ] +{-| + Produce lambda in Elm out of a haskell function. + + > lam (\var -> + > "elmFunction" `a` var + > ) + + produces an Elm lambda expression of the form + + > (\var -> elmFunction var) +-} lam :: (Expression (Var () a) -> Expression (Var () v)) -> Expression v diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -6,8 +6,9 @@ import Data.Foldable (traverse_) import Data.HashMap.Strict (HashMap) -import Data.JsonSpec (Specification(JsonArray, JsonDateTime, JsonEither, - JsonInt, JsonLet, JsonNullable, JsonNum, JsonObject, JsonRef, JsonString, JsonTag)) +import Data.JsonSpec (FieldSpec(Optional, Required), + Specification(JsonArray, JsonDateTime, JsonEither, JsonInt, JsonLet, + JsonNullable, JsonNum, JsonObject, JsonRef, JsonString, JsonTag)) import Data.JsonSpec.Elm (Named, elmDefs) import Data.Maybe (fromMaybe) import Data.Proxy (Proxy(Proxy)) @@ -89,25 +90,25 @@ , " Json.Decode.andThen (\\c -> Json.Decode.map c (Json.Decode.field \"invites\" (Json.Decode.list inviteDecoder))) |>" , " Json.Decode.andThen (\\c -> Json.Decode.map c (Json.Decode.field \"created-at\" Iso8601.decoder)) |>" , " Json.Decode.andThen (\\c -> Json.Decode.map c (Json.Decode.field \"attachments\" (Json.Decode.list Json.Decode.string)))))))))) |>" - , " Json.Decode.andThen (\\a -> Json.Decode.map a (Json.Decode.field \"credits\" Json.Decode.int)) |>" + , " Json.Decode.andThen (\\a -> Json.Decode.map a (Json.Decode.maybe (Json.Decode.field \"credits\" Json.Decode.int))) |>" , " Json.Decode.andThen (\\a -> Json.Decode.map a (Json.Decode.field \"user\" Json.Decode.string))" , "" , "" , "dashboardEncoder : Dashboard -> Json.Encode.Value" , "dashboardEncoder a =" - , " Json.Encode.object [ (\"proposals\" , Json.Encode.list (\\b -> Json.Encode.object [ (\"key\" , Json.Encode.string b.key)" - , " , (\"value\" , (\\c -> Json.Encode.object [ (\"name\" , Json.Encode.string c.name)" - , " , (\"owner\" , Json.Encode.string c.owner)" - , " , (\"availability\" , Json.Encode.list (\\d -> Json.Encode.object [ (\"interval\" , (\\e -> Json.Encode.object [ (\"startInclusive\" , Iso8601.encode e.startInclusive)" - , " , (\"endExclusive\" , Iso8601.encode e.endExclusive) ]) d.interval)" - , " , (\"users\" , Json.Encode.list Json.Encode.string d.users) ]) c.availability)" - , " , (\"description\" , Json.Encode.string c.description)" - , " , (\"venue\" , Json.Encode.string c.venue)" - , " , (\"invites\" , Json.Encode.list inviteEncoder c.invites)" - , " , (\"created-at\" , Iso8601.encode c.created_at)" - , " , (\"attachments\" , Json.Encode.list Json.Encode.string c.attachments) ]) b.value) ]) a.proposals)" - , " , (\"credits\" , Json.Encode.int a.credits)" - , " , (\"user\" , Json.Encode.string a.user) ]" + , " Json.Encode.object (List.filterMap identity [ Just (\"proposals\" , Json.Encode.list (\\b -> Json.Encode.object (List.filterMap identity [ Just (\"key\" , Json.Encode.string b.key)" + , " , Just (\"value\" , (\\c -> Json.Encode.object (List.filterMap identity [ Just (\"name\" , Json.Encode.string c.name)" + , " , Just (\"owner\" , Json.Encode.string c.owner)" + , " , Just (\"availability\" , Json.Encode.list (\\d -> Json.Encode.object (List.filterMap identity [ Just (\"interval\" , (\\e -> Json.Encode.object (List.filterMap identity [ Just (\"startInclusive\" , Iso8601.encode e.startInclusive)" + , " , Just (\"endExclusive\" , Iso8601.encode e.endExclusive) ])) d.interval)" + , " , Just (\"users\" , Json.Encode.list Json.Encode.string d.users) ])) c.availability)" + , " , Just (\"description\" , Json.Encode.string c.description)" + , " , Just (\"venue\" , Json.Encode.string c.venue)" + , " , Just (\"invites\" , Json.Encode.list inviteEncoder c.invites)" + , " , Just (\"created-at\" , Iso8601.encode c.created_at)" + , " , Just (\"attachments\" , Json.Encode.list Json.Encode.string c.attachments) ])) b.value) ])) a.proposals)" + , " , Maybe.map (\\b -> (\"credits\" , Json.Encode.int b)) a.credits" + , " , Just (\"user\" , Json.Encode.string a.user) ])" , "" , "" , "inviteDecoder : Json.Decode.Decoder Invite" @@ -139,13 +140,13 @@ , "inviteEncoder a =" , " case a of" , " InviteUser b ->" - , " (\\c -> Json.Encode.object [ (\"type\" , always (Json.Encode.string \"discord-user\") c.type_)" - , " , (\"username\" , Json.Encode.string c.username) ]) b" + , " (\\c -> Json.Encode.object (List.filterMap identity [ Just (\"type\" , always (Json.Encode.string \"discord-user\") c.type_)" + , " , Just (\"username\" , Json.Encode.string c.username) ])) b" , "" , " InviteGuild b ->" - , " (\\c -> Json.Encode.object [ (\"type\" , always (Json.Encode.string \"discord-server\") c.type_)" - , " , (\"guild\" , (\\d -> Json.Encode.object [ (\"id\" , Json.Encode.string d.id)" - , " , (\"name\" , Json.Encode.string d.name) ]) c.guild) ]) b" + , " (\\c -> Json.Encode.object (List.filterMap identity [ Just (\"type\" , always (Json.Encode.string \"discord-server\") c.type_)" + , " , Just (\"guild\" , (\\d -> Json.Encode.object (List.filterMap identity [ Just (\"id\" , Json.Encode.string d.id)" + , " , Just (\"name\" , Json.Encode.string d.name) ])) c.guild) ])) b" , "" , "" , "type Invite " @@ -165,7 +166,7 @@ , " , invites : List Invite" , " , created_at : Time.Posix" , " , attachments : List String } }" - , " , credits : Int" + , " , credits : Maybe Int" , " , user : String }" ] ) @@ -196,7 +197,7 @@ $ elmDefs (Proxy @NullableSpec) expected :: HashMap Module Text - expected = + expected = HM.singleton ["Api", "Data"] ( Text.unlines @@ -225,13 +226,68 @@ ] ) in do - TIO.hPutStrLn stderr "==========================================\n\n" - TIO.hPutStrLn stderr (fromMaybe "" (HM.lookup ["Api", "Data"] actual)) - TIO.hPutStrLn stderr "\n\n==========================================\n\n" actual `shouldBe` expected compileElm actual + it "works with optionality" $ + let + actual :: HashMap Module Text + actual = + fmap ((<> "\n") . renderStrict . layoutPretty defaultLayoutOptions) + . modules + . Set.toList + $ elmDefs (Proxy @( + JsonLet + '[ '("TestObj", JsonObject '[ + Optional "foo" JsonInt, + Optional "bar" (JsonNullable JsonInt), + Required "baz" JsonInt, + Required "qux" (JsonNullable JsonInt) + ]) + ] + (JsonRef "TestObj") + )) + expected :: HashMap Module Text + expected = + HM.singleton + ["Api", "Data"] + ( Text.unlines + [ "module Api.Data exposing" + , " ( testObjDecoder" + , " , testObjEncoder" + , " , TestObj" + , " )" + , "" + , "import Json.Decode" + , "import Json.Encode" + , "" + , "" + , "testObjDecoder : Json.Decode.Decoder TestObj" + , "testObjDecoder =" + , " Json.Decode.succeed (\\a b c d -> { foo = a, bar = b, baz = c, qux = d }) |>" + , " Json.Decode.andThen (\\a -> Json.Decode.map a (Json.Decode.maybe (Json.Decode.field \"foo\" Json.Decode.int))) |>" + , " Json.Decode.andThen (\\a -> Json.Decode.map a (Json.Decode.maybe (Json.Decode.field \"bar\" (Json.Decode.nullable Json.Decode.int)))) |>" + , " Json.Decode.andThen (\\a -> Json.Decode.map a (Json.Decode.field \"baz\" Json.Decode.int)) |>" + , " Json.Decode.andThen (\\a -> Json.Decode.map a (Json.Decode.field \"qux\" (Json.Decode.nullable Json.Decode.int)))" + , "" + , "" + , "testObjEncoder : TestObj -> Json.Encode.Value" + , "testObjEncoder a =" + , " Json.Encode.object (List.filterMap identity [ Maybe.map (\\b -> (\"foo\" , Json.Encode.int b)) a.foo" + , " , Maybe.map (\\b -> (\"bar\" , (\\c -> Maybe.withDefault Json.Encode.null (Maybe.map Json.Encode.int c)) b)) a.bar" + , " , Just (\"baz\" , Json.Encode.int a.baz)" + , " , Just (\"qux\" , (\\b -> Maybe.withDefault Json.Encode.null (Maybe.map Json.Encode.int b)) a.qux) ])" + , "" + , "" + , "type alias TestObj =" + , " { foo : Maybe Int, bar : Maybe (Maybe Int), baz : Int, qux : Maybe Int }" + ] + ) + in do + actual `shouldBe` expected + compileElm actual + compileElm :: HashMap Module Text -> IO () compileElm code = do traverse_ writeModule (HM.toList code) @@ -261,105 +317,98 @@ JsonLet '[ '("Dashboard", JsonObject '[ - '("proposals", JsonArray ( + Required "proposals" (JsonArray ( JsonObject '[ - '("key", JsonString), - '("value", JsonObject '[ - '("name", JsonString), - '("owner", JsonString), - '("availability", JsonArray ( + Required "key" JsonString, + Required "value" (JsonObject '[ + Required "name" JsonString, + Required "owner" JsonString, + Required "availability" (JsonArray ( JsonObject '[ - '("interval", JsonObject '[ - '("startInclusive", JsonDateTime), - '("endExclusive", JsonDateTime) + Required "interval" (JsonObject '[ + Required "startInclusive" JsonDateTime, + Required "endExclusive" JsonDateTime ]), - '("users", JsonArray JsonString) + Required "users" (JsonArray JsonString) ] )), - '("description", JsonString), - '("venue", JsonString), - '("invites", ( + Required "description" JsonString, + Required "venue" JsonString, + Required "invites" ( JsonLet '[ '("Invite", JsonEither (Named "InviteUser" (JsonObject '[ - '("type", JsonTag "discord-user"), - '("username", JsonString) + Required "type" (JsonTag "discord-user"), + Required "username" JsonString ])) (Named "InviteGuild" (JsonObject '[ - '("type", JsonTag "discord-server"), - '("guild", JsonObject '[ - '("id", JsonString), - '("name", JsonString) + Required "type" (JsonTag "discord-server"), + Required "guild" (JsonObject '[ + Required "id" JsonString, + Required "name" JsonString ]) ])) ) ] - (JsonArray (JsonRef "Invite")))), - '("created-at", JsonDateTime), - '("attachments", JsonArray JsonString) + (JsonArray (JsonRef "Invite")) + ), + Required "created-at" JsonDateTime, + Required "attachments" (JsonArray JsonString) ]) ] )), - '("credits", JsonInt), - '("user", JsonString) + Optional "credits" JsonInt, + Required "user" JsonString ]) ] ( JsonRef "Dashboard") type ExampleSpec = Named "ExampleType" - ( JsonObject - '[ '("stringField", JsonString) - , '( "anonymousObject" - , JsonObject - '[ '("floatField", JsonNum) - , '("dateField", JsonDateTime) - , '( "sumType1" - , Named "SumTypeWithCustomConstructorNames" - ( JsonEither - ( JsonEither - (Named "IntConstructor" JsonInt) - (Named "StringConstructor" JsonString) - ) - (Named "FloatConstructor" JsonNum) - ) - ) - , '( "sumType2" - , Named "SumTypeWithAutomaticConstructorNames" - ( JsonEither - ( JsonEither - JsonInt - JsonString - ) - JsonNum - ) - ) - ] - ) - , '( "namedObject" - , Named "NamedElmRecord" - ( JsonObject - '[ '("stringField", JsonString) - , '( "listOfStrings" - , JsonArray JsonString - ) - ] + ( JsonObject '[ + Required "stringField" JsonString, + Required "anonymousObject" (JsonObject '[ + Required "floatField" JsonNum, + Required "dateField" JsonDateTime, + Required "sumType1" ( + Named "SumTypeWithCustomConstructorNames" ( + JsonEither + ( + JsonEither + (Named "IntConstructor" JsonInt) + (Named "StringConstructor" JsonString) ) + (Named "FloatConstructor" JsonNum) ) - , '( "newtypedObject" - , Named "NewtypedElmRecord" - ( Named "Cons" - ( JsonObject - '[ '("stringField", JsonString) - , '( "listOfStrings" - , JsonArray JsonString - ) - ] - ) - ) + ), + Required "sumType2" ( + Named "SumTypeWithAutomaticConstructorNames" ( + JsonEither + ( JsonEither JsonInt JsonString) + JsonNum ) - ] + ) + ]), + Required "namedObject" ( + Named "NamedElmRecord" ( + JsonObject '[ + Required "stringField" JsonString, + Required "listOfStrings" (JsonArray JsonString) + ] + ) + ), + Required "newtypedObject" ( + Named "NewtypedElmRecord" ( + Named "Cons" ( + JsonObject '[ + Required "stringField" JsonString, + Required "listOfStrings" (JsonArray JsonString) + ] + ) + ) + ) + ] )