json-spec-elm (empty) → 0.1.0.1
raw patch · 5 files changed
+866/−0 lines, 5 filesdep +basedep +bounddep +containers
Dependencies added: base, bound, containers, elm-syntax, hspec, json-spec, json-spec-elm, mtl, prettyprinter, text, unordered-containers
Files
- LICENSE +21/−0
- README.md +7/−0
- json-spec-elm.cabal +60/−0
- src/Data/JsonSpec/Elm.hs +551/−0
- test/test.hs +227/−0
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2023 Rick Owens++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,7 @@+# json-spec-elm++Produce elm types, encoders, and decoders from a+[`json-spec`](https://hackage.haskell.org/package/json-spec) `Specification`.++See `/test/test.hs` for an example.+
+ json-spec-elm.cabal view
@@ -0,0 +1,60 @@+cabal-version: 3.0+name: json-spec-elm+version: 0.1.0.1+synopsis: Elm code generate for `json-spec`.+description: + Produce elm types, encoders, and decoders from a+ [`json-spec`](https://hackage.haskell.org/package/json-spec) `Specification`.++ See `/test/test.hs` for an example.+homepage: https://github.com/owensmurray/json-spec-elm+license: MIT+license-file: LICENSE+author: Rick Owens+maintainer: rick@owensmurray.com+copyright: 2022 Rick Owens+category: JSON, Elm+build-type: Simple+extra-source-files:+ README.md+ LICENSE++common dependencies+ build-depends:+ , base >= 4.17 && < 4.18+ , 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.3+ , prettyprinter >= 1.7.1 && < 1.8+ , text >= 2.0.2 && < 2.1+ , unordered-containers >= 0.2.19.1 && < 0.3++common warnings+ ghc-options:+ -Wmissing-deriving-strategies+ -Wmissing-export-lists+ -Wmissing-import-lists+ -Wredundant-constraints+ -Wall++library+ import: dependencies, warnings+ exposed-modules: + Data.JsonSpec.Elm+ -- other-modules: + -- other-extensions: + hs-source-dirs: src+ default-language: Haskell2010++test-suite test+ import: dependencies, warnings+ main-is: test.hs+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ default-language: Haskell2010+ build-depends:+ , json-spec-elm+ , hspec >= 2.11.1 && < 2.12+
+ src/Data/JsonSpec/Elm.hs view
@@ -0,0 +1,551 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.JsonSpec.Elm (+ elmDefs,+ Definitions,+ HasType(..),+) where+++import Bound (Scope(Scope), Var(B, F), toScope)+import Control.Monad.Writer (MonadWriter(tell), Writer, execWriter)+import Data.JsonSpec (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))+import Data.Text (Text)+import Data.Void (Void, absurd)+import GHC.TypeLits (ErrorMessage((:$$:), (:<>:)), KnownSymbol, Symbol,+ TypeError, symbolVal)+import Language.Elm.Definition (Definition)+import Language.Elm.Expression ((|>), Expression, bind, if_)+import Language.Elm.Name (Constructor, Qualified)+import Language.Elm.Type (Type)+import Prelude (Applicative(pure), Foldable(foldl), Functor(fmap),+ Maybe(Just, Nothing), Monad((>>)), Semigroup((<>)), Show(show), ($),+ (++), (.), (<$>), Int, error, reverse, zip)+import qualified Data.Char as Char+import qualified Data.Set as Set+import qualified Data.Text as Text+import qualified GHC.TypeLits as Lits+import qualified Language.Elm.Definition as Def+import qualified Language.Elm.Expression as Expr+import qualified Language.Elm.Name as Name+import qualified Language.Elm.Pattern as Pat+import qualified Language.Elm.Type as Type+++elmDefs+ :: forall spec. (HasType spec)+ => Proxy (spec :: Specification)+ -> Set Definition+elmDefs _ =+ execWriter $ typeOf @spec >> decoderOf @spec+++class Record (spec :: [(Symbol, Specification)]) where+ recordDefs :: forall v. Definitions [(Name.Field, Type v)]+ recordEncoders :: Definitions [(Text, Name.Field, Expression Void)]+instance Record '[] where+ recordDefs = pure []+ recordEncoders = pure []+instance+ ( HasType spec+ , KnownSymbol name+ , Record more+ )+ =>+ Record ( '(name, spec) : more )+ where+ recordDefs = do+ type_ <- typeOf @spec+ moreFields <- recordDefs @more+ pure $ (fieldName @name, type_) : moreFields+ recordEncoders = do+ encoder <- encoderOf @spec+ moreFields <- recordEncoders @more+ pure $ (sym @name, fieldName @name, encoder) : moreFields+++class HasType (spec :: Specification) where+ typeOf :: forall v. Definitions (Type v)+ decoderOf :: Definitions (Expression Void)+ encoderOf :: Definitions (Expression Void)+instance HasType JsonString where+ typeOf = pure "String.String"+ decoderOf = pure "Json.Decode.string"+ encoderOf = pure "Json.Encode.string"+instance HasType JsonNum where+ typeOf = pure "Basics.Float"+ decoderOf = pure "Json.Decode.float"+ encoderOf = pure "Json.Encode.float"+instance HasType JsonInt where+ 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+ ))+ )+ )+ ("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`+ Expr.List+ [ Expr.apps "Basics.," [+ Expr.String jsonField,+ Expr.bind Expr.Global absurd encoder `Expr.App`+ (Expr.Proj elmField `Expr.App` Expr.Var var)+ ]+ | (jsonField, elmField, encoder) <- fields+ ]+ 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+ decoderOf = do+ dec <- decoderOf @spec+ pure $ Expr.App "Json.Decode.list" dec+ encoderOf = do+ encoder <- encoderOf @spec+ pure $ "Json.Encode.list" `Expr.App` encoder+instance HasType JsonBool where+ typeOf = pure "Basics.Bool"+ decoderOf = pure "Json.Decode.bool"+ encoderOf =+ pure "Json.Encode.bool"+instance (HasType spec) => HasType (JsonNullable spec) where+ typeOf = do+ type_ <- typeOf @spec+ pure $ Type.App "Maybe.Maybe" type_+ decoderOf = do+ dec <- decoderOf @spec+ pure $ Expr.App "Json.Decode.nullable" dec+ encoderOf = do+ encoder <- encoderOf @spec+ pure $+ Expr.Lam . toScope $+ Expr.apps+ "Maybe.withDefault"+ [ "Json.Decode.null"+ , Expr.apps+ "Maybe.map"+ [ Expr.bind Expr.Global absurd encoder+ , Expr.Var (B ())+ ]+ ]+instance (KnownSymbol const) => HasType (JsonTag const) where+ typeOf = pure "Basics.()"+ decoderOf =+ pure $+ "Json.Decode.string"+ |> Expr.apps "Json.Decode.andThen"+ [ Expr.Lam . toScope $+ if_+ (+ Expr.apps+ "Basics.=="+ [ Expr.Var (B ())+ , Expr.String (sym @const)+ ]+ )+ (Expr.App "Json.Decode.succeed" "Basics.()")+ (Expr.App "Json.Decode.fail" (Expr.String "Tag mismatch"))+ ]+ encoderOf =+ pure $+ "Basics.always" `Expr.App`+ ("Json.Encode.string" `Expr.App` Expr.String (sym @const))+instance HasType JsonDateTime where+ typeOf = pure "Time.Posix"+ decoderOf = pure "Iso8601.decoder"+ encoderOf = pure "Iso8601.encode"+instance (KnownSymbol name) => HasType (JsonRef name) where+ typeOf =+ pure+ . Type.Global+ . localName+ $ sym @name+ decoderOf =+ pure . Expr.Global $ decoderName @name+ encoderOf =+ pure . Expr.Global $ encoderName @name+instance (HasType spec) => HasType (JsonLet '[] spec) where+ typeOf = typeOf @spec+ decoderOf = decoderOf @spec+ encoderOf = encoderOf @spec+instance {- HasType (JsonLet ( def : more ) spec) -}+ ( ElmDef def+ , HasType (JsonLet more spec)+ )+ =>+ HasType (JsonLet ( def : more ) spec)+ where+ typeOf = do+ defs @def+ typeOf @(JsonLet more spec)+ decoderOf = do+ defs @def+ decoderOf @(JsonLet more spec)+ encoderOf = do+ defs @def+ encoderOf @(JsonLet more spec)+instance {- HasType (JsonEither left right) -}+ ( TypeError+ ( Lits.Text "Elm doesn't support anonymous sum types, so if you "+ :<>: Lits.Text "want to use (possibly nested) `JsonEither` "+ :<>: Lits.Text "you must give it a name using `JsonLet`, e.g:"+ :$$: Lits.Text ""+ :$$: Lits.Text "> JsonLet"+ :$$: Lits.Text "> '[ '( \"MySum\""+ :$$: Lits.Text "> , JsonEither"+ :$$: Lits.Text "> ( JsonEither"+ :$$: Lits.Text "> JsonInt"+ :$$: Lits.Text "> JsonString"+ :$$: Lits.Text "> )"+ :$$: Lits.Text "> ( JsonEither"+ :$$: Lits.Text "> JsonFloat"+ :$$: Lits.Text "> JsonBool"+ :$$: Lits.Text "> )"+ :$$: Lits.Text "> )"+ :$$: Lits.Text "> ]"+ :$$: Lits.Text "> (JsonRef \"MySum\")"+ :$$: Lits.Text ""+ :$$: Lits.Text "This will produce the Elm type"+ :$$: Lits.Text ""+ :$$: Lits.Text "> type MySum"+ :$$: Lits.Text "> = MySum_1 Int"+ :$$: Lits.Text "> | MySum_2 String"+ :$$: Lits.Text "> | MySum_3 Float"+ :$$: Lits.Text "> | MySum_4 Bool"+ :$$: Lits.Text ""++ )+ )+ =>+ HasType (JsonEither left right)+ where+ typeOf = error "undefinable"+ decoderOf = error "undefinable"+ encoderOf = error "undefinable"+++type family LambdaDepth (record :: [k]) where+ LambdaDepth '[] = Void+ LambdaDepth (a : more) =+ 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]+++type family Concat (a :: [k]) (b :: [k]) where+ Concat '[] b = b+ Concat (a : more) b =+ 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+ defs :: Definitions ()+instance {-# OVERLAPS #-}+ ( KnownSymbol name+ , SumDef (JsonEither left right)+ )+ =>+ ElmDef '(name, JsonEither left right)+ where+ defs = do+ branches <- sumDef @(JsonEither left right)+ let+ constructors :: [(Constructor, [Scope Int Type Void])]+ constructors =+ [ ( Name.Constructor (constructorName n)+ , [Scope type_]+ )+ | (n, type_) <- zip [(1 :: Int) ..] branches+ ]+ decoders <- sumDecoders @(JsonEither left right)+ encoders <- sumEncoders @(JsonEither left right)+ tell . Set.fromList $+ [ Def.Type (localName name) 0 constructors+ , Def.Constant+ (decoderName @name)+ 0+ ( Scope+ ( "Json.Decode.Decoder"+ `Type.App`+ Type.Global (localName name)+ )+ )+ (+ "Json.Decode.oneOf"+ `Expr.App`+ Expr.List+ [ "Json.Decode.map"+ `Expr.App` Expr.Global (localName (constructorName n))+ `Expr.App` dec+ | (n, dec) <- zip [(1 :: Int) ..] decoders+ ]+ )+ , Def.Constant+ (encoderName @name)+ 0+ (+ toScope $+ Type.Fun+ (Type.Global (localName name))+ "Json.Encode.Value"+ )+ (+ Expr.Lam . toScope $+ Expr.Case+ (Expr.Var (B ()))+ [ ( Pat.Con (localName (constructorName n)) [Pat.Var 0]+ , toScope $+ fmap absurd encoder `Expr.App`+ Expr.Var (B (0 :: Int))+ )+ | (n, encoder) <- zip [1..] encoders+ ]+ )+ ]+ where+ constructorName :: Int -> Text+ constructorName n = name <> "_" <> showt n++ name :: Text+ name = sym @name+instance (HasType spec, KnownSymbol name) => ElmDef '(name, spec) where+ defs = do+ type_ <- typeOf @spec+ dec <- decoderOf @spec+ enc <- encoderOf @spec+ tell . Set.fromList $+ [ Def.Alias+ (localName (sym @name))+ 0+ (Scope type_)+ , Def.Constant+ (decoderName @name)+ 0+ ( Scope+ ( Type.App+ "Json.Decode.Decoder"+ (Type.Global $ localName (sym @name))+ )+ )+ dec+ , Def.Constant+ (encoderName @name)+ 0+ ( Scope+ ( Type.Fun+ (Type.Global $ localName (sym @name))+ "Json.Encode.Value"+ )+ )+ enc+ ]+++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 (JsonEither (JsonEither a b) (JsonEither c d))+ where+ sumDef = do+ left <- sumDef @(JsonEither a b)+ right <- sumDef @(JsonEither c d)+ pure $ left ++ right+ sumDecoders = do+ left <- sumDecoders @(JsonEither a b)+ right <- sumDecoders @(JsonEither c d)+ pure (left ++ right)+ sumEncoders = do+ left <- sumEncoders @(JsonEither a b)+ right <- sumEncoders @(JsonEither c d)+ 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)+ =>+ SumDef (JsonEither left right)+ where+ sumDef = do+ left <- typeOf @left+ right <- typeOf @right+ pure [left, right]+ sumDecoders = do+ left <- decoderOf @left+ right <- decoderOf @right+ pure [left, right]+ sumEncoders = do+ left <- encoderOf @left+ right <- encoderOf @right+ pure [left, right]+++localName :: Text -> Qualified+localName =+ Name.Qualified ["Api", "Data"]+++type Definitions = Writer (Set Definition)+++sym :: forall a b. (KnownSymbol a, IsString b) => b+sym = fromString $ symbolVal (Proxy @a)+++showt :: (Show a, IsString b) => a -> b+showt = fromString . show+++lower :: Text -> Text+lower txt =+ case Text.uncons txt of+ Nothing -> txt+ Just (c, more) -> Text.cons (Char.toLower c) more+++decoderName :: forall name. (KnownSymbol name) => Qualified+decoderName = localName (lower (sym @name) <> "Decoder")++encoderName :: forall name. (KnownSymbol name) => Qualified+encoderName = localName (lower (sym @name) <> "Encoder")+++fieldName :: forall name. (KnownSymbol name) => Name.Field+fieldName =+ Name.Field $+ case sym @name of+ "type" -> "type_"+ other -> Text.replace "-" "_" other++
+ test/test.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Main (main) where++import Data.HashMap.Strict (HashMap)+import Data.JsonSpec (Specification(JsonArray, JsonDateTime, JsonEither,+ JsonInt, JsonLet, JsonObject, JsonRef, JsonString, JsonTag))+import Data.JsonSpec.Elm (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 Prettyprinter (defaultLayoutOptions, layoutPretty)+import Prettyprinter.Render.Text (renderStrict)+import System.IO (stderr)+import Test.Hspec (describe, hspec, it, shouldBe)+import qualified Data.HashMap.Strict as HM+import qualified Data.Set as Set+import qualified Data.Text as Text+import qualified Data.Text.IO as TIO++main :: IO ()+main =+ hspec $ do+ describe "thing" $ do+ it "works" $+ let+ actual :: HashMap Module Text+ actual =+ fmap ((<> "\n") . renderStrict . layoutPretty defaultLayoutOptions)+ . modules+ . Set.toList+ $ elmDefs (Proxy @TestSpec)++ expected :: HashMap Module Text+ expected =+ HM.singleton+ ["Api", "Data"]+ ( Text.unlines+ [ "module Api.Data exposing"+ , " ( dashboardDecoder"+ , " , dashboardEncoder"+ , " , inviteDecoder"+ , " , inviteEncoder"+ , " , Invite(..)"+ , " , Dashboard"+ , " )"+ , ""+ , "import Iso8601"+ , "import Json.Decode"+ , "import Json.Encode"+ , "import Time"+ , ""+ , ""+ , "dashboardDecoder : Json.Decode.Decoder Dashboard"+ , "dashboardDecoder ="+ , " Json.Decode.succeed (\\a b c -> { proposals = a, credits = b, user = c }) |>"+ , " Json.Decode.andThen (\\a -> Json.Decode.map a (Json.Decode.list (Json.Decode.succeed (\\b c -> { key = b"+ , " , value = c }) |>"+ , " Json.Decode.andThen (\\b -> Json.Decode.map b Json.Decode.string) |>"+ , " Json.Decode.andThen (\\b -> Json.Decode.map b (Json.Decode.succeed (\\c d e f g h i j -> { name = c"+ , " , owner = d"+ , " , availability = e"+ , " , description = f"+ , " , venue = g"+ , " , invites = h"+ , " , created_at = i"+ , " , attachments = j }) |>"+ , " Json.Decode.andThen (\\c -> Json.Decode.map c Json.Decode.string) |>"+ , " Json.Decode.andThen (\\c -> Json.Decode.map c Json.Decode.string) |>"+ , " Json.Decode.andThen (\\c -> Json.Decode.map c (Json.Decode.list (Json.Decode.succeed (\\d e -> { interval = d"+ , " , users = e }) |>"+ , " Json.Decode.andThen (\\d -> Json.Decode.map d (Json.Decode.succeed (\\e f -> { startInclusive = e"+ , " , endExclusive = f }) |>"+ , " Json.Decode.andThen (\\e -> Json.Decode.map e Iso8601.decoder) |>"+ , " Json.Decode.andThen (\\e -> Json.Decode.map e Iso8601.decoder))) |>"+ , " Json.Decode.andThen (\\d -> Json.Decode.map d (Json.Decode.list Json.Decode.string))))) |>"+ , " Json.Decode.andThen (\\c -> Json.Decode.map c Json.Decode.string) |>"+ , " Json.Decode.andThen (\\c -> Json.Decode.map c Json.Decode.string) |>"+ , " Json.Decode.andThen (\\c -> Json.Decode.map c (Json.Decode.list inviteDecoder)) |>"+ , " Json.Decode.andThen (\\c -> Json.Decode.map c Iso8601.decoder) |>"+ , " Json.Decode.andThen (\\c -> Json.Decode.map c (Json.Decode.list Json.Decode.string))))))) |>"+ , " Json.Decode.andThen (\\a -> Json.Decode.map a Json.Decode.int) |>"+ , " Json.Decode.andThen (\\a -> Json.Decode.map a 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) ]"+ , ""+ , ""+ , "inviteDecoder : Json.Decode.Decoder Invite"+ , "inviteDecoder ="+ , " Json.Decode.oneOf [ Json.Decode.map Invite_1 (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"+ , " Json.Decode.succeed ()"+ , ""+ , " 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"+ , " , guild = b }) |>"+ , " Json.Decode.andThen (\\a -> Json.Decode.map a (Json.Decode.string |>"+ , " Json.Decode.andThen (\\b -> if b == \"discord-server\" then"+ , " Json.Decode.succeed ()"+ , ""+ , " else"+ , " Json.Decode.fail \"Tag mismatch\"))) |>"+ , " Json.Decode.andThen (\\a -> Json.Decode.map a (Json.Decode.succeed (\\b c -> { id = b"+ , " , name = c }) |>"+ , " Json.Decode.andThen (\\b -> Json.Decode.map b Json.Decode.string) |>"+ , " Json.Decode.andThen (\\b -> Json.Decode.map b Json.Decode.string)))) ]"+ , ""+ , ""+ , "inviteEncoder : Invite -> Json.Encode.Value"+ , "inviteEncoder a ="+ , " case a of"+ , " Invite_1 b ->"+ , " (\\c -> Json.Encode.object [ (\"type\" , always (Json.Encode.string \"discord-user\") c.type_)"+ , " , (\"username\" , Json.Encode.string c.username) ]) b"+ , ""+ , " Invite_2 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 } }"+ , ""+ , ""+ , "type alias Dashboard ="+ , " { proposals : List { key : String"+ , " , value : { name : String"+ , " , owner : String"+ , " , availability : List { interval : { startInclusive : Time.Posix"+ , " , endExclusive : Time.Posix }"+ , " , users : List String }"+ , " , description : String"+ , " , venue : String"+ , " , invites : List Invite"+ , " , created_at : Time.Posix"+ , " , attachments : List String } }"+ , " , credits : Int"+ , " , user : String }"+ ]+ )+ 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+++{-+ This spec is copied from an as-yet uncompleted personal project. I+ just used it because it is fairly complex. Probably something known+ to be exhaustive is in order.+-}+type TestSpec =+ JsonLet+ '[+ '("Dashboard", JsonObject '[+ '("proposals", JsonArray (+ JsonObject '[+ '("key", JsonString),+ '("value", JsonObject '[+ '("name", JsonString),+ '("owner", JsonString),+ '("availability", JsonArray (+ JsonObject '[+ '("interval", JsonObject '[+ '("startInclusive", JsonDateTime),+ '("endExclusive", JsonDateTime)+ ]),+ '("users", JsonArray JsonString)+ ]+ )),+ '("description", JsonString),+ '("venue", JsonString),+ '("invites", (+ JsonLet '[+ '("Invite",+ JsonEither+ (JsonObject '[+ '("type", JsonTag "discord-user"),+ '("username", JsonString)+ ])+ (JsonObject '[+ '("type", JsonTag "discord-server"),+ '("guild", JsonObject '[+ '("id", JsonString),+ '("name", JsonString)+ ])+ ])+ )+ ]+ (JsonArray (JsonRef "Invite")))),+ '("created-at", JsonDateTime),+ '("attachments", JsonArray JsonString)+ ])+ ]+ )),+ '("credits", JsonInt),+ '("user", JsonString)+ ])+ ] ( JsonRef "Dashboard")+