{-# 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")