elm-bridge 0.4.1 → 0.4.2
raw patch · 8 files changed
+56/−46 lines, 8 filesdep +hspec-discoverdep ~aeson
Dependencies added: hspec-discover
Dependency ranges changed: aeson
Files
- CHANGELOG.md +5/−0
- elm-bridge.cabal +4/−2
- src/Elm/Derive.hs +10/−13
- src/Elm/Json.hs +9/−5
- src/Elm/TyRep.hs +7/−2
- test/Elm/JsonSpec.hs +7/−7
- test/Elm/ModuleSpec.hs +2/−2
- test/EndToEnd.hs +12/−15
CHANGELOG.md view
@@ -1,3 +1,8 @@+# v0.4.2++Drop support for `aeson < 1.`+Add support for `aeson == 1.2.*`+ # v0.4.1 ## Bugfixes
elm-bridge.cabal view
@@ -1,5 +1,5 @@ name: elm-bridge-version: 0.4.1+version: 0.4.2 synopsis: Derive Elm types and Json code from Haskell types description: Building the bridge from Haskell to Elm and back. Define types once, use on both sides and enjoy easy (de)serialisation. Cheers!@@ -14,6 +14,7 @@ category: Web, Compiler, Language build-type: Simple cabal-version: >=1.10+tested-with: GHC==8.2.1, GHC==8.0.2, GHC==7.10.3 extra-source-files: README.md@@ -34,7 +35,7 @@ other-modules: Elm.Utils build-depends: base >= 4.7 && < 5, template-haskell,- aeson >= 0.9+ aeson >= 1 default-language: Haskell2010 test-suite end-to-end-tests@@ -61,6 +62,7 @@ build-depends: base, hspec >= 2.0,+ hspec-discover, elm-bridge, aeson, containers
src/Elm/Derive.hs view
@@ -40,22 +40,18 @@ -- | Note that This default set of options is distinct from that in -- the @aeson@ package. defaultOptions :: A.Options-defaultOptions = A.Options { A.sumEncoding = A.ObjectWithSingleField- , A.fieldLabelModifier = id- , A.constructorTagModifier = id- , A.allNullaryToStringTag = True- , A.omitNothingFields = False-#if MIN_VERSION_aeson(0,10,0)- , A.unwrapUnaryRecords = False-#endif- }+defaultOptions+ = A.defaultOptions+ { A.sumEncoding = A.ObjectWithSingleField+ , A.fieldLabelModifier = id+ , A.constructorTagModifier = id+ , A.allNullaryToStringTag = True+ , A.omitNothingFields = False+ , A.unwrapUnaryRecords = False+ } unwrapUnaryRecords :: A.Options -> Bool-#if MIN_VERSION_aeson(0,10,0) unwrapUnaryRecords opts = A.unwrapUnaryRecords opts-#else-unwrapUnaryRecords _ = False-#endif {-| This generates a default set of options. The parameter represents the number of characters that must be dropped from the Haskell field names.@@ -96,6 +92,7 @@ TwoElemArray -> [|SumEncoding' TwoElemArray|] ObjectWithSingleField -> [|SumEncoding' ObjectWithSingleField|] TaggedObject tn cn -> [|SumEncoding' (TaggedObject tn cn)|]+ UntaggedValue -> [|SumEncoding' UntaggedValue|] runDerive :: Name -> [TyVarBndr] -> (Q Exp -> Q Exp) -> Q [Dec] runDerive name vars mkBody =
src/Elm/Json.hs view
@@ -108,11 +108,12 @@ where tab n s = replicate n ' ' ++ s typename = et_name name- declLine [o] = ""- declLine os = " in " ++ case encodingType of+ declLine [_] = ""+ declLine _ = " in " ++ case encodingType of ObjectWithSingleField -> unwords [ "decodeSumObjectWithSingleField ", show typename, dictName] TwoElemArray -> unwords [ "decodeSumTwoElemArray ", show typename, dictName ] TaggedObject tg el -> unwords [ "decodeSumTaggedObject", show typename, show tg, show el, dictName, isObjectSetName ]+ UntaggedValue -> "Json.Decode.oneOf (Dict.values " ++ dictName ++ ")" dictName = "jsonDecDict" ++ typename isObjectSetName = "jsonDecObjectSet" ++ typename deriveUnaries strs = unlines@@ -126,12 +127,13 @@ TaggedObject _ _ -> "\n" ++ tab 8 (isObjectSetName ++ " = " ++ "Set.fromList [" ++ intercalate ", " (map (show . fst) $ filter (isLeft . snd) opts) ++ "]") _ -> "" dictEntry (oname, args) = "(" ++ show oname ++ ", " ++ mkDecoder oname args ++ ")"- mkDecoder oname (Left args) = "Json.Decode.map "+ mkDecoder oname (Left args) = lazy $ "Json.Decode.map " ++ cap oname ++ " (" ++ unwords (parseRecords Nothing False args) ++ ")"- mkDecoder oname (Right args) = unwords ( decodeFunction++ mkDecoder oname (Right args) = lazy $ unwords ( decodeFunction : cap oname : zipWith (\t' i -> "(" ++ jsonParserForIndexedType t' i ++ ")") args [0..] )@@ -148,6 +150,7 @@ decoderType name = funcname name ++ " : " ++ intercalate " -> " (prependTypes "Json.Decode.Decoder " name ++ [decoderTypeEnd name]) decoderTypeEnd name = unwords ("Json.Decode.Decoder" : "(" : et_name name : map tv_name (et_args name) ++ [")"]) makeName name = unwords (funcname name : prependTypes "localDecoder_" name)+ lazy decoder = "Json.Decode.lazy (\\_ -> " ++ decoder ++ ")" {-| Compile a JSON serializer for an Elm type. @@ -210,9 +213,10 @@ ObjectWithSingleField -> "encodeSumObjectWithSingleField" TwoElemArray -> "encodeSumTwoElementArray" TaggedObject k c -> unwords ["encodeSumTaggedObject", show k, show c]+ UntaggedValue -> "encodeSumUntagged" defaultEncoding [(oname, Right args)] = unlines $ [ makeType name- , fname name ++ " " + , fname name ++ " " ++ unwords (map (\tv -> "localEncoder_" ++ tv_name tv) $ et_args name) ++ "(" ++ cap oname ++ " " ++ argList args ++ ") =" , " " ++ mkEncodeList args
src/Elm/TyRep.hs view
@@ -113,24 +113,29 @@ TaggedObject n f -> "TaggedObject " ++ show n ++ " " ++ show f ObjectWithSingleField -> "ObjectWithSingleField" TwoElemArray -> "TwoElemArray"+ UntaggedValue -> "UntaggedValue" instance Eq SumEncoding' where SumEncoding' a == SumEncoding' b = case (a,b) of (TaggedObject a1 b1, TaggedObject a2 b2) -> a1 == a2 && b1 == b2 (ObjectWithSingleField, ObjectWithSingleField) -> True (TwoElemArray, TwoElemArray) -> True+ (UntaggedValue, UntaggedValue) -> True _ -> False instance Ord SumEncoding' where compare (SumEncoding' a) (SumEncoding' b) = case (a,b) of (TaggedObject a1 b1, TaggedObject a2 b2) -> compare a1 a2 <> compare b1 b2+ (ObjectWithSingleField, ObjectWithSingleField) -> EQ+ (TwoElemArray, TwoElemArray) -> EQ+ (UntaggedValue, UntaggedValue) -> EQ (TaggedObject _ _, _) -> LT (_, TaggedObject _ _) -> GT- (ObjectWithSingleField, ObjectWithSingleField) -> EQ (ObjectWithSingleField, _) -> LT (_, ObjectWithSingleField) -> GT- (TwoElemArray, TwoElemArray) -> EQ+ (UntaggedValue, _) -> LT+ (_, UntaggedValue) -> GT defSumEncoding :: SumEncoding' defSumEncoding = SumEncoding' ObjectWithSingleField
test/Elm/JsonSpec.hs view
@@ -106,9 +106,9 @@ [ "jsonDecBaz : Json.Decode.Decoder a -> Json.Decode.Decoder ( Baz a )" , "jsonDecBaz localDecoder_a =" , " let jsonDecDictBaz = Dict.fromList"- , " [ (\"Baz1\", Json.Decode.map Baz1 ( (\"foo\" := Json.Decode.int) >>= \\pfoo -> (\"qux\" := jsonDecMap (Json.Decode.int) (localDecoder_a)) >>= \\pqux -> Json.Decode.succeed {foo = pfoo, qux = pqux}))"- , " , (\"Baz2\", Json.Decode.map Baz2 ( (Json.Decode.maybe (\"bar\" := Json.Decode.int)) >>= \\pbar -> (\"str\" := Json.Decode.string) >>= \\pstr -> Json.Decode.succeed {bar = pbar, str = pstr}))"- , " , (\"Testing\", Json.Decode.map Testing (jsonDecBaz (localDecoder_a)))"+ , " [ (\"Baz1\", Json.Decode.lazy (\\_ -> Json.Decode.map Baz1 ( (\"foo\" := Json.Decode.int) >>= \\pfoo -> (\"qux\" := jsonDecMap (Json.Decode.int) (localDecoder_a)) >>= \\pqux -> Json.Decode.succeed {foo = pfoo, qux = pqux})))"+ , " , (\"Baz2\", Json.Decode.lazy (\\_ -> Json.Decode.map Baz2 ( (Json.Decode.maybe (\"bar\" := Json.Decode.int)) >>= \\pbar -> (\"str\" := Json.Decode.string) >>= \\pstr -> Json.Decode.succeed {bar = pbar, str = pstr})))"+ , " , (\"Testing\", Json.Decode.lazy (\\_ -> Json.Decode.map Testing (jsonDecBaz (localDecoder_a))))" , " ]" , " in decodeSumObjectWithSingleField \"Baz\" jsonDecDictBaz" ]@@ -124,8 +124,8 @@ [ "jsonDecSomeOpts : Json.Decode.Decoder a -> Json.Decode.Decoder ( SomeOpts a )" , "jsonDecSomeOpts localDecoder_a =" , " let jsonDecDictSomeOpts = Dict.fromList"- , " [ (\"Okay\", Json.Decode.map Okay (Json.Decode.int))"- , " , (\"NotOkay\", Json.Decode.map NotOkay (localDecoder_a))"+ , " [ (\"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" ]@@ -154,8 +154,8 @@ [ "jsonDecUnaryA : Json.Decode.Decoder ( UnaryA )" , "jsonDecUnaryA =" , " let jsonDecDictUnaryA = Dict.fromList"- , " [ (\"UnaryA1\", Json.Decode.succeed UnaryA1)"- , " , (\"UnaryA2\", Json.Decode.succeed UnaryA2)"+ , " [ (\"UnaryA1\", Json.Decode.lazy (\\_ -> Json.Decode.succeed UnaryA1))"+ , " , (\"UnaryA2\", Json.Decode.lazy (\\_ -> Json.Decode.succeed UnaryA2))" , " ]" , " in decodeSumObjectWithSingleField \"UnaryA\" jsonDecDictUnaryA" ]
test/Elm/ModuleSpec.hs view
@@ -89,8 +89,8 @@ , "jsonDecQux : Json.Decode.Decoder a -> Json.Decode.Decoder ( Qux a )" , "jsonDecQux localDecoder_a =" , " let jsonDecDictQux = Dict.fromList"- , " [ (\"Qux1\", Json.Decode.map2 Qux1 (Json.Decode.index 0 (Json.Decode.int)) (Json.Decode.index 1 (Json.Decode.string)))"- , " , (\"Qux2\", Json.Decode.map Qux2 ( (\"a\" := Json.Decode.int) >>= \\pa -> (\"test\" := localDecoder_a) >>= \\ptest -> Json.Decode.succeed {a = pa, test = ptest}))"+ , " [ (\"Qux1\", Json.Decode.lazy (\\_ -> Json.Decode.map2 Qux1 (Json.Decode.index 0 (Json.Decode.int)) (Json.Decode.index 1 (Json.Decode.string))))"+ , " , (\"Qux2\", Json.Decode.lazy (\\_ -> Json.Decode.map Qux2 ( (\"a\" := Json.Decode.int) >>= \\pa -> (\"test\" := localDecoder_a) >>= \\ptest -> Json.Decode.succeed {a = pa, test = ptest})))" , " ]" , " in decodeSumObjectWithSingleField \"Qux\" jsonDecDictQux" , ""
test/EndToEnd.hs view
@@ -40,6 +40,9 @@ data SimpleRecord03 a = SimpleRecord03 { _s03qux :: a } deriving Show data SimpleRecord04 a = SimpleRecord04 { _s04qux :: a } deriving Show +data SumUntagged a = SMInt Int | SMList a+ deriving Show+ $(deriveBoth defaultOptions{ fieldLabelModifier = drop 3, omitNothingFields = False } ''Record1) $(deriveBoth defaultOptions{ fieldLabelModifier = drop 3, omitNothingFields = True } ''Record2) @@ -58,7 +61,6 @@ $(deriveBoth defaultOptions{ fieldLabelModifier = drop 4, omitNothingFields = False, allNullaryToStringTag = True , sumEncoding = TwoElemArray } ''Sum11) $(deriveBoth defaultOptions{ fieldLabelModifier = drop 4, omitNothingFields = True , allNullaryToStringTag = True , sumEncoding = TwoElemArray } ''Sum12) -#if MIN_VERSION_aeson(0,10,0) $(deriveBoth defaultOptions{ allNullaryToStringTag = False, unwrapUnaryRecords = False } ''Simple01) $(deriveBoth defaultOptions{ allNullaryToStringTag = False, unwrapUnaryRecords = True } ''Simple02) $(deriveBoth defaultOptions{ allNullaryToStringTag = True, unwrapUnaryRecords = False } ''Simple03)@@ -68,17 +70,8 @@ $(deriveBoth defaultOptions{ allNullaryToStringTag = False, unwrapUnaryRecords = True , fieldLabelModifier = drop 4 } ''SimpleRecord02) $(deriveBoth defaultOptions{ allNullaryToStringTag = True , unwrapUnaryRecords = False, fieldLabelModifier = drop 4 } ''SimpleRecord03) $(deriveBoth defaultOptions{ allNullaryToStringTag = True , unwrapUnaryRecords = True , fieldLabelModifier = drop 4 } ''SimpleRecord04)-#else-$(deriveBoth defaultOptions{ allNullaryToStringTag = False } ''Simple01)-$(deriveBoth defaultOptions{ allNullaryToStringTag = False } ''Simple02)-$(deriveBoth defaultOptions{ allNullaryToStringTag = True } ''Simple03)-$(deriveBoth defaultOptions{ allNullaryToStringTag = True } ''Simple04) -$(deriveBoth defaultOptions{ allNullaryToStringTag = False, fieldLabelModifier = drop 4 } ''SimpleRecord01)-$(deriveBoth defaultOptions{ allNullaryToStringTag = False, fieldLabelModifier = drop 4 } ''SimpleRecord02)-$(deriveBoth defaultOptions{ allNullaryToStringTag = True , fieldLabelModifier = drop 4 } ''SimpleRecord03)-$(deriveBoth defaultOptions{ allNullaryToStringTag = True , fieldLabelModifier = drop 4 } ''SimpleRecord04)-#endif+$(deriveBoth defaultOptions{ sumEncoding = UntaggedValue } ''SumUntagged) instance Arbitrary a => Arbitrary (Record1 a) where arbitrary = Record1 <$> arbitrary <*> fmap Just arbitrary <*> arbitrary <*> fmap Just arbitrary@@ -116,6 +109,8 @@ instance Arbitrary a => Arbitrary (SimpleRecord03 a) where arbitrary = SimpleRecord03 <$> arbitrary instance Arbitrary a => Arbitrary (SimpleRecord04 a) where arbitrary = SimpleRecord04 <$> arbitrary +instance Arbitrary a => Arbitrary (SumUntagged a) where arbitrary = oneof [ SMInt <$> arbitrary, SMList <$> arbitrary ]+ elmModuleContent :: String elmModuleContent = unlines [ "-- This module requires the following packages:"@@ -130,12 +125,8 @@ , "import Json.Helpers exposing (..)" , "import Test exposing (..)" , "import Expect exposing (..)"- , "import Test.Runner.Html" , "import String" , ""- , "main : Test.Runner.Html.TestProgram"- , "main = Test.Runner.Html.run <| concat [ sumEncode, sumDecode, recordDecode, recordEncode, simpleEncode, simpleDecode ]"- , "" , "recordDecode : Test" , "recordDecode = describe \"Record decoding checks\"" , " [ recordDecode1"@@ -162,6 +153,7 @@ , " , sumDecode10" , " , sumDecode11" , " , sumDecode12"+ , " , sumDecodeUntagged" , " ]" , "" , "sumEncode : Test"@@ -178,6 +170,7 @@ , " , sumEncode10" , " , sumEncode11" , " , sumEncode12"+ , " , sumEncodeUntagged" , " ]" , "" , "simpleDecode : Test"@@ -233,6 +226,7 @@ , DefineElm (Proxy :: Proxy (SimpleRecord02 a)) , DefineElm (Proxy :: Proxy (SimpleRecord03 a)) , DefineElm (Proxy :: Proxy (SimpleRecord04 a))+ , DefineElm (Proxy :: Proxy (SumUntagged a)) ] ] @@ -314,6 +308,7 @@ sr02 <- sample' arbitrary :: IO [SimpleRecord02 [Int]] sr03 <- sample' arbitrary :: IO [SimpleRecord03 [Int]] sr04 <- sample' arbitrary :: IO [SimpleRecord04 [Int]]+ sm <- sample' arbitrary :: IO [SumUntagged [Int]] args <- getArgs case args of [] -> return ()@@ -363,5 +358,7 @@ , mkSimpleRecordDecodeTest "02" sr02 , mkSimpleRecordDecodeTest "03" sr03 , mkSimpleRecordDecodeTest "04" sr04+ , mkSumEncodeTest "Untagged" sm+ , mkSumDecodeTest "Untagged" sm ]