ilyakooo0/elm-bridge
1
0
Fork 0
mirror of https://github.com/ilyakooo0/elm-bridge.git synced 2024-09-11 14:05:55 +03:00
Code Issues Packages Projects Releases Wiki Activity

Work in progress for phantom newtypes

Browse Source 
See #35.
This commit is contained in:
Simon Marechal 2018-08-22 07:46:11 +02:00
parent 5d298317ea
commit 887c2dd939
3 changed files with 76 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
src/Elm/Derive.hs
View File

@ -197,4 +197,10 @@ deriveElmDef opts name =
else deriveAlias True opts name [] conFields
TySynD _ vars otherTy ->
deriveSynonym opts name vars otherTy
NewtypeD _ _ tyvars Nothing (NormalC _ [(Bang NoSourceUnpackedness NoSourceStrictness, otherTy)]) [] ->
deriveSynonym opts name tyvars otherTy
NewtypeD _ _ tyvars Nothing (RecC _ conFields@[(Name (OccName _) _, Bang NoSourceUnpackedness NoSourceStrictness, otherTy)]) [] ->
if A.unwrapUnaryRecords opts
then deriveSynonym opts name tyvars otherTy
else deriveAlias True opts name tyvars conFields
_ -> fail ("Oops, can only derive data and newtype, not this: " ++ show tyCon)

44
test/Elm/JsonSpec.hs
View File

@ -53,6 +53,11 @@ 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)
@ -67,6 +72,10 @@ $(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"
@ -247,6 +256,32 @@ ntdParse = unlines
, " Json.Decode.succeed (NTD {getNtd = pgetNtd})"
]
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 ="
, " (\"getPhantomD\" := Json.Decode.int) >>= \\pgetPhantomD ->"
, " Json.Decode.succeed (PhantomD {getPhantomD = pgetPhantomD})"
]
spec :: Spec
spec =
describe "json serialisation" $
@ -264,6 +299,10 @@ spec =
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
@ -292,3 +331,8 @@ spec =
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

26
test/Elm/TyRenderSpec.hs
View File

@ -35,11 +35,20 @@ data Paa
= PA1
| PA2
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 defaultOptions ''SomeOpts)
$(deriveElmDef defaultOptions ''Unit)
$(deriveElmDef defaultOptions{allNullaryToStringTag = True, constructorTagModifier = drop 1} ''Paa)
$(deriveElmDef defaultOptions ''PhantomA)
$(deriveElmDef defaultOptions ''PhantomB)
$(deriveElmDef defaultOptions { unwrapUnaryRecords = False } ''PhantomC)
$(deriveElmDef defaultOptions { unwrapUnaryRecords = False } ''PhantomD)
fooCode :: String
fooCode = "type alias Foo =\n { name: String\n , blablub: Int\n }\n"
@ -60,6 +69,15 @@ paaCode = unlines
, " | PA2 "
]
phantomATy :: String
phantomATy = "type alias PhantomA a = Int\n"
phantomBTy :: String
phantomBTy = "type alias PhantomB a = Int\n"
phantomCTy :: String
phantomCTy = "type alias PhantomC a = Int\n"
phantomDTy :: String
phantomDTy = "type PhantomD a = PhantomD\n { getPhantomD: Int\n }\n"
spec :: Spec
spec =
describe "deriveElmRep" $
@ -68,9 +86,17 @@ spec =
rSomeOpts = compileElmDef (Proxy :: Proxy (SomeOpts a))
rUnit = compileElmDef (Proxy :: Proxy Unit)
rPaa = compileElmDef (Proxy :: Proxy Paa)
rPhA = compileElmDef (Proxy :: Proxy (PhantomA a))
rPhB = compileElmDef (Proxy :: Proxy (PhantomB a))
rPhC = compileElmDef (Proxy :: Proxy (PhantomC a))
rPhD = compileElmDef (Proxy :: Proxy (PhantomD a))
it "should produce the correct code" $
do renderElm rFoo `shouldBe` fooCode
renderElm rBar `shouldBe` barCode
renderElm rSomeOpts `shouldBe` someOptsCode
renderElm rUnit `shouldBe` unitCode
renderElm rPaa `shouldBe` paaCode
renderElm rPhA `shouldBe` phantomATy
renderElm rPhB `shouldBe` phantomBTy
renderElm rPhC `shouldBe` phantomCTy
renderElm rPhD `shouldBe` phantomDTy