elm-bridge 0.2.1.1 → 0.2.2.0
raw patch · 11 files changed
+194/−57 lines, 11 files
Files
- CHANGELOG.md +9/−0
- LICENSE +1/−1
- README.md +10/−0
- elm-bridge.cabal +3/−3
- src/Elm/Derive.hs +10/−1
- src/Elm/Json.hs +30/−18
- src/Elm/Module.hs +2/−0
- src/Elm/TyRep.hs +1/−0
- test/Elm/DeriveSpec.hs +3/−0
- test/Elm/ModuleSpec.hs +10/−1
- test/EndToEnd.hs +115/−33
CHANGELOG.md view
@@ -1,3 +1,12 @@+# v0.2.2++## New features+ * The Elm JSON encoders and decoders now match `aeson` more closely. In partlicular, single constructor sum types are now encoded without+ the constructor. Also, the `aeson` 0.11 option `unwrapUnaryRecords` is now supported.++## Bugfixes+ * Fixed Elm type error in encoders for types like `[Map String v]` (0.2.1.2).+ # v0.2.1 ## New features
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2015 Alexander Thiemann <mail@athiemann.net>+Copyright (c) 2015 - 2016 Alexander Thiemann <mail@athiemann.net> and contributors All rights reserved.
README.md view
@@ -72,5 +72,15 @@ ## Install +### Haskell+ * Using cabal: `cabal install elm-bridge` * From Source: `git clone https://github.com/agrafix/elm-bridge.git && cd elm-bridge && cabal install`++### Elm++* `elm package install bartavelle/json-helpers`++## Contribute++Pull requests are welcome! Please consider creating an issue beforehand, so we can discuss what you would like to do. Code should be written in a consistent style throughout the project. Avoid whitespace that is sensible to conflicts. (E.g. alignment of `=` signs in functions definitions) Note that by sending a pull request you agree that your contribution can be released under the BSD3 License as part of the `elm-bridge` package or related packages.
elm-bridge.cabal view
@@ -1,14 +1,14 @@ name: elm-bridge-version: 0.2.1.1+version: 0.2.2.0 synopsis: Derive Elm types 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!-homepage: http://github.com/agrafix/elm-bridge+homepage: https://github.com/agrafix/elm-bridge license: BSD3 license-file: LICENSE author: Alexander Thiemann <mail@athiemann.net>, Simon Marechal <bartavelle@gmail.com> maintainer: Alexander Thiemann <mail@athiemann.net>-copyright: (c) 2015 Alexander Thiemann+copyright: (c) 2015 - 2016 Alexander Thiemann and contributors category: Web, Compiler, Language build-type: Simple cabal-version: >=1.10
src/Elm/Derive.hs view
@@ -50,6 +50,14 @@ #endif } +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. The first letter of the field is then converted to lowercase, ie:@@ -124,8 +132,9 @@ deriveAlias :: A.Options -> Name -> [TyVarBndr] -> [VarStrictType] -> Q [Dec] deriveAlias opts name vars conFields = runDerive name vars $ \typeName ->- [|ETypeAlias (EAlias $typeName $fields omitNothing False)|] -- default to no newtype+ [|ETypeAlias (EAlias $typeName $fields omitNothing False unwrapUnary)|] -- default to no newtype where+ unwrapUnary = unwrapUnaryRecords opts fields = listE $ map mkField conFields omitNothing = A.omitNothingFields opts mkField :: VarStrictType -> Q Exp
src/Elm/Json.hs view
@@ -61,17 +61,18 @@ in "Json.Decode.tuple" ++ show tupleLen ++ " (" ++ commas ++ ") " ++ unwords (map (\t' -> "(" ++ jsonParserForType t' ++ ")") xs) -parseRecords :: Maybe ETypeName -> [(String, EType)] -> [String]-parseRecords newtyped fields = map mkField fields ++ [" Json.Decode.succeed " ++ mkNewtype ("{" ++ intercalate ", " (map (\(fldName, _) -> fixReserved fldName ++ " = p" ++ fldName) fields) ++ "}")]+parseRecords :: Maybe ETypeName -> Bool -> [(String, EType)] -> [String]+parseRecords newtyped unwrap fields = map (mkField doUnwrap) fields ++ [" Json.Decode.succeed " ++ mkNewtype ("{" ++ intercalate ", " (map (\(fldName, _) -> fixReserved fldName ++ " = p" ++ fldName) fields) ++ "}")] where+ doUnwrap = length fields == 1 && unwrap mkNewtype x = case newtyped of Nothing -> x Just nm -> "(" ++ et_name nm ++ " " ++ x ++ ")"- mkField (fldName, fldType) =+ mkField u (fldName, fldType) = let (fldStart, fldEnd, mh) = if isOption fldType then ("(Json.Decode.maybe ", ")", Root) else ("", "", Leaf)- in " " ++ fldStart ++ "(\"" ++ fldName ++ "\" := "+ in " " ++ fldStart ++ "(" ++ (if u then "" else "\"" ++ fldName ++ "\" := ") ++ jsonParserForType' mh fldType ++ fldEnd ++ ") `Json.Decode.andThen` \\p" ++ fldName ++ " ->"@@ -93,21 +94,22 @@ , makeName name ++ " =" , jsonParserForType ty ]- ETypeAlias (EAlias name fields _ newtyping) -> unlines+ ETypeAlias (EAlias name fields _ newtyping unwrap) -> unlines ( decoderType name : (makeName name ++ " =")- : parseRecords (if newtyping then Just name else Nothing) fields+ : parseRecords (if newtyping then Just name else Nothing) unwrap fields ) ETypeSum (ESum name opts (SumEncoding' encodingType) _ unarystring) -> decoderType name ++ "\n" ++ makeName name ++ " =" ++ case allUnaries unarystring opts of Just names -> " " ++ deriveUnaries names- Nothing -> "\n" ++ encodingDictionnary ++ isObjectSet ++ "\n in " ++ declLine ++ "\n"+ Nothing -> "\n" ++ encodingDictionary opts ++ isObjectSet ++ "\n" ++ declLine opts ++ "\n" where tab n s = replicate n ' ' ++ s typename = et_name name- declLine = case encodingType of+ declLine [o] = ""+ declLine os = " 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 ]@@ -117,7 +119,8 @@ [ "decodeSumUnaries " ++ show typename ++ " " ++ dictName , dictName ++ " = Dict.fromList [" ++ intercalate ", " (map (\s -> "(" ++ show s ++ ", " ++ cap s ++ ")") strs ) ++ "]" ]- encodingDictionnary = tab 4 "let " ++ dictName ++ " = Dict.fromList\n" ++ tab 12 "[ " ++ intercalate ("\n" ++ replicate 12 ' ' ++ ", ") (map dictEntry opts) ++ "\n" ++ tab 12 "]"+ encodingDictionary [(oname, args)] = " " ++ mkDecoder oname args+ encodingDictionary os = tab 4 "let " ++ dictName ++ " = Dict.fromList\n" ++ tab 12 "[ " ++ intercalate ("\n" ++ replicate 12 ' ' ++ ", ") (map dictEntry os) ++ "\n" ++ tab 12 "]" isObjectSet = case encodingType of TaggedObject _ _ -> "\n" ++ tab 8 (isObjectSetName ++ " = " ++ "Set.fromList [" ++ intercalate ", " (map (show . fst) $ filter (isLeft . snd) opts) ++ "]") _ -> ""@@ -125,7 +128,7 @@ mkDecoder oname (Left args) = "Json.Decode.map " ++ cap oname ++ " ("- ++ unwords (parseRecords Nothing args)+ ++ unwords (parseRecords Nothing False args) ++ ")" mkDecoder oname (Right args) = unwords ( decodeFunction : cap oname@@ -163,7 +166,7 @@ then jsonSerForType t' else "(maybeEncode (" ++ jsonSerForType t' ++ "))" ETyApp (ETyCon (ETCon "Set")) t' -> "(encodeSet " ++ jsonSerForType t' ++ ")"- ETyApp (ETyApp (ETyCon (ETCon "Dict")) key) value -> "encodeMap (" ++ jsonSerForType key ++ ") (" ++ jsonSerForType value ++ ")"+ ETyApp (ETyApp (ETyCon (ETCon "Dict")) key) value -> "(encodeMap (" ++ jsonSerForType key ++ ") (" ++ jsonSerForType value ++ "))" _ -> case unpackTupleType ty of [] -> error $ "This should never happen. Failed to unpackTupleType: " ++ show ty@@ -188,23 +191,32 @@ case etd of ETypePrimAlias (EPrimAlias name ty) -> makeName name False ++ " = " ++ jsonSerForType ty ++ " val\n"- ETypeAlias (EAlias name fields _ newtyping) ->+ ETypeAlias (EAlias name [(fldName, fldType)] _ newtyping True) ->+ makeName name newtyping ++ " =\n " ++ jsonSerForType fldType ++ " val." ++ fixReserved fldName+ ETypeAlias (EAlias name fields _ newtyping _) -> makeName name newtyping ++ " =\n Json.Encode.object\n [" ++ intercalate "\n ," (map (\(fldName, fldType) -> " (\"" ++ fldName ++ "\", " ++ jsonSerForType fldType ++ " val." ++ fixReserved fldName ++ ")") fields) ++ "\n ]\n" ETypeSum (ESum name opts (SumEncoding' se) _ unarystring) -> case allUnaries unarystring opts of- Nothing -> defaultEncoding+ Nothing -> defaultEncoding opts Just strs -> unaryEncoding strs where encodeFunction = case se of ObjectWithSingleField -> "encodeSumObjectWithSingleField" TwoElemArray -> "encodeSumTwoElementArray" TaggedObject k c -> unwords ["encodeSumTaggedObject", show k, show c]- defaultEncoding = unlines (+ defaultEncoding [(oname, Right args)] = unlines $+ [ makeType name+ , fname name ++ " " + ++ unwords (map (\tv -> "localEncoder_" ++ tv_name tv) $ et_args name)+ ++ "(" ++ cap oname ++ " " ++ argList args ++ ") ="+ , " " ++ mkEncodeList args+ ]+ defaultEncoding os = unlines ( ( makeName name False ++ " =") : " let keyval v = case v of"- : (map (replicate 12 ' ' ++) (map mkcase opts))+ : (map (replicate 12 ' ' ++) (map mkcase os)) ++ [ " " ++ unwords ["in", encodeFunction, "keyval", "val"] ] ) unaryEncoding names = unlines (@@ -213,14 +225,14 @@ ] ++ map (\n -> replicate 8 ' ' ++ cap n ++ " -> Json.Encode.string " ++ show n) names ) mkcase :: (String, Either [(String, EType)] [EType]) -> String- mkcase (oname, Right args) = replicate 8 ' ' ++ cap oname ++ " " ++ argList args ++ " -> (" ++ show oname ++ ", " ++ mkEncodeList args ++ ")"+ mkcase (oname, Right args) = replicate 8 ' ' ++ cap oname ++ " " ++ argList args ++ " -> (" ++ show oname ++ ", encodeValue (" ++ mkEncodeList args ++ "))" mkcase (oname, Left args) = replicate 8 ' ' ++ cap oname ++ " vs -> (" ++ show oname ++ ", " ++ mkEncodeObject args ++ ")" argList a = unwords $ map (\i -> "v" ++ show i ) [1 .. length a] numargs :: (a -> String) -> [a] -> String numargs f = intercalate ", " . zipWith (\n a -> f a ++ " v" ++ show n) ([1..] :: [Int]) mkEncodeObject args = "encodeObject [" ++ intercalate ", " (map (\(n,t) -> "(" ++ show n ++ ", " ++ jsonSerForType t ++ " vs." ++ fixReserved n ++ ")") args) ++ "]"- mkEncodeList [arg] = "encodeValue (" ++ jsonSerForType arg ++ " v1)"- mkEncodeList args = "encodeValue (Json.Encode.list [" ++ numargs jsonSerForType args ++ "])"+ mkEncodeList [arg] = jsonSerForType arg ++ " v1"+ mkEncodeList args = "Json.Encode.list [" ++ numargs jsonSerForType args ++ "]" where fname name = "jsonEnc" ++ et_name name makeType name = fname name ++ " : " ++ intercalate " -> " (map (mkLocalEncoder . tv_name) (et_args name) ++ [unwords (et_name name : map tv_name (et_args name)) , "Value"])
src/Elm/Module.hs view
@@ -31,6 +31,8 @@ , "import Json.Encode exposing (Value)" , "-- The following module comes from bartavelle/json-helpers" , "import Json.Helpers exposing (..)"+ , "import Dict"+ , "import Set" , "" , "" ]) ++ makeModuleContent defs
src/Elm/TyRep.hs view
@@ -67,6 +67,7 @@ , ea_fields :: [(String, EType)] , ea_omit_null :: Bool , ea_newtype :: Bool+ , ea_unwrap_unary :: Bool } deriving (Show, Eq, Ord) data ESum
test/Elm/DeriveSpec.hs view
@@ -59,6 +59,7 @@ ] , ea_omit_null = False , ea_newtype = False+ , ea_unwrap_unary = False } fooElm :: ETypeDef@@ -74,6 +75,7 @@ [("f_name",ETyCon (ETCon {tc_name = "String"})),("f_blablub",ETyCon (ETCon {tc_name = "Int"}))] , ea_omit_null = False , ea_newtype = False+ , ea_unwrap_unary = False } barElm :: ETypeDef@@ -93,6 +95,7 @@ ] , ea_omit_null = False , ea_newtype = False+ , ea_unwrap_unary = False } bazElm :: ETypeDef
test/Elm/ModuleSpec.hs view
@@ -5,6 +5,7 @@ import Elm.Module +import Data.Map (Map) import Data.Proxy import Test.Hspec @@ -14,6 +15,7 @@ , b_blablub :: Int , b_tuple :: (Int, String) , b_list :: [Bool]+ , b_list_map :: [Map String Bool] } deriving (Show, Eq) data Qux a = Qux1 Int String@@ -32,6 +34,8 @@ , "import Json.Encode exposing (Value)" , "-- The following module comes from bartavelle/json-helpers" , "import Json.Helpers exposing (..)"+ , "import Dict"+ , "import Set" , "" , "" , "type alias Bar a ="@@ -39,6 +43,7 @@ , " , blablub: Int" , " , tuple: (Int, String)" , " , list: (List Bool)"+ , " , list_map: (List (Dict String Bool))" , " }" , "" , "jsonDecBar : Json.Decode.Decoder a -> Json.Decode.Decoder ( Bar a )"@@ -47,7 +52,8 @@ , " (\"blablub\" := Json.Decode.int) `Json.Decode.andThen` \\pblablub ->" , " (\"tuple\" := Json.Decode.tuple2 (,) (Json.Decode.int) (Json.Decode.string)) `Json.Decode.andThen` \\ptuple ->" , " (\"list\" := Json.Decode.list (Json.Decode.bool)) `Json.Decode.andThen` \\plist ->"- , " Json.Decode.succeed {name = pname, blablub = pblablub, tuple = ptuple, list = plist}"+ , " (\"list_map\" := Json.Decode.list (Json.Decode.dict (Json.Decode.bool))) `Json.Decode.andThen` \\plist_map ->"+ , " Json.Decode.succeed {name = pname, blablub = pblablub, tuple = ptuple, list = plist, list_map = plist_map}" , "" , "jsonEncBar : (a -> Value) -> Bar a -> Value" , "jsonEncBar localEncoder_a val ="@@ -56,6 +62,7 @@ , " , (\"blablub\", Json.Encode.int val.blablub)" , " , (\"tuple\", (\\(v1,v2) -> Json.Encode.list [(Json.Encode.int) v1,(Json.Encode.string) v2]) val.tuple)" , " , (\"list\", (Json.Encode.list << List.map Json.Encode.bool) val.list)"+ , " , (\"list_map\", (Json.Encode.list << List.map (encodeMap (Json.Encode.string) (Json.Encode.bool))) val.list_map)" , " ]" , "" ]@@ -69,6 +76,8 @@ , "import Json.Encode exposing (Value)" , "-- The following module comes from bartavelle/json-helpers" , "import Json.Helpers exposing (..)"+ , "import Dict"+ , "import Set" , "" , "" , "type Qux a ="
test/EndToEnd.hs view
@@ -30,6 +30,15 @@ data Sum11 a = Sum11A a | Sum11B (Maybe a) | Sum11C a a | Sum11D { _s11foo :: a } | Sum11E { _s11bar :: Int, _s11baz :: Int } deriving Show data Sum12 a = Sum12A a | Sum12B (Maybe a) | Sum12C a a | Sum12D { _s12foo :: a } | Sum12E { _s12bar :: Int, _s12baz :: Int } deriving Show +data Simple01 a = Simple01 a deriving Show+data Simple02 a = Simple02 a deriving Show+data Simple03 a = Simple03 a deriving Show+data Simple04 a = Simple04 a deriving Show+data SimpleRecord01 a = SimpleRecord01 { _s01qux :: a } deriving Show+data SimpleRecord02 a = SimpleRecord02 { _s02qux :: a } deriving Show+data SimpleRecord03 a = SimpleRecord03 { _s03qux :: a } deriving Show+data SimpleRecord04 a = SimpleRecord04 { _s04qux :: a } deriving Show+ $(deriveBoth defaultOptions{ fieldLabelModifier = drop 3, omitNothingFields = False } ''Record1) $(deriveBoth defaultOptions{ fieldLabelModifier = drop 3, omitNothingFields = True } ''Record2) @@ -48,6 +57,16 @@ $(deriveBoth defaultOptions{ fieldLabelModifier = drop 4, omitNothingFields = False, allNullaryToStringTag = True , sumEncoding = TwoElemArray } ''Sum11) $(deriveBoth defaultOptions{ fieldLabelModifier = drop 4, omitNothingFields = True , allNullaryToStringTag = True , sumEncoding = TwoElemArray } ''Sum12) +$(deriveBoth defaultOptions{ allNullaryToStringTag = False, unwrapUnaryRecords = False } ''Simple01)+$(deriveBoth defaultOptions{ allNullaryToStringTag = False, unwrapUnaryRecords = True } ''Simple02)+$(deriveBoth defaultOptions{ allNullaryToStringTag = True, unwrapUnaryRecords = False } ''Simple03)+$(deriveBoth defaultOptions{ allNullaryToStringTag = True, unwrapUnaryRecords = True } ''Simple04)++$(deriveBoth defaultOptions{ allNullaryToStringTag = False, unwrapUnaryRecords = False, fieldLabelModifier = drop 4 } ''SimpleRecord01)+$(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)+ instance Arbitrary a => Arbitrary (Record1 a) where arbitrary = Record1 <$> arbitrary <*> fmap Just arbitrary <*> arbitrary <*> fmap Just arbitrary instance Arbitrary a => Arbitrary (Record2 a) where@@ -75,6 +94,15 @@ instance Arbitrary a => Arbitrary (Sum11 a) where arbitrary = arb Sum11A Sum11B Sum11C Sum11D Sum11E instance Arbitrary a => Arbitrary (Sum12 a) where arbitrary = arb Sum12A Sum12B Sum12C Sum12D Sum12E +instance Arbitrary a => Arbitrary (Simple01 a) where arbitrary = Simple01 <$> arbitrary+instance Arbitrary a => Arbitrary (Simple02 a) where arbitrary = Simple02 <$> arbitrary+instance Arbitrary a => Arbitrary (Simple03 a) where arbitrary = Simple03 <$> arbitrary+instance Arbitrary a => Arbitrary (Simple04 a) where arbitrary = Simple04 <$> arbitrary+instance Arbitrary a => Arbitrary (SimpleRecord01 a) where arbitrary = SimpleRecord01 <$> arbitrary+instance Arbitrary a => Arbitrary (SimpleRecord02 a) where arbitrary = SimpleRecord02 <$> arbitrary+instance Arbitrary a => Arbitrary (SimpleRecord03 a) where arbitrary = SimpleRecord03 <$> arbitrary+instance Arbitrary a => Arbitrary (SimpleRecord04 a) where arbitrary = SimpleRecord04 <$> arbitrary+ elmModuleContent :: String elmModuleContent = unlines [ "-- This module requires the following packages:"@@ -92,7 +120,7 @@ , "import String" , "" , "main : Element"- , "main = elementRunner <| suite \"Testing\" [ sumEncode, sumDecode, recordDecode, recordEncode ]"+ , "main = elementRunner <| suite \"Testing\" [ sumEncode, sumDecode, recordDecode, recordEncode, simpleEncode, simpleDecode ]" , "" , "recordDecode : Test" , "recordDecode = suite \"Record decoding checks\""@@ -138,13 +166,37 @@ , " , sumEncode12" , " ]" , ""+ , "simpleDecode : Test"+ , "simpleDecode = suite \"Simple records/types checks\""+ , " [ simpleDecode01"+ , " , simpleDecode02"+ , " , simpleDecode03"+ , " , simpleDecode04"+ , " , simplerecordDecode01"+ , " , simplerecordDecode02"+ , " , simplerecordDecode03"+ , " , simplerecordDecode04"+ , " ]"+ , ""+ , "simpleEncode : Test"+ , "simpleEncode = suite \"Simple records/types checks\""+ , " [ simpleEncode01"+ , " , simpleEncode02"+ , " , simpleEncode03"+ , " , simpleEncode04"+ , " , simplerecordEncode01"+ , " , simplerecordEncode02"+ , " , simplerecordEncode03"+ , " , simplerecordEncode04"+ , " ]"+ , "" , "-- this is done to prevent artificial differences due to object ordering, this won't work with Maybe's though :(" , "assertEqualHack : String -> String -> Assertion" , "assertEqualHack a b =" , " let remix = Json.Decode.decodeString Json.Decode.value" , " in assertEqual (remix a) (remix b)" , ""- , makeModuleContentWithAlterations (newtypeAliases ["Record1", "Record2"] . defaultAlterations)+ , makeModuleContentWithAlterations (newtypeAliases ["Record1", "Record2", "SimpleRecord01", "SimpleRecord02", "SimpleRecord03", "SimpleRecord04"] . defaultAlterations) [ DefineElm (Proxy :: Proxy (Record1 a)) , DefineElm (Proxy :: Proxy (Record2 a)) , DefineElm (Proxy :: Proxy (Sum01 a))@@ -159,6 +211,14 @@ , DefineElm (Proxy :: Proxy (Sum10 a)) , DefineElm (Proxy :: Proxy (Sum11 a)) , DefineElm (Proxy :: Proxy (Sum12 a))+ , DefineElm (Proxy :: Proxy (Simple01 a))+ , DefineElm (Proxy :: Proxy (Simple02 a))+ , DefineElm (Proxy :: Proxy (Simple03 a))+ , DefineElm (Proxy :: Proxy (Simple04 a))+ , DefineElm (Proxy :: Proxy (SimpleRecord01 a))+ , DefineElm (Proxy :: Proxy (SimpleRecord02 a))+ , DefineElm (Proxy :: Proxy (SimpleRecord03 a))+ , DefineElm (Proxy :: Proxy (SimpleRecord04 a)) ] ] @@ -171,7 +231,7 @@ ++ [" ]"] ) where- mktest (n,e) = pfix ++ "test \"" ++ show n ++ "\" (assertEqual (Json.Decode.decodeString (jsonDec" ++ pred ++ num ++ " Json.Decode.int) " ++ encoded ++ ") (Ok (" ++ pretty ++ ")))"+ mktest (n,e) = pfix ++ "test \"" ++ show n ++ "\" (assertEqual (Ok (" ++ pretty ++ ")) (Json.Decode.decodeString (jsonDec" ++ pred ++ num ++ " (Json.Decode.list Json.Decode.int)) " ++ encoded ++ "))" where pretty = T.unpack $ T.replace (T.pack (prefix ++ num)) T.empty $ T.pack $ show e encoded = show (encode e)@@ -192,7 +252,7 @@ ++ [" ]"] ) where- mktest (n,e) = pfix ++ "test \"" ++ show n ++ "\" (assertEqualHack (Json.Encode.encode 0 (jsonEnc" ++ pred ++ num ++ " Json.Encode.int (" ++ pretty ++ "))) " ++ encoded ++ ")"+ mktest (n,e) = pfix ++ "test \"" ++ show n ++ "\" (assertEqualHack " ++ encoded ++ "(Json.Encode.encode 0 (jsonEnc" ++ pred ++ num ++ "(Json.Encode.list << List.map Json.Encode.int) (" ++ pretty ++ "))))" where pretty = T.unpack $ T.replace (T.pack (prefix ++ num)) T.empty $ T.pack $ show e encoded = show (encode e)@@ -203,37 +263,43 @@ mkRecordEncodeTest :: (Show a, ToJSON a) => String -> [a] -> String mkRecordEncodeTest = mkEncodeTest "Record" "_r"-{--mkSumEncodeTest num elems = unlines (- [ "sumEncode" ++ num ++ " : Test"- , "sumEncode" ++ num ++ " = suite \"sum encode " ++ num ++ "\""- ]- ++ map mktest (zip ([1..] :: [Int]) elems)- ++ [" ]"]- )- where- mktest (n,e) = prefix ++ "test \"" ++ show n ++ "\" (assertEqualHack (Json.Encode.encode 0 (jsonEncSum" ++ num ++ " Json.Encode.int (" ++ pretty ++ "))) " ++ encoded ++ ")"- where- pretty = T.unpack $ T.replace (T.pack ("_s" ++ num)) T.empty $ T.pack $ show e- encoded = show (encode e)- prefix = if n == 1 then " [ " else " , "--}++mkSimpleRecordDecodeTest :: (Show a, ToJSON a) => String -> [a] -> String+mkSimpleRecordDecodeTest = mkDecodeTest "SimpleRecord" "_s"++mkSimpleRecordEncodeTest :: (Show a, ToJSON a) => String -> [a] -> String+mkSimpleRecordEncodeTest = mkEncodeTest "SimpleRecord" "_s"++mkSimpleDecodeTest :: (Show a, ToJSON a) => String -> [a] -> String+mkSimpleDecodeTest = mkDecodeTest "Simple" "_s"++mkSimpleEncodeTest :: (Show a, ToJSON a) => String -> [a] -> String+mkSimpleEncodeTest = mkEncodeTest "Simple" "_s"+ main :: IO () main = do- ss01 <- sample' arbitrary :: IO [Sum01 Int]- ss02 <- sample' arbitrary :: IO [Sum02 Int]- ss03 <- sample' arbitrary :: IO [Sum03 Int]- ss04 <- sample' arbitrary :: IO [Sum04 Int]- ss05 <- sample' arbitrary :: IO [Sum05 Int]- ss06 <- sample' arbitrary :: IO [Sum06 Int]- ss07 <- sample' arbitrary :: IO [Sum07 Int]- ss08 <- sample' arbitrary :: IO [Sum08 Int]- ss09 <- sample' arbitrary :: IO [Sum09 Int]- ss10 <- sample' arbitrary :: IO [Sum10 Int]- ss11 <- sample' arbitrary :: IO [Sum11 Int]- ss12 <- sample' arbitrary :: IO [Sum12 Int]- re01 <- sample' arbitrary :: IO [Record1 Int]- re02 <- sample' arbitrary :: IO [Record2 Int]+ ss01 <- sample' arbitrary :: IO [Sum01 [Int]]+ ss02 <- sample' arbitrary :: IO [Sum02 [Int]]+ ss03 <- sample' arbitrary :: IO [Sum03 [Int]]+ ss04 <- sample' arbitrary :: IO [Sum04 [Int]]+ ss05 <- sample' arbitrary :: IO [Sum05 [Int]]+ ss06 <- sample' arbitrary :: IO [Sum06 [Int]]+ ss07 <- sample' arbitrary :: IO [Sum07 [Int]]+ ss08 <- sample' arbitrary :: IO [Sum08 [Int]]+ ss09 <- sample' arbitrary :: IO [Sum09 [Int]]+ ss10 <- sample' arbitrary :: IO [Sum10 [Int]]+ ss11 <- sample' arbitrary :: IO [Sum11 [Int]]+ ss12 <- sample' arbitrary :: IO [Sum12 [Int]]+ re01 <- sample' arbitrary :: IO [Record1 [Int]]+ re02 <- sample' arbitrary :: IO [Record2 [Int]]+ sp01 <- sample' arbitrary :: IO [Simple01 [Int]]+ sp02 <- sample' arbitrary :: IO [Simple02 [Int]]+ sp03 <- sample' arbitrary :: IO [Simple03 [Int]]+ sp04 <- sample' arbitrary :: IO [Simple04 [Int]]+ sr01 <- sample' arbitrary :: IO [SimpleRecord01 [Int]]+ sr02 <- sample' arbitrary :: IO [SimpleRecord02 [Int]]+ sr03 <- sample' arbitrary :: IO [SimpleRecord03 [Int]]+ sr04 <- sample' arbitrary :: IO [SimpleRecord04 [Int]] args <- getArgs case args of [] -> return ()@@ -267,5 +333,21 @@ , mkRecordDecodeTest "2" re02 , mkRecordEncodeTest "1" re01 , mkRecordEncodeTest "2" re02+ , mkSimpleEncodeTest "01" sp01+ , mkSimpleEncodeTest "02" sp02+ , mkSimpleEncodeTest "03" sp03+ , mkSimpleEncodeTest "04" sp04+ , mkSimpleDecodeTest "01" sp01+ , mkSimpleDecodeTest "02" sp02+ , mkSimpleDecodeTest "03" sp03+ , mkSimpleDecodeTest "04" sp04+ , mkSimpleRecordEncodeTest "01" sr01+ , mkSimpleRecordEncodeTest "02" sr02+ , mkSimpleRecordEncodeTest "03" sr03+ , mkSimpleRecordEncodeTest "04" sr04+ , mkSimpleRecordDecodeTest "01" sr01+ , mkSimpleRecordDecodeTest "02" sr02+ , mkSimpleRecordDecodeTest "03" sr03+ , mkSimpleRecordDecodeTest "04" sr04 ]