elm-bridge-0.8.5: test/Elm/JsonSpec.hs
{-# LANGUAGE TemplateHaskell #-}
module Elm.JsonSpec (spec) where
import Elm.Derive
import Elm.Json
import Elm.TyRender
import Elm.TyRep
import qualified Data.Aeson.TH as TH
import Data.Aeson.Types (defaultTaggedObject)
import Data.Char (toLower)
import qualified Data.Map.Strict as M
import Data.Proxy
import Test.Hspec
data Foo
= Foo
{ f_name :: String
, f_blablub :: Int
} deriving (Show, Eq)
data Bar a
= Bar
{ b_name :: a
, b_blablub :: Int
, b_tuple :: (Int, String)
, b_list :: [Bool]
} deriving (Show, Eq)
data SomeOpts a
= Okay Int
| NotOkay a
data UnaryA = UnaryA1 | UnaryA2
data UnaryB = UnaryB1 | UnaryB2
data Change a = Change { _before :: a, _after :: a }
data Baz a = Baz1 { _foo :: Int, _qux :: M.Map Int a }
| Baz2 { _bar :: Maybe Int, _str :: String }
| Testing (Baz a)
data TestComp a = TestComp { _t1 :: Change Int
, _t2 :: Change a
}
data DoneState = Done | NotDone deriving (Eq, Show)
data Id = Id String deriving (Show, Eq)
data EditDone = EditDone Id DoneState DoneState deriving (Show, Eq)
newtype NTA = NTA Int
newtype NTB = NTB { getNtb :: Int }
newtype NTC = NTC Int
newtype NTD = NTD { getNtd :: Int }
newtype PhantomA a = PhantomA Int
newtype PhantomB a = PhantomB { getPhantomB :: Int }
newtype PhantomC a = PhantomC Int
newtype PhantomD a = PhantomD { getPhantomD :: Int }
$(deriveElmDef (defaultOptionsDropLower 2) ''Foo)
$(deriveElmDef (defaultOptionsDropLower 2) ''Bar)
$(deriveElmDef (defaultOptionsDropLower 1) ''TestComp)
$(deriveElmDef defaultOptions ''SomeOpts)
$(deriveElmDef defaultOptions{ allNullaryToStringTag = False } ''UnaryA)
$(deriveElmDef defaultOptions{ allNullaryToStringTag = True } ''UnaryB)
$(deriveElmDef defaultOptions { fieldLabelModifier = drop 1 . map toLower } ''Baz)
$(deriveElmDef (defaultOptions { sumEncoding = defaultTaggedObject }) ''DoneState)
$(deriveElmDef (TH.defaultOptions { sumEncoding = TH.defaultTaggedObject }) ''Id)
$(deriveElmDef (TH.defaultOptions { sumEncoding = TH.defaultTaggedObject }) ''EditDone)
$(deriveElmDef defaultOptions ''NTA)
$(deriveElmDef defaultOptions ''NTB)
$(deriveElmDef defaultOptions { unwrapUnaryRecords = False } ''NTC)
$(deriveElmDef defaultOptions { unwrapUnaryRecords = False } ''NTD)
$(deriveElmDef defaultOptions ''PhantomA)
$(deriveElmDef defaultOptions ''PhantomB)
$(deriveElmDef defaultOptions { unwrapUnaryRecords = False } ''PhantomC)
$(deriveElmDef defaultOptions { unwrapUnaryRecords = False } ''PhantomD)
fooSer :: String
fooSer = "jsonEncFoo : Foo -> Value\njsonEncFoo val =\n Json.Encode.object\n [ (\"name\", Json.Encode.string val.name)\n , (\"blablub\", Json.Encode.int val.blablub)\n ]\n"
fooParse :: String
fooParse = unlines
[ "jsonDecFoo : Json.Decode.Decoder ( Foo )"
, "jsonDecFoo ="
, " Json.Decode.succeed Foo"
, " |> required \"name\" (Json.Decode.string)"
, " |> required \"blablub\" (Json.Decode.int)"
]
barSer :: String
barSer = unlines
[ "jsonEncBar : (a -> Value) -> Bar a -> Value"
, "jsonEncBar localEncoder_a val ="
, " Json.Encode.object"
, " [ (\"name\", localEncoder_a val.name)"
, " , (\"blablub\", Json.Encode.int val.blablub)"
, " , (\"tuple\", (\\(t1,t2) -> Json.Encode.list identity [(Json.Encode.int) t1,(Json.Encode.string) t2]) val.tuple)"
, " , (\"list\", (Json.Encode.list Json.Encode.bool) val.list)"
, " ]"
]
bazSer :: String
bazSer = unlines
[ "jsonEncBaz : (a -> Value) -> Baz a -> Value"
, "jsonEncBaz localEncoder_a val ="
, " let keyval v = case v of"
, " Baz1 vs -> (\"Baz1\", encodeObject [(\"foo\", Json.Encode.int vs.foo), (\"qux\", (jsonEncMap (Json.Encode.int) (localEncoder_a)) vs.qux)])"
, " Baz2 vs -> (\"Baz2\", encodeObject [(\"bar\", (maybeEncode (Json.Encode.int)) vs.bar), (\"str\", Json.Encode.string vs.str)])"
, " Testing v1 -> (\"Testing\", encodeValue ((jsonEncBaz (localEncoder_a)) v1))"
, " in encodeSumObjectWithSingleField keyval val"
]
barParse :: String
barParse = unlines
[ "jsonDecBar : Json.Decode.Decoder a -> Json.Decode.Decoder ( Bar a )"
, "jsonDecBar localDecoder_a ="
, " Json.Decode.succeed Bar"
, " |> required \"name\" (localDecoder_a)"
, " |> required \"blablub\" (Json.Decode.int)"
, " |> required \"tuple\" (Json.Decode.map2 tuple2 (Json.Decode.index 0 (Json.Decode.int)) (Json.Decode.index 1 (Json.Decode.string)))"
, " |> required \"list\" (Json.Decode.list (Json.Decode.bool))"
]
bazParse :: String
bazParse = unlines
[ "jsonDecBaz : Json.Decode.Decoder a -> Json.Decode.Decoder ( Baz a )"
, "jsonDecBaz localDecoder_a ="
, " let jsonDecDictBaz = Dict.fromList"
, " [ (\"Baz1\", Json.Decode.lazy (\\_ -> Json.Decode.map Baz1 ( Json.Decode.succeed Baz |> required \"foo\" (Json.Decode.int) |> required \"qux\" (jsonDecMap (Json.Decode.int) (localDecoder_a)))))"
, " , (\"Baz2\", Json.Decode.lazy (\\_ -> Json.Decode.map Baz2 ( Json.Decode.succeed Baz |> fnullable \"bar\" (Json.Decode.int) |> required \"str\" (Json.Decode.string))))"
, " , (\"Testing\", Json.Decode.lazy (\\_ -> Json.Decode.map Testing (jsonDecBaz (localDecoder_a))))"
, " ]"
, " in decodeSumObjectWithSingleField \"Baz\" jsonDecDictBaz"
]
someOptsParse :: String
someOptsParse = unlines
[ "jsonDecSomeOpts : Json.Decode.Decoder a -> Json.Decode.Decoder ( SomeOpts a )"
, "jsonDecSomeOpts localDecoder_a ="
, " let jsonDecDictSomeOpts = Dict.fromList"
, " [ (\"Okay\", Json.Decode.lazy (\\_ -> Json.Decode.map Okay (Json.Decode.int)))"
, " , (\"NotOkay\", Json.Decode.lazy (\\_ -> Json.Decode.map NotOkay (localDecoder_a)))"
, " ]"
, " in decodeSumObjectWithSingleField \"SomeOpts\" jsonDecDictSomeOpts"
]
someOptsSer :: String
someOptsSer = unlines
[ "jsonEncSomeOpts : (a -> Value) -> SomeOpts a -> Value"
, "jsonEncSomeOpts localEncoder_a val ="
, " let keyval v = case v of"
, " Okay v1 -> (\"Okay\", encodeValue (Json.Encode.int v1))"
, " NotOkay v1 -> (\"NotOkay\", encodeValue (localEncoder_a v1))"
, " in encodeSumObjectWithSingleField keyval val"
]
test1Parse :: String
test1Parse = unlines
[ "jsonDecTestComp : Json.Decode.Decoder a -> Json.Decode.Decoder ( TestComp a )"
, "jsonDecTestComp localDecoder_a ="
, " Json.Decode.succeed TestComp"
, " |> required \"t1\" (jsonDecChange (Json.Decode.int))"
, " |> required \"t2\" (jsonDecChange (localDecoder_a))"
]
unaryAParse :: String
unaryAParse = unlines
[ "jsonDecUnaryA : Json.Decode.Decoder ( UnaryA )"
, "jsonDecUnaryA ="
, " let jsonDecDictUnaryA = Dict.fromList"
, " [ (\"UnaryA1\", Json.Decode.lazy (\\_ -> Json.Decode.succeed UnaryA1))"
, " , (\"UnaryA2\", Json.Decode.lazy (\\_ -> Json.Decode.succeed UnaryA2))"
, " ]"
, " in decodeSumObjectWithSingleField \"UnaryA\" jsonDecDictUnaryA"
]
unaryAStringParser :: String
unaryAStringParser = unlines
[ "stringDecUnaryA : String -> Maybe UnaryA"
, "stringDecUnaryA s ="
, " case s of"
, " \"UnaryA1\" -> Just UnaryA1"
, " \"UnaryA2\" -> Just UnaryA2"
, " _ -> Nothing"
]
unaryBParse :: String
unaryBParse = unlines
[ "jsonDecUnaryB : Json.Decode.Decoder ( UnaryB )"
, "jsonDecUnaryB = "
, " let jsonDecDictUnaryB = Dict.fromList [(\"UnaryB1\", UnaryB1), (\"UnaryB2\", UnaryB2)]"
, " in decodeSumUnaries \"UnaryB\" jsonDecDictUnaryB"
]
unaryASer :: String
unaryASer = unlines
[ "jsonEncUnaryA : UnaryA -> Value"
, "jsonEncUnaryA val ="
, " let keyval v = case v of"
, " UnaryA1 -> (\"UnaryA1\", encodeValue (Json.Encode.list identity []))"
, " UnaryA2 -> (\"UnaryA2\", encodeValue (Json.Encode.list identity []))"
, " in encodeSumObjectWithSingleField keyval val"
]
unaryAStringSer :: String
unaryAStringSer = unlines
[ "stringEncUnaryA : UnaryA -> String"
, "stringEncUnaryA val ="
, " case val of"
, " UnaryA1 -> \"UnaryA1\""
, " UnaryA2 -> \"UnaryA2\""
]
unaryBSer :: String
unaryBSer = unlines
[ "jsonEncUnaryB : UnaryB -> Value"
, "jsonEncUnaryB val ="
, " case val of"
, " UnaryB1 -> Json.Encode.string \"UnaryB1\""
, " UnaryB2 -> Json.Encode.string \"UnaryB2\""
]
doneParse :: String
doneParse = unlines
[ "jsonDecDoneState : Json.Decode.Decoder ( DoneState )"
, "jsonDecDoneState = "
, " let jsonDecDictDoneState = Dict.fromList [(\"Done\", Done), (\"NotDone\", NotDone)]"
, " in decodeSumUnaries \"DoneState\" jsonDecDictDoneState"
]
editDoneParse :: String
editDoneParse = unlines
[ "jsonDecEditDone : Json.Decode.Decoder ( EditDone )"
, "jsonDecEditDone ="
, " Json.Decode.lazy (\\_ -> Json.Decode.map3 EditDone (Json.Decode.index 0 (jsonDecId)) (Json.Decode.index 1 (jsonDecDoneState)) (Json.Decode.index 2 (jsonDecDoneState)))"
, ""
]
idParse :: String
idParse = unlines
[ "jsonDecId : Json.Decode.Decoder ( Id )"
, "jsonDecId ="
, " Json.Decode.lazy (\\_ -> Json.Decode.map Id (Json.Decode.string))"
, ""
]
ntaParse :: String
ntaParse = unlines
[ "jsonDecNTA : Json.Decode.Decoder ( NTA )"
, "jsonDecNTA ="
, " Json.Decode.int"
]
ntbParse :: String
ntbParse = unlines
[ "jsonDecNTB : Json.Decode.Decoder ( NTB )"
, "jsonDecNTB ="
, " Json.Decode.int"
]
ntcParse :: String
ntcParse = unlines
[ "jsonDecNTC : Json.Decode.Decoder ( NTC )"
, "jsonDecNTC ="
, " Json.Decode.int"
]
ntdParse :: String
ntdParse = unlines
[ "jsonDecNTD : Json.Decode.Decoder ( NTD )"
, "jsonDecNTD ="
, " Json.Decode.succeed NTD"
, " |> required \"getNtd\" (Json.Decode.int)"
]
phantomAParse :: String
phantomAParse = unlines
[ "jsonDecPhantomA : Json.Decode.Decoder a -> Json.Decode.Decoder ( PhantomA a )"
, "jsonDecPhantomA localDecoder_a ="
, " Json.Decode.int"
]
phantomBParse :: String
phantomBParse = unlines
[ "jsonDecPhantomB : Json.Decode.Decoder a -> Json.Decode.Decoder ( PhantomB a )"
, "jsonDecPhantomB localDecoder_a ="
, " Json.Decode.int"
]
phantomCParse :: String
phantomCParse = unlines
[ "jsonDecPhantomC : Json.Decode.Decoder a -> Json.Decode.Decoder ( PhantomC a )"
, "jsonDecPhantomC localDecoder_a ="
, " Json.Decode.int"
]
phantomDParse :: String
phantomDParse = unlines
[ "jsonDecPhantomD : Json.Decode.Decoder a -> Json.Decode.Decoder ( PhantomD a )"
, "jsonDecPhantomD localDecoder_a ="
, " Json.Decode.succeed PhantomD"
, " |> required \"getPhantomD\" (Json.Decode.int)"
]
spec :: Spec
spec =
describe "json serialisation" $
do let rFoo = compileElmDef (Proxy :: Proxy Foo)
rBar = compileElmDef (Proxy :: Proxy (Bar a))
rBaz = compileElmDef (Proxy :: Proxy (Baz a))
rTest1 = compileElmDef (Proxy :: Proxy (TestComp a))
rSomeOpts = compileElmDef (Proxy :: Proxy (SomeOpts a))
rUnaryA = compileElmDef (Proxy :: Proxy UnaryA)
rUnaryB = compileElmDef (Proxy :: Proxy UnaryB)
rDoneState = compileElmDef (Proxy :: Proxy DoneState)
rId = compileElmDef (Proxy :: Proxy Id)
rEditDone = compileElmDef (Proxy :: Proxy EditDone)
rNTA = compileElmDef (Proxy :: Proxy NTA)
rNTB = compileElmDef (Proxy :: Proxy NTB)
rNTC = compileElmDef (Proxy :: Proxy NTC)
rNTD = compileElmDef (Proxy :: Proxy NTD)
rPhantomA = compileElmDef (Proxy :: Proxy (PhantomA a))
rPhantomB = compileElmDef (Proxy :: Proxy (PhantomB a))
rPhantomC = compileElmDef (Proxy :: Proxy (PhantomC a))
rPhantomD = compileElmDef (Proxy :: Proxy (PhantomD a))
it "should produce the correct ser code" $ do
jsonSerForDef rFoo `shouldBe` fooSer
jsonSerForDef rBar `shouldBe` barSer
jsonSerForDef rSomeOpts `shouldBe` someOptsSer
jsonSerForDef rBaz `shouldBe` bazSer
it "should produce the correct ser code for unary unions" $ do
jsonSerForDef rUnaryA `shouldBe` unaryASer
jsonSerForDef rUnaryB `shouldBe` unaryBSer
it "should produce the correct stringSerForSimpleAdt code" $ do
stringSerForSimpleAdt rUnaryA `shouldBe` unaryAStringSer
it "should produce the correct stringParserForDef code" $ do
stringParserForSimpleAdt rUnaryA `shouldBe` unaryAStringParser
it "should produce the correct parse code for aliases" $ do
jsonParserForDef rFoo `shouldBe` fooParse
jsonParserForDef rBar `shouldBe` barParse
it "should produce the correct parse code generic sum types" $ do
jsonParserForDef rBaz `shouldBe` bazParse
jsonParserForDef rSomeOpts `shouldBe` someOptsParse
jsonParserForDef rTest1 `shouldBe` test1Parse
it "should produce the correct parse code for unary unions" $ do
jsonParserForDef rUnaryA `shouldBe` unaryAParse
jsonParserForDef rUnaryB `shouldBe` unaryBParse
it "should produce the correct parse code for issue #18" $ do
jsonParserForDef rDoneState `shouldBe` doneParse
jsonParserForDef rId `shouldBe` idParse
jsonParserForDef rEditDone `shouldBe` editDoneParse
it "should produce the correct parse code for newtypes with unwrapUnaryRecords=True" $ do
jsonParserForDef rNTA `shouldBe` ntaParse
jsonParserForDef rNTB `shouldBe` ntbParse
it "should produce the correct parse code for newtypes with unwrapUnaryRecords=False" $ do
jsonParserForDef rNTC `shouldBe` ntcParse
jsonParserForDef rNTD `shouldBe` ntdParse
it "should produce the correct parse code for phantom newtypes" $ do
jsonParserForDef rPhantomA `shouldBe` phantomAParse
jsonParserForDef rPhantomB `shouldBe` phantomBParse
jsonParserForDef rPhantomC `shouldBe` phantomCParse
jsonParserForDef rPhantomD `shouldBe` phantomDParse