json-spec-elm 0.1.0.1 → 0.2.0.0

raw patch · 4 files changed

+489/−200 lines, 4 filesdep +directorydep +processPVP ok

version bump matches the API change (PVP)

Dependencies added: directory, process

API changes (from Hackage documentation)

Files

• README.md +232/−0
• json-spec-elm.cabal +4/−2
• src/Data/JsonSpec/Elm.hs +148/−183
• test/test.hs +105/−15

@@ -5,3 +5,235 @@  See `/test/test.hs` for an example. +# Example++First let's define an example spec.++A couple of things to note:++1. Only things that are named using `JsonLet` will get elm types. (Also+   note, `Named` is just an alias for `JsonLet`.) So you will probably+   want to name the top-level of your spec at least.+2. `JsonEither` spec types _must_ be named. Elm can support anonymous+   record types but not anonymous sum types, so there is no way to embed+   an anonymous `JsonEither`. You have to give it a name.+3. Naming the constructors for sum types is a little tricky. If a branch+   of `JsonEither` is given a name (using `Named`), then we interpret+   the name as the name of the data constructor, not the name of the+   type contained within the branch.  To name both the data constructor+   and the type, you must use nested `Named`s.++```+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+                        )+                     ]+                )+            )+         ]+    )+```++This spec will produce the following code (after running it through+`elm-format`):++```+module Api.Data exposing+  ( ExampleType+  , NamedElmRecord+  , SumTypeWithAutomaticConstructorNames(..)+  , SumTypeWithCustomConstructorNames(..)+  , exampleTypeDecoder+  , exampleTypeEncoder+  , namedElmRecordDecoder+  , namedElmRecordEncoder+  , sumTypeWithAutomaticConstructorNamesDecoder+  , sumTypeWithAutomaticConstructorNamesEncoder+  , sumTypeWithCustomConstructorNamesDecoder+  , sumTypeWithCustomConstructorNamesEncoder+  )++import Iso8601+import Json.Decode+import Json.Encode+import Time+++exampleTypeDecoder : Json.Decode.Decoder ExampleType+exampleTypeDecoder =+  Json.Decode.succeed+    (\a b c ->+      { stringField = a+      , anonymousObject = b+      , namedObject = c+      }+    )+    |> Json.Decode.andThen (\a -> Json.Decode.map a Json.Decode.string)+    |> Json.Decode.andThen+        (\a ->+          Json.Decode.map a+            (Json.Decode.succeed+              (\b c d e ->+                { floatField = b+                , dateField = c+                , sumType1 = d+                , sumType2 = e+                }+              )+              |> Json.Decode.andThen (\b -> Json.Decode.map b Json.Decode.float)+              |> Json.Decode.andThen (\b -> Json.Decode.map b Iso8601.decoder)+              |> Json.Decode.andThen (\b -> Json.Decode.map b sumTypeWithCustomConstructorNamesDecoder)+              |> Json.Decode.andThen (\b -> Json.Decode.map b sumTypeWithAutomaticConstructorNamesDecoder)+            )+        )+    |> Json.Decode.andThen (\a -> Json.Decode.map a namedElmRecordDecoder)+++exampleTypeEncoder : ExampleType -> Json.Encode.Value+exampleTypeEncoder a =+  Json.Encode.object+    [ ( "stringField", Json.Encode.string a.stringField )+    , ( "anonymousObject"+      , (\b ->+          Json.Encode.object+            [ ( "floatField", Json.Encode.float b.floatField )+            , ( "dateField", Iso8601.encode b.dateField )+            , ( "sumType1", sumTypeWithCustomConstructorNamesEncoder b.sumType1 )+            , ( "sumType2", sumTypeWithAutomaticConstructorNamesEncoder b.sumType2 )+            ]+        )+          a.anonymousObject+      )+    , ( "namedObject", namedElmRecordEncoder a.namedObject )+    ]+++namedElmRecordDecoder : Json.Decode.Decoder NamedElmRecord+namedElmRecordDecoder =+  Json.Decode.succeed (\a b -> { stringField = a, listOfStrings = b })+    |> Json.Decode.andThen (\a -> Json.Decode.map a Json.Decode.string)+    |> Json.Decode.andThen (\a -> Json.Decode.map a (Json.Decode.list Json.Decode.string))+++namedElmRecordEncoder : NamedElmRecord -> Json.Encode.Value+namedElmRecordEncoder a =+  Json.Encode.object+    [ ( "stringField", Json.Encode.string a.stringField )+    , ( "listOfStrings", Json.Encode.list Json.Encode.string a.listOfStrings )+    ]+++sumTypeWithAutomaticConstructorNamesDecoder : Json.Decode.Decoder SumTypeWithAutomaticConstructorNames+sumTypeWithAutomaticConstructorNamesDecoder =+  Json.Decode.oneOf+    [ Json.Decode.map SumTypeWithAutomaticConstructorNames_1 Json.Decode.int+    , Json.Decode.map SumTypeWithAutomaticConstructorNames_2 Json.Decode.string+    , Json.Decode.map SumTypeWithAutomaticConstructorNames_3 Json.Decode.float+    ]+++sumTypeWithAutomaticConstructorNamesEncoder : SumTypeWithAutomaticConstructorNames -> Json.Encode.Value+sumTypeWithAutomaticConstructorNamesEncoder a =+  case a of+    SumTypeWithAutomaticConstructorNames_1 b ->+      Json.Encode.int b++    SumTypeWithAutomaticConstructorNames_2 b ->+      Json.Encode.string b++    SumTypeWithAutomaticConstructorNames_3 b ->+      Json.Encode.float b+++sumTypeWithCustomConstructorNamesDecoder : Json.Decode.Decoder SumTypeWithCustomConstructorNames+sumTypeWithCustomConstructorNamesDecoder =+  Json.Decode.oneOf+    [ Json.Decode.map IntConstructor Json.Decode.int+    , Json.Decode.map StringConstructor Json.Decode.string+    , Json.Decode.map FloatConstructor Json.Decode.float+    ]+++sumTypeWithCustomConstructorNamesEncoder : SumTypeWithCustomConstructorNames -> Json.Encode.Value+sumTypeWithCustomConstructorNamesEncoder a =+  case a of+    IntConstructor b ->+      Json.Encode.int b++    StringConstructor b ->+      Json.Encode.string b++    FloatConstructor b ->+      Json.Encode.float b+++type SumTypeWithAutomaticConstructorNames+  = SumTypeWithAutomaticConstructorNames_1 Int+  | SumTypeWithAutomaticConstructorNames_2 String+  | SumTypeWithAutomaticConstructorNames_3 Float+++type SumTypeWithCustomConstructorNames+  = IntConstructor Int+  | StringConstructor String+  | FloatConstructor Float+++type alias ExampleType =+  { stringField : String+  , anonymousObject :+      { floatField : Float+      , dateField : Time.Posix+      , sumType1 : SumTypeWithCustomConstructorNames+      , sumType2 : SumTypeWithAutomaticConstructorNames+      }+  , namedObject : NamedElmRecord+  }+++type alias NamedElmRecord =+  { stringField : String, listOfStrings : List String }+```++## Generating code++The main function exposed by this module is `elmDefs`, which returns+a `Set Definition` (where `Definition` is from the `elm-syntax`+package). For examples on how to transform a `Definition` into some+files on disk, see `/test/test.hs`.++

