json-spec-elm 0.3.0.4 → 0.4.0.0

raw patch · 3 files changed

+240/−137 lines, 3 filesdep ~json-specPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: json-spec

API changes (from Hackage documentation)

Files

• json-spec-elm.cabal +13/−11
• src/Data/JsonSpec/Elm.hs +80/−28
• test/test.hs +147/−98

@@ -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 

@@ -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

@@ -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)+              ]+            )+          )+        )+      ]     )