{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module Main (main) where
import Data.Foldable (traverse_)
import Data.HashMap.Strict (HashMap)
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))
import Data.Text (Text)
import Language.Elm.Name (Module)
import Language.Elm.Pretty (modules)
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
import qualified Data.Text as Text
import qualified Data.Text.IO as TIO
main :: IO ()
main =
hspec $ do
describe "Code generation" $ do
it "works with a complicated schema" $
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.field \"proposals\" (Json.Decode.list (Json.Decode.succeed (\\b c -> { key = b"
, " , value = 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"
, " , venue = g"
, " , invites = h"
, " , created_at = i"
, " , attachments = j }) |>"
, " 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.field \"interval\" (Json.Decode.succeed (\\e f -> { startInclusive = e"
, " , endExclusive = f }) |>"
, " 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.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 (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"
, "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.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.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.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.field \"guild\" (Json.Decode.succeed (\\b c -> { id = b"
, " , name = c }) |>"
, " 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"
, "inviteEncoder a ="
, " case a of"
, " InviteUser 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 (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 "
, " = InviteUser { type_ : (), username : String }"
, " | InviteGuild { 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 : Maybe 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
compileElm actual
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
compileElm actual
it "works with nullable values" $
let
actual :: HashMap Module Text
actual =
fmap ((<> "\n") . renderStrict . layoutPretty defaultLayoutOptions)
. modules
. Set.toList
$ elmDefs (Proxy @NullableSpec)
expected :: HashMap Module Text
expected =
HM.singleton
["Api", "Data"]
( Text.unlines
[ "module Api.Data exposing"
, " ( nullableIntDecoder"
, " , nullableIntEncoder"
, " , NullableInt"
, " )"
, ""
, "import Json.Decode"
, "import Json.Encode"
, ""
, ""
, "nullableIntDecoder : Json.Decode.Decoder NullableInt"
, "nullableIntDecoder ="
, " Json.Decode.nullable Json.Decode.int"
, ""
, ""
, "nullableIntEncoder : NullableInt -> Json.Encode.Value"
, "nullableIntEncoder a ="
, " Maybe.withDefault Json.Encode.null (Maybe.map Json.Encode.int a)"
, ""
, ""
, "type alias NullableInt ="
, " Maybe Int"
]
)
in do
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)
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
to be exhaustive is in order.
-}
type TestSpec =
JsonLet
'[
'("Dashboard", JsonObject '[
Required "proposals" (JsonArray (
JsonObject '[
Required "key" JsonString,
Required "value" (JsonObject '[
Required "name" JsonString,
Required "owner" JsonString,
Required "availability" (JsonArray (
JsonObject '[
Required "interval" (JsonObject '[
Required "startInclusive" JsonDateTime,
Required "endExclusive" JsonDateTime
]),
Required "users" (JsonArray JsonString)
]
)),
Required "description" JsonString,
Required "venue" JsonString,
Required "invites" (
JsonLet '[
'("Invite",
JsonEither
(Named "InviteUser" (JsonObject '[
Required "type" (JsonTag "discord-user"),
Required "username" JsonString
]))
(Named "InviteGuild" (JsonObject '[
Required "type" (JsonTag "discord-server"),
Required "guild" (JsonObject '[
Required "id" JsonString,
Required "name" JsonString
])
]))
)
]
(JsonArray (JsonRef "Invite"))
),
Required "created-at" JsonDateTime,
Required "attachments" (JsonArray JsonString)
])
]
)),
Optional "credits" JsonInt,
Required "user" JsonString
])
] ( JsonRef "Dashboard")
type ExampleSpec =
Named "ExampleType"
( 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)
)
),
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)
]
)
)
)
]
)
type NullableSpec =
Named "NullableInt"
(JsonNullable JsonInt)
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_)