@@ -1,6 +1,6 @@ cabal-version:       3.0 name:                json-spec-elm-version:             0.1.0.1+version:             0.2.0.0 synopsis:            Elm code generate for `json-spec`. description:                               Produce elm types, encoders, and decoders from a@@ -56,5 +56,7 @@   default-language: Haskell2010   build-depends:     , json-spec-elm-    , hspec >= 2.11.1 && < 2.12+    , directory >= 1.3.7.1  && < 1.4+    , hspec     >= 2.11.1   && < 2.12+    , process   >= 1.6.16.0 && < 1.7 

@@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-}@@ -15,10 +16,11 @@   elmDefs,   Definitions,   HasType(..),+  Named, ) where  -import Bound (Scope(Scope), Var(B, F), toScope)+import Bound (Scope(Scope), Var(B), abstract1, closed, toScope) import Control.Monad.Writer (MonadWriter(tell), Writer, execWriter) import Data.JsonSpec (Specification(JsonArray, JsonBool, JsonDateTime,   JsonEither, JsonInt, JsonLet, JsonNullable, JsonNum, JsonObject,@@ -31,12 +33,12 @@ import GHC.TypeLits (ErrorMessage((:$$:), (:<>:)), KnownSymbol, Symbol,   TypeError, symbolVal) import Language.Elm.Definition (Definition)-import Language.Elm.Expression ((|>), Expression, bind, if_)+import Language.Elm.Expression ((|>), Expression, if_) import Language.Elm.Name (Constructor, Qualified) import Language.Elm.Type (Type)-import Prelude (Applicative(pure), Foldable(foldl), Functor(fmap),+import Prelude (Applicative(pure), Foldable(foldl, foldr), Functor(fmap),   Maybe(Just, Nothing), Monad((>>)), Semigroup((<>)), Show(show), ($),-  (++), (.), (<$>), Int, error, reverse, zip)+  (++), (.), (<$>), Int, error, fst, snd, zip) import qualified Data.Char as Char import qualified Data.Set as Set import qualified Data.Text as Text@@ -59,9 +61,11 @@ class Record (spec :: [(Symbol, Specification)]) where   recordDefs :: forall v. Definitions [(Name.Field, Type v)]   recordEncoders :: Definitions [(Text, Name.Field, Expression Void)]+  recordDecoders :: Definitions [(Text, Expression Void)] instance Record '[] where   recordDefs = pure []   recordEncoders = pure []+  recordDecoders = pure [] instance     ( HasType spec     , KnownSymbol name@@ -73,11 +77,15 @@     recordDefs = do       type_ <- typeOf @spec       moreFields <- recordDefs @more-      pure $ (fieldName @name, type_) : moreFields+      pure $ (fieldName (sym @name), type_) : moreFields     recordEncoders = do       encoder <- encoderOf @spec       moreFields <- recordEncoders @more-      pure $ (sym @name, fieldName @name, encoder) : moreFields+      pure $ (sym @name, fieldName (sym @name), encoder) : moreFields+    recordDecoders = do+      dec <- decoderOf @spec+      more <- recordDecoders @more+      pure $ ( sym @name , dec) : more   class HasType (spec :: Specification) where@@ -96,65 +104,47 @@   typeOf = pure "Basics.Int"   decoderOf = pure "Json.Decode.int"   encoderOf = pure "Json.Encode.int"-instance {- HasType (JsonObject fields) -}-    ( Record fields-    , BaseFields (Reverse fields)-    , Lambda (LambdaDepth (Reverse fields))-    , Decoders fields-    )-  =>-    HasType (JsonObject fields)-  where-    typeOf = Type.Record <$> recordDefs @fields-    decoderOf = do-        decoders <- fieldDecoders @fields-        pure $-          foldl-            (\expr (_, decoder) ->-              expr |> ("Json.Decode.andThen" `Expr.App`-                Expr.Lam (toScope (-                  "Json.Decode.map"-                    `Expr.App` Expr.Var (B ())-                    `Expr.App` bind Expr.Global absurd decoder-                ))-              )+instance (Record fields) => HasType (JsonObject fields) where+  typeOf = Type.Record <$> recordDefs @fields+  decoderOf = do+    decoders <- recordDecoders @fields+    pure $+      foldl+        (\expr decoder ->+          expr |>+            (+              "Json.Decode.andThen" `a`+                lam (\var -> "Json.Decode.map" `a` var `a` (absurd <$> decoder))             )-            ("Json.Decode.succeed" `Expr.App` lambda)-            decoders-      where-        lambda =-          lam . Expr.Record . reverse $-            [ (name, var)-            | (name, var) <- baseFields @(Reverse fields)-            ]-    encoderOf = do-        fields <- recordEncoders @fields-        pure $-          Expr.Lam . toScope $-            "Json.Encode.object"-            `Expr.App`+        )+        ("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 `Expr.App`-                  (Expr.Proj elmField `Expr.App` Expr.Var var)+                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 ()-+    where+      var :: Bound.Var () a+      var = B () instance (HasType spec) => HasType (JsonArray spec) where   typeOf = do     elemType <- typeOf @spec-    pure $ Type.App "Basics.List" elemType+    pure $ "Basics.List" `ta` elemType   decoderOf = do     dec <- decoderOf @spec-    pure $ Expr.App "Json.Decode.list" dec+    pure $ "Json.Decode.list" `a` dec   encoderOf = do     encoder <- encoderOf @spec-    pure $ "Json.Encode.list" `Expr.App` encoder+    pure $ "Json.Encode.list" `a` encoder instance HasType JsonBool where   typeOf = pure "Basics.Bool"   decoderOf = pure "Json.Decode.bool"@@ -163,10 +153,10 @@ instance (HasType spec) => HasType (JsonNullable spec) where   typeOf = do     type_ <- typeOf @spec-    pure $ Type.App "Maybe.Maybe" type_+    pure $ "Maybe.Maybe" `ta` type_   decoderOf = do     dec <- decoderOf @spec-    pure $ Expr.App "Json.Decode.nullable" dec+    pure $ a "Json.Decode.nullable" dec   encoderOf = do     encoder <- encoderOf @spec     pure $@@ -195,13 +185,13 @@                     , Expr.String (sym @const)                     ]                 )-                (Expr.App "Json.Decode.succeed" "Basics.()")-                (Expr.App "Json.Decode.fail" (Expr.String "Tag mismatch"))+                (a "Json.Decode.succeed" "Basics.()")+                (a "Json.Decode.fail" (Expr.String "Tag mismatch"))           ]   encoderOf =     pure $-      "Basics.always" `Expr.App`-        ("Json.Encode.string" `Expr.App` Expr.String (sym @const))+      "Basics.always" `a`+        ("Json.Encode.string" `a` Expr.String (sym @const)) instance HasType JsonDateTime where   typeOf = pure "Time.Posix"   decoderOf = pure "Iso8601.decoder"@@ -221,7 +211,7 @@   decoderOf = decoderOf @spec   encoderOf = encoderOf @spec instance {- HasType (JsonLet ( def : more ) spec) -}-    ( ElmDef def+    ( HasDef def     , HasType (JsonLet more spec)     )   =>@@ -282,32 +272,6 @@     Bound.Var () (LambdaDepth more)  -class Lambda depth where-  lam :: Expression depth -> Expression Void-instance {-# OVERLAPS #-} Lambda (Bound.Var () Void) where-  lam e = Expr.Lam (toScope e)-instance (Lambda deeper) => Lambda (Bound.Var () deeper) where-  lam e = lam (Expr.Lam (toScope e))---class BaseFields (record :: [(Symbol, Specification)]) where-  baseFields :: [(Name.Field, Expression (LambdaDepth record))]-instance BaseFields '[] where-  baseFields = []-instance {- BaseFields ('(name, spec) : more) -}-    (BaseFields more, KnownSymbol name)-  =>-    BaseFields ('(name, spec) : more)-  where-    baseFields =-        (fieldName @name, Expr.Var (B ())) :-        [ (name, b var)-        | (name, var) <- baseFields @more-        ]-      where-        b = bind Expr.Global (Expr.Var . F)-- type family Reverse (l :: [k]) where   Reverse '[] = '[]   Reverse (a : more) = Concat (Reverse more) '[a]@@ -319,39 +283,24 @@     a : Concat more b  -class Decoders (spec :: [(Symbol, Specification)]) where-  fieldDecoders :: Definitions [(Text, Expression Void)]-instance Decoders '[] where-  fieldDecoders = pure []-instance {- Decoders ('(name, spec) : more) -}-    (HasType spec, Decoders more, KnownSymbol name)-  =>-    Decoders ('(name, spec) : more)-  where-    fieldDecoders = do-      dec <- decoderOf @spec-      more <- fieldDecoders @more-      pure $ ( sym @name , dec) : more---class ElmDef (def :: (Symbol, Specification)) where+class HasDef (def :: (Symbol, Specification)) where   defs :: Definitions ()-instance {-# OVERLAPS #-}+instance {-# OVERLAPS #-} {- HasDef '(name, JsonEither left right) -}     ( KnownSymbol name     , SumDef (JsonEither left right)     )   =>-    ElmDef '(name, JsonEither left right)+    HasDef '(name, JsonEither left right)   where     defs = do         branches <- sumDef @(JsonEither left right)         let           constructors :: [(Constructor, [Scope Int Type Void])]           constructors =-            [ ( Name.Constructor (constructorName n)+            [ ( Name.Constructor (constructorName conName n)               , [Scope type_]               )-            | (n, type_) <- zip [(1 :: Int) ..] branches+            | (n, (conName, type_)) <- zip [1..] branches             ]         decoders <- sumDecoders @(JsonEither left right)         encoders <- sumEncoders @(JsonEither left right)@@ -360,20 +309,15 @@           , Def.Constant               (decoderName @name)               0-              ( Scope-                  ( "Json.Decode.Decoder"-                    `Type.App`-                    Type.Global (localName name)-                  )-              )+              (Scope ("Json.Decode.Decoder" `ta` Type.Global (localName name)))               (                 "Json.Decode.oneOf"-                `Expr.App`+                `a`                 Expr.List                   [ "Json.Decode.map"-                    `Expr.App` Expr.Global (localName (constructorName n))-                    `Expr.App` dec-                  | (n, dec) <-  zip [(1 :: Int) ..] decoders+                    `a` Expr.Global (localName (constructorName conName n))+                    `a` dec+                  | (n, (conName, dec)) <-  zip [1..] decoders                   ]               )           , Def.Constant@@ -389,22 +333,24 @@                 Expr.Lam . toScope $                   Expr.Case                     (Expr.Var (B ()))-                    [ ( Pat.Con (localName (constructorName n)) [Pat.Var 0]+                    [ ( Pat.Con (localName (constructorName conName n)) [Pat.Var 0]                       , toScope $-                        fmap absurd encoder `Expr.App`+                        fmap absurd encoder `a`                           Expr.Var (B (0 :: Int))                       )-                    | (n, encoder) <- zip [1..] encoders+                    | (n, (conName, encoder)) <- zip [1..] encoders                     ]               )           ]       where-        constructorName :: Int -> Text-        constructorName n = name <> "_" <> showt n+        constructorName :: Maybe Text -> Int -> Text+        constructorName = \cases+          Nothing n -> name <> "_" <> showt n+          (Just consName) _ -> consName          name :: Text         name = sym @name-instance (HasType spec, KnownSymbol name) => ElmDef '(name, spec) where+instance (HasType spec, KnownSymbol name) => HasDef '(name, spec) where   defs = do     type_ <- typeOf @spec     dec <- decoderOf @spec@@ -418,9 +364,9 @@           (decoderName @name)           0           ( Scope-              ( Type.App-                  "Json.Decode.Decoder"-                  (Type.Global $ localName (sym @name))+              (+                "Json.Decode.Decoder" `ta`+                  Type.Global (localName (sym @name))               )           )           dec@@ -438,77 +384,52 @@   class SumDef (spec :: Specification) where-  sumDef :: forall v. Definitions [Type v]-  sumDecoders :: Definitions [Expression Void]-  sumEncoders :: Definitions [Expression Void]-instance {-# OVERLAPS #-}-    (SumDef (JsonEither a b), SumDef (JsonEither c d))+  sumDef :: forall v. Definitions [(Maybe Text, Type v)]+  sumDecoders :: Definitions [(Maybe Text, Expression Void)]+  sumEncoders :: Definitions [(Maybe Text, Expression Void)]+instance+    (SumDef left, SumDef right)   =>-    SumDef (JsonEither (JsonEither a b) (JsonEither c d))+    SumDef (JsonEither left right)   where     sumDef = do-      left <- sumDef @(JsonEither a b)-      right <- sumDef @(JsonEither c d)+      left <- sumDef @left+      right <- sumDef @right       pure $ left ++ right     sumDecoders = do-      left <- sumDecoders @(JsonEither a b)-      right <- sumDecoders @(JsonEither c d)+      left <- sumDecoders @left+      right <- sumDecoders @right       pure (left ++ right)     sumEncoders = do-      left <- sumEncoders @(JsonEither a b)-      right <- sumEncoders @(JsonEither c d)+      left <- sumEncoders @left+      right <- sumEncoders @right       pure (left ++ right)-instance {-# OVERLAPS #-}-    (SumDef (JsonEither a b), HasType right)-  =>-    SumDef (JsonEither (JsonEither a b) right)-  where-    sumDef = do-      left <- sumDef @(JsonEither a b)-      right <- typeOf @right-      pure $ left ++ [right]-    sumDecoders = do-      left <- sumDecoders @(JsonEither a b)-      right <- decoderOf @right-      pure $ left ++ [right]-    sumEncoders = do-      left <- sumEncoders @(JsonEither a b)-      right <- encoderOf @right-      pure $ left ++ [right]-instance {-# OVERLAPS #-}-    (SumDef (JsonEither c d), HasType left)-  =>-    SumDef (JsonEither left (JsonEither c d))-  where-    sumDef = do-      left <- typeOf @left-      right <- sumDef @(JsonEither c d)-      pure $ left : right-    sumDecoders = do-      left <- decoderOf @left-      right <- sumDecoders @(JsonEither c d)-      pure $ left : right-    sumEncoders = do-      left <- encoderOf @left-      right <- sumEncoders @(JsonEither c d)-      pure $ left : right instance-    (HasType left, HasType right)+    ( HasType def+    , KnownSymbol name+    )   =>-    SumDef (JsonEither left right)+    SumDef (JsonLet '[ '(name, def) ] (JsonRef name))   where     sumDef = do-      left <- typeOf @left-      right <- typeOf @right-      pure [left, right]+      typ <- typeOf @def+      pure [(Just (sym @name), typ)]     sumDecoders = do-      left <- decoderOf @left-      right <- decoderOf @right-      pure [left, right]+      dec <- decoderOf @def+      pure [(Just (sym @name), dec)]     sumEncoders = do-      left <- encoderOf @left-      right <- encoderOf @right-      pure [left, right]+      enc <- encoderOf @def+      pure [(Just (sym @name), enc)]+instance {-# overlaps #-} (HasType a) => SumDef a where+  sumDef = do+    typ <- typeOf @a+    pure [(Nothing, typ)]+  sumDecoders = do+    dec <- decoderOf @a+    pure [(Nothing, dec)]+  sumEncoders = do+    enc <- encoderOf @a+    pure [(Nothing, enc)]   localName :: Text -> Qualified@@ -541,11 +462,55 @@ encoderName = localName (lower (sym @name) <> "Encoder")  -fieldName :: forall name. (KnownSymbol name) => Name.Field-fieldName =+fieldName :: Text -> Name.Field+fieldName specName =   Name.Field $-    case sym @name of+    case specName of       "type" -> "type_"       other -> Text.replace "-" "_" other+++a :: Expression v -> Expression v -> Expression v+a = Expr.App+++ta :: Type v -> Type v -> Type v+ta = Type.App+++recordConstructor :: [Text] -> Expression v+recordConstructor records =+    case+      closed $+        foldr+          (\field expr ->+            Expr.Lam $ abstract1 field expr+          )+          unboundRecord+          records+    of+      Nothing -> error "can't happen"+      Just expr -> expr+  where+    unboundRecord :: Expression Text+    unboundRecord =+      Expr.Record+        [ (fieldName field, Expr.Var field)+        | field <- records+        ]+++lam+  :: (Expression (Var () a) -> Expression (Var () v))+  -> Expression v+lam f =+  Expr.Lam . toScope $ f (Expr.Var (B ()))+++{-|+  Helper for giving a specification a name. This is especially useful for+  making sure sum type data constructors have meaningful names.+-}+type Named name def = JsonLet '[ '(name, def) ] (JsonRef name)  

@@ -4,19 +4,23 @@  module Main (main) where +import Data.Foldable (traverse_) import Data.HashMap.Strict (HashMap) import Data.JsonSpec (Specification(JsonArray, JsonDateTime, JsonEither,-  JsonInt, JsonLet, JsonObject, JsonRef, JsonString, JsonTag))-import Data.JsonSpec.Elm (elmDefs)+  JsonInt, JsonLet, JsonNum, JsonObject, JsonRef, JsonString, JsonTag))+import Data.JsonSpec.Elm (Named, elmDefs) import Data.Maybe (fromMaybe) import Data.Proxy (Proxy(Proxy)) import Data.Text (Text) import Language.Elm.Name (Module) import Language.Elm.Pretty (modules)-import Prelude (Functor(fmap), Semigroup((<>)), ($), (.), IO)+import Prelude (Bool(True), Functor(fmap), Semigroup((<>)), ($), (.),+  FilePath, IO, init) import Prettyprinter (defaultLayoutOptions, layoutPretty) import Prettyprinter.Render.Text (renderStrict)+import System.Directory (createDirectoryIfMissing) import System.IO (stderr)+import System.Process (callCommand) import Test.Hspec (describe, hspec, it, shouldBe) import qualified Data.HashMap.Strict as HM import qualified Data.Set as Set@@ -26,8 +30,8 @@ main :: IO () main =   hspec $ do-    describe "thing" $ do-      it "works" $+    describe "Code generation" $ do+      it "works with a complicated schema" $         let           actual :: HashMap Module Text           actual =@@ -107,7 +111,7 @@                   , ""                   , "inviteDecoder : Json.Decode.Decoder Invite"                   , "inviteDecoder ="-                  , "    Json.Decode.oneOf [ Json.Decode.map Invite_1 (Json.Decode.succeed (\\a b -> { type_ = a"+                  , "    Json.Decode.oneOf [ Json.Decode.map InviteUser (Json.Decode.succeed (\\a b -> { type_ = a"                   , "    , username = b }) |>"                   , "    Json.Decode.andThen (\\a -> Json.Decode.map a (Json.Decode.string |>"                   , "    Json.Decode.andThen (\\b -> if b == \"discord-user\" then"@@ -116,7 +120,7 @@                   , "    else"                   , "        Json.Decode.fail \"Tag mismatch\"))) |>"                   , "    Json.Decode.andThen (\\a -> Json.Decode.map a Json.Decode.string))"-                  , "    , Json.Decode.map Invite_2 (Json.Decode.succeed (\\a b -> { type_ = a"+                  , "    , Json.Decode.map InviteGuild (Json.Decode.succeed (\\a b -> { type_ = a"                   , "    , guild = b }) |>"                   , "    Json.Decode.andThen (\\a -> Json.Decode.map a (Json.Decode.string |>"                   , "    Json.Decode.andThen (\\b -> if b == \"discord-server\" then"@@ -133,19 +137,19 @@                   , "inviteEncoder : Invite -> Json.Encode.Value"                   , "inviteEncoder a ="                   , "    case a of"-                  , "        Invite_1 b ->"+                  , "        InviteUser b ->"                   , "            (\\c -> Json.Encode.object [ (\"type\" , always (Json.Encode.string \"discord-user\") c.type_)"                   , "            , (\"username\" , Json.Encode.string c.username) ]) b"                   , ""-                  , "        Invite_2 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"                   , ""                   , ""                   , "type Invite "-                  , "    = Invite_1 { type_ : (), username : String }"-                  , "    | Invite_2 { type_ : (), guild : { id : String, name : String } }"+                  , "    = InviteUser { type_ : (), username : String }"+                  , "    | InviteGuild { type_ : (), guild : { id : String, name : String } }"                   , ""                   , ""                   , "type alias Dashboard  ="@@ -169,8 +173,34 @@           TIO.hPutStrLn stderr (fromMaybe "" (HM.lookup ["Api", "Data"] actual))           TIO.hPutStrLn stderr "\n\n==========================================\n\n"           actual `shouldBe` expected+      it "works with the example schema" $+        let+          actual :: HashMap Module Text+          actual =+            fmap ((<> "\n") . renderStrict . layoutPretty defaultLayoutOptions)+            . modules+            . Set.toList+            $ elmDefs (Proxy @ExampleSpec) +        in do+          traverse_ writeModule (HM.toList actual)+          callCommand "(cd elm-test; elm-format src/ --yes)"+          callCommand+            "(\+              \cd elm-test; \+              \yes Y | (\+                \elm init; \+                \elm install rtfeldman/elm-iso8601-date-strings; \+                \elm install elm/json; \+                \elm install elm/url; \+                \elm install elm/time; \+                \elm install elm/http\+              \); \+              \elm make src/Api/Data.elm\+            \)"+          callCommand "rm -rf elm-test" + {-   This spec is copied from an as-yet uncompleted personal project. I   just used it because it is fairly complex. Probably something known@@ -201,17 +231,17 @@                 JsonLet '[                   '("Invite",                     JsonEither-                      (JsonObject '[+                      (Named "InviteUser" (JsonObject '[                         '("type", JsonTag "discord-user"),                         '("username", JsonString)-                      ])-                      (JsonObject '[+                      ]))+                      (Named "InviteGuild" (JsonObject '[                         '("type", JsonTag "discord-server"),                         '("guild", JsonObject '[                           '("id", JsonString),                           '("name", JsonString)                          ])-                      ])+                      ]))                   )                 ]                 (JsonArray (JsonRef "Invite")))),@@ -224,4 +254,64 @@         '("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+                        )+                     ]+                )+            )+         ]+    )+++writeModule :: (Module, Text) -> IO ()+writeModule (module_, content) = do+    createDirectoryIfMissing True dirname+    TIO.writeFile filename content+  where+    pathName :: [Text] -> FilePath+    pathName = ("elm-test/src/" <>) . Text.unpack . Text.intercalate "/"++    filename :: FilePath+    filename = pathName module_ <> ".elm"++    dirname :: FilePath+    dirname = pathName (init module_)+