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.2.0.0 +version: 0.3.0.0 synopsis: Elm code generate for `json-spec`. description: Produce elm types, encoders, and decoders from a 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 @@ -21,7 +21,8 @@ import Bound (Scope(Scope), Var(B), abstract1, closed, toScope) -import Control.Monad.Writer (MonadWriter(tell), Writer, execWriter) +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)) @@ -85,7 +86,10 @@ recordDecoders = do dec <- decoderOf @spec more <- recordDecoders @more - pure $ ( sym @name , dec) : more + pure $ + ( sym @name + , "Json.Decode.field" `a` Expr.String (sym @name) `a` dec + ) : more class HasType (spec :: Specification) where @@ -255,7 +259,6 @@ :$$: Lits.Text "> | MySum_3 Float" :$$: Lits.Text "> | MySum_4 Bool" :$$: Lits.Text "" - ) ) => @@ -285,7 +288,7 @@ class HasDef (def :: (Symbol, Specification)) where defs :: Definitions () -instance {-# OVERLAPS #-} {- HasDef '(name, JsonEither left right) -} +instance {- HasDef '(name, JsonEither left right) -} ( KnownSymbol name , SumDef (JsonEither left right) ) @@ -333,10 +336,12 @@ Expr.Lam . toScope $ Expr.Case (Expr.Var (B ())) - [ ( Pat.Con (localName (constructorName conName n)) [Pat.Var 0] + [ ( Pat.Con + (localName (constructorName conName n)) + [Pat.Var 0] , toScope $ - fmap absurd encoder `a` - Expr.Var (B (0 :: Int)) + fmap absurd encoder `a` + Expr.Var (B (0 :: Int)) ) | (n, (conName, encoder)) <- zip [1..] encoders ] @@ -350,44 +355,100 @@ name :: Text name = sym @name -instance (HasType spec, KnownSymbol name) => HasDef '(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 - ( - "Json.Decode.Decoder" `ta` - Type.Global (localName (sym @name)) - ) - ) - dec - , Def.Constant - (encoderName @name) - 0 - ( Scope - ( Type.Fun - (Type.Global $ localName (sym @name)) - "Json.Encode.Value" +instance {- HasDef '(name, Named consName spec) -} + ( HasType spec + , KnownSymbol consName + , KnownSymbol name + ) + => + HasDef '(name, Named consName spec) + where + defs = do + typ <- typeOf @spec + dec <- decoderOf @spec + enc <- encoderOf @spec + tell . Set.fromList $ + [ Def.Type (localName (sym @name)) 0 + [ ( Name.Constructor (sym @consName) + , [ lift typ ] ) - ) - enc - ] + ] + , Def.Constant + (decoderName @name) + 0 + ( Scope + ( + "Json.Decode.Decoder" `ta` + Type.Global (localName (sym @name)) + ) + ) + ( "Json.Decode.map" + `a` Expr.Global (localName (sym @consName)) + `a` dec + ) + , Def.Constant + (encoderName @name) + 0 + ( Scope + ( Type.Fun + (Type.Global $ localName (sym @name)) + "Json.Encode.Value" + ) + ) + ( lam $ \var -> + Expr.Case + var + [ (Pat.Con + (localName (sym @consName)) + [ Pat.Var 0 ] + , toScope $ + (absurd <$> enc) `a` Expr.Var (B 0) + ) + ] + ) + ] +instance {- HasDef '(name, spec) -} + {-# overlaps #-} (HasType spec, KnownSymbol name) + => + HasDef '(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 + ( + "Json.Decode.Decoder" `ta` + 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 [(Maybe Text, Type v)] sumDecoders :: Definitions [(Maybe Text, Expression Void)] sumEncoders :: Definitions [(Maybe Text, Expression Void)] -instance +instance {- SumDef (JsonEither left right) -} (SumDef left, SumDef right) => SumDef (JsonEither left right) @@ -404,7 +465,7 @@ left <- sumEncoders @left right <- sumEncoders @right pure (left ++ right) -instance +instance {- SumDef (JsonLet '[ '(name, def) ] (JsonRef name)) -} ( HasType def , KnownSymbol name ) @@ -457,6 +518,7 @@ decoderName :: forall name. (KnownSymbol name) => Qualified decoderName = localName (lower (sym @name) <> "Decoder") + encoderName :: forall name. (KnownSymbol name) => Qualified encoderName = localName (lower (sym @name) <> "Encoder") diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -63,10 +63,10 @@ , "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" + , " Json.Decode.andThen (\\a -> Json.Decode.map a (Json.Decode.field \"proposals\" (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" + , " Json.Decode.andThen (\\b -> Json.Decode.map b (Json.Decode.field \"key\" Json.Decode.string)) |>" + , " Json.Decode.andThen (\\b -> Json.Decode.map b (Json.Decode.field \"value\" (Json.Decode.succeed (\\c d e f g h i j -> { name = c" , " , owner = d" , " , availability = e" , " , description = f" @@ -74,22 +74,22 @@ , " , 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" + , " Json.Decode.andThen (\\c -> Json.Decode.map c (Json.Decode.field \"name\" Json.Decode.string)) |>" + , " Json.Decode.andThen (\\c -> Json.Decode.map c (Json.Decode.field \"owner\" Json.Decode.string)) |>" + , " Json.Decode.andThen (\\c -> Json.Decode.map c (Json.Decode.field \"availability\" (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" + , " Json.Decode.andThen (\\d -> Json.Decode.map d (Json.Decode.field \"interval\" (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)" + , " Json.Decode.andThen (\\e -> Json.Decode.map e (Json.Decode.field \"startInclusive\" Iso8601.decoder)) |>" + , " Json.Decode.andThen (\\e -> Json.Decode.map e (Json.Decode.field \"endExclusive\" Iso8601.decoder))))) |>" + , " Json.Decode.andThen (\\d -> Json.Decode.map d (Json.Decode.field \"users\" (Json.Decode.list Json.Decode.string))))))) |>" + , " Json.Decode.andThen (\\c -> Json.Decode.map c (Json.Decode.field \"description\" Json.Decode.string)) |>" + , " Json.Decode.andThen (\\c -> Json.Decode.map c (Json.Decode.field \"venue\" Json.Decode.string)) |>" + , " 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.field \"user\" Json.Decode.string))" , "" , "" , "dashboardEncoder : Dashboard -> Json.Encode.Value" @@ -113,25 +113,25 @@ , "inviteDecoder =" , " 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 (\\a -> Json.Decode.map a (Json.Decode.field \"type\" (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.fail \"Tag mismatch\")))) |>" + , " Json.Decode.andThen (\\a -> Json.Decode.map a (Json.Decode.field \"username\" Json.Decode.string)))" , " , 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 (\\a -> Json.Decode.map a (Json.Decode.field \"type\" (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" + , " Json.Decode.fail \"Tag mismatch\")))) |>" + , " Json.Decode.andThen (\\a -> Json.Decode.map a (Json.Decode.field \"guild\" (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)))) ]" + , " Json.Decode.andThen (\\b -> Json.Decode.map b (Json.Decode.field \"id\" Json.Decode.string)) |>" + , " Json.Decode.andThen (\\b -> Json.Decode.map b (Json.Decode.field \"name\" Json.Decode.string)))))) ]" , "" , "" , "inviteEncoder : Invite -> Json.Encode.Value" @@ -294,6 +294,18 @@ , JsonArray JsonString ) ] + ) + ) + , '( "newtypedObject" + , Named "NewtypedElmRecord" + ( Named "Cons" + ( JsonObject + '[ '("stringField", JsonString) + , '( "listOfStrings" + , JsonArray JsonString + ) + ] + ) ) ) ]