elm-bridge 0.4.2 → 0.4.3
raw patch · 8 files changed
+284/−97 lines, 8 filesdep −hspec-discoverdep ~basePVP ok
version bump matches the API change (PVP)
Dependencies removed: hspec-discover
Dependency ranges changed: base
API changes (from Hackage documentation)
Files
- elm-bridge.cabal +7/−8
- src/Elm/Derive.hs +11/−16
- src/Elm/Json.hs +3/−2
- src/Elm/Module.hs +1/−0
- test/Elm/DeriveSpec.hs +3/−3
- test/Elm/JsonSpec.hs +88/−12
- test/EndToEnd.hs +156/−55
- test/Spec.hs +15/−1
elm-bridge.cabal view
@@ -1,10 +1,9 @@ name: elm-bridge-version: 0.4.2-synopsis: Derive Elm types and Json code from Haskell types+version: 0.4.3+synopsis: Derive Elm types and Json code from Haskell types, using aeson's options description: Building the bridge from Haskell to Elm and back. Define types once,- use on both sides and enjoy easy (de)serialisation. Cheers!-- This module only supports Elm 0.18. Version 0.3.* supports both Elm 0.16 and Elm 0.17.+ and derive the aeson and elm functions at the same time, using any aeson+ option you like. Cheers! homepage: https://github.com/agrafix/elm-bridge license: BSD3 license-file: LICENSE@@ -14,7 +13,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+tested-with: GHC==8.4.1, GHC==8.2.2, GHC==8.0.2 extra-source-files: README.md@@ -33,7 +32,7 @@ Elm.TyRep Elm.Versions other-modules: Elm.Utils- build-depends: base >= 4.7 && < 5,+ build-depends: base >= 4.9 && < 5, template-haskell, aeson >= 1 default-language: Haskell2010@@ -48,6 +47,7 @@ containers, QuickCheck, text+ ghc-options: -O0 default-language: Haskell2010 test-suite derive-elm-tests@@ -62,7 +62,6 @@ build-depends: base, hspec >= 2.0,- hspec-discover, elm-bridge, aeson, containers
src/Elm/Derive.hs view
@@ -47,7 +47,7 @@ , A.constructorTagModifier = id , A.allNullaryToStringTag = True , A.omitNothingFields = False- , A.unwrapUnaryRecords = False+ , A.unwrapUnaryRecords = True } unwrapUnaryRecords :: A.Options -> Bool@@ -125,10 +125,10 @@ PlainTV tv -> tv KindedTV tv _ -> tv -deriveAlias :: A.Options -> Name -> [TyVarBndr] -> [VarStrictType] -> Q [Dec]-deriveAlias opts name vars conFields =+deriveAlias :: Bool -> A.Options -> Name -> [TyVarBndr] -> [VarStrictType] -> Q [Dec]+deriveAlias isNewtype opts name vars conFields = runDerive name vars $ \typeName ->- [|ETypeAlias (EAlias $typeName $fields omitNothing False unwrapUnary)|] -- default to no newtype+ [|ETypeAlias (EAlias $typeName $fields omitNothing isNewtype unwrapUnary)|] -- default to no newtype where unwrapUnary = unwrapUnaryRecords opts fields = listE $ map mkField conFields@@ -184,22 +184,17 @@ deriveElmDef opts name = do TyConI tyCon <- reify name case tyCon of-#if __GLASGOW_HASKELL__ >= 800 DataD _ _ tyVars _ constrs _ ->-#else- DataD _ _ tyVars constrs _ ->-#endif- case constrs of [] -> fail "Can not derive empty data decls"- [RecC _ conFields] -> deriveAlias opts name tyVars conFields+ [RecC _ conFields] -> deriveAlias False opts name tyVars conFields _ -> deriveSum opts name tyVars constrs-#if __GLASGOW_HASKELL__ >= 800- NewtypeD _ _ tyVars _ (RecC _ conFields) _ ->-#else- NewtypeD _ _ tyVars (RecC _ conFields) _ ->-#endif- deriveAlias opts name tyVars conFields+ NewtypeD [] _ [] Nothing (NormalC _ [(Bang NoSourceUnpackedness NoSourceStrictness, otherTy)]) [] ->+ deriveSynonym opts name [] otherTy+ NewtypeD [] _ [] Nothing (RecC _ conFields@[(Name (OccName _) _, Bang NoSourceUnpackedness NoSourceStrictness, otherTy)]) [] ->+ if A.unwrapUnaryRecords opts+ then deriveSynonym opts name [] otherTy+ else deriveAlias True opts name [] conFields TySynD _ vars otherTy -> deriveSynonym opts name vars otherTy _ -> fail ("Oops, can only derive data and newtype, not this: " ++ show tyCon)
src/Elm/Json.hs view
@@ -92,7 +92,7 @@ ETypePrimAlias (EPrimAlias name ty) -> unlines [ decoderType name , makeName name ++ " ="- , jsonParserForType ty+ , " " ++ jsonParserForType ty ] ETypeAlias (EAlias name fields _ newtyping unwrap) -> unlines ( decoderType name@@ -124,7 +124,8 @@ 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) ++ "]")+ TaggedObject _ _+ | length opts > 1 -> "\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) = lazy $ "Json.Decode.map "
src/Elm/Module.hs view
@@ -110,6 +110,7 @@ ETyApp (ETyApp (ETyCon (ETCon "THashMap")) k) v -> checkMap k v ETyApp (ETyApp (ETyCon (ETCon "Map")) k) v -> checkMap k v ETyCon (ETCon "Integer") -> ETyCon (ETCon "Int")+ ETyCon (ETCon "Natural") -> ETyCon (ETCon "Int") ETyCon (ETCon "Text") -> ETyCon (ETCon "String") ETyCon (ETCon "Vector") -> ETyCon (ETCon "List") ETyCon (ETCon "Double") -> ETyCon (ETCon "Float")
test/Elm/DeriveSpec.hs view
@@ -59,7 +59,7 @@ ] , ea_omit_null = False , ea_newtype = False- , ea_unwrap_unary = False+ , ea_unwrap_unary = True } fooElm :: ETypeDef@@ -75,7 +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+ , ea_unwrap_unary = True } barElm :: ETypeDef@@ -95,7 +95,7 @@ ] , ea_omit_null = False , ea_newtype = False- , ea_unwrap_unary = False+ , ea_unwrap_unary = True } bazElm :: ETypeDef
test/Elm/JsonSpec.hs view
@@ -8,8 +8,9 @@ import Data.Proxy import Test.Hspec import Data.Char (toLower)-import Data.Aeson.Types (SumEncoding(..))+import Data.Aeson.Types (SumEncoding(..),defaultTaggedObject) import qualified Data.Map.Strict as M+import qualified Data.Aeson.TH as TH data Foo = Foo@@ -42,10 +43,16 @@ , _t2 :: Change a } --- TODO-data Qux a = Qux1 { _quxfoo :: Int, _quxqux :: a }- | Qux2 Int (M.Map Int 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 }+ $(deriveElmDef (defaultOptionsDropLower 2) ''Foo) $(deriveElmDef (defaultOptionsDropLower 2) ''Bar) $(deriveElmDef (defaultOptionsDropLower 1) ''TestComp)@@ -53,7 +60,13 @@ $(deriveElmDef defaultOptions{ allNullaryToStringTag = False } ''UnaryA) $(deriveElmDef defaultOptions{ allNullaryToStringTag = True } ''UnaryB) $(deriveElmDef defaultOptions { fieldLabelModifier = drop 1 . map toLower } ''Baz)-$(deriveElmDef defaultOptions { fieldLabelModifier = drop 4 . map toLower, sumEncoding = TaggedObject "tag" "value" } ''Qux)+$(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) 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"@@ -113,12 +126,6 @@ , " in decodeSumObjectWithSingleField \"Baz\" jsonDecDictBaz" ] -quxParse :: String-quxParse = unlines- [ "jsonDecQux localDecoder_a ="- , " "- ]- someOptsParse :: String someOptsParse = unlines [ "jsonDecSomeOpts : Json.Decode.Decoder a -> Json.Decode.Decoder ( SomeOpts a )"@@ -187,17 +194,76 @@ , " 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 ="+ , " (\"getNtd\" := Json.Decode.int) >>= \\pgetNtd ->"+ , " Json.Decode.succeed (NTD {getNtd = pgetNtd})"+ ]+ 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))- rQux = compileElmDef (Proxy :: Proxy (Qux 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) it "should produce the correct ser code" $ do jsonSerForDef rFoo `shouldBe` fooSer jsonSerForDef rBar `shouldBe` barSer@@ -216,3 +282,13 @@ 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
test/EndToEnd.hs view
@@ -13,6 +13,7 @@ import Control.Applicative import System.Environment import Data.Char (toLower)+import Data.List (stripPrefix) import Prelude data Record1 a = Record1 { _r1foo :: Int, _r1bar :: Maybe Int, _r1baz :: a, _r1qux :: Maybe a } deriving Show@@ -43,6 +44,112 @@ data SumUntagged a = SMInt Int | SMList a deriving Show +newtype NT1 = NT1 [Int] deriving Show+newtype NT2 = NT2 { _nt2foo :: [Int] } deriving Show+newtype NT3 = NT3 [Int] deriving Show+newtype NT4 = NT4 { _nt4foo :: [Int] } deriving Show++extractNT1 :: NT1 -> [Int]+extractNT1 (NT1 x) =x+extractNT2 :: NT2 -> [Int]+extractNT2 (NT2 x) =x+extractNT3 :: NT3 -> [Int]+extractNT3 (NT3 x) =x++dropAll :: String -> String -> String+dropAll needle haystack+ = case stripPrefix needle haystack of+ Just nxt -> dropAll needle nxt+ Nothing -> case haystack of+ [] -> []+ (x:xs) -> x : dropAll needle xs+++mkDecodeTest :: (Show a, ToJSON a) => String -> String -> String -> [a] -> String+mkDecodeTest pred prefix num elems = unlines (+ [ map toLower pred ++ "Decode" ++ num ++ " : Test"+ , map toLower pred ++ "Decode" ++ num ++ " = describe \"" ++ pred ++ " decode " ++ num ++ "\""+ ]+ ++ map mktest (zip ([1..] :: [Int]) elems)+ ++ [" ]"]+ )+ where+ mktest (n,e) = pfix ++ "test \"" ++ show n ++ "\" (\\_ -> equal (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)+ pfix = if n == 1 then " [ " else " , "++mkDecodeTestNT :: ToJSON n => String -> String -> String -> (n -> [Int]) -> [n] -> String+mkDecodeTestNT pred prefix num extract elems = unlines (+ [ map toLower pred ++ "Decode" ++ num ++ " : Test"+ , map toLower pred ++ "Decode" ++ num ++ " = describe \"" ++ pred ++ " decode " ++ num ++ "\""+ ]+ ++ map mktest (zip ([1..] :: [Int]) elems)+ ++ [" ]"]+ )+ where+ mktest (n,e) = pfix ++ "test \"" ++ show n ++ "\" (\\_ -> equal (Ok (" ++ pretty ++ ")) (Json.Decode.decodeString jsonDec" ++ pred ++ num ++ " " ++ encoded ++ "))"+ where+ pretty = T.unpack $ T.replace (T.pack (prefix ++ num)) T.empty $ T.pack $ show (extract e)+ encoded = show (encode e)+ pfix = if n == 1 then " [ " else " , "++mkSumDecodeTest :: (Show a, ToJSON a) => String -> [a] -> String+mkSumDecodeTest = mkDecodeTest "Sum" "_s"++mkRecordDecodeTest :: (Show a, ToJSON a) => String -> [a] -> String+mkRecordDecodeTest = mkDecodeTest "Record" "_r"++mkEncodeTest :: (Show a, ToJSON a) => String -> String -> String -> [a] -> String+mkEncodeTest pred prefix num elems = unlines (+ [ map toLower pred ++ "Encode" ++ num ++ " : Test"+ , map toLower pred ++ "Encode" ++ num ++ " = describe \"" ++ pred ++ " encode " ++ num ++ "\""+ ]+ ++ map mktest (zip ([1..] :: [Int]) elems)+ ++ [" ]"]+ )+ where+ mktest (n,e) = pfix ++ "test \"" ++ show n ++ "\" (\\_ -> equalHack " ++ 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)+ pfix = if n == 1 then " [ " else " , "++mkEncodeTestNT :: (Show a, ToJSON n) => String -> String -> String -> (n -> a) -> [n] -> String+mkEncodeTestNT pred prefix num extract elems = unlines (+ [ map toLower pred ++ "Encode" ++ num ++ " : Test"+ , map toLower pred ++ "Encode" ++ num ++ " = describe \"" ++ pred ++ " encode " ++ num ++ "\""+ ]+ ++ map mktest (zip ([1..] :: [Int]) elems)+ ++ [" ]"]+ )+ where+ mktest (n,e) = pfix ++ "test \"" ++ show n ++ "\" (\\_ -> equalHack " ++ encoded ++ "(Json.Encode.encode 0 (jsonEnc" ++ pred ++ num ++ " (" ++ pretty ++ "))))"+ where+ pretty = T.unpack $ T.replace (T.pack (prefix ++ num)) T.empty $ T.pack $ show (extract e)+ encoded = show (encode e)+ pfix = if n == 1 then " [ " else " , "++mkSumEncodeTest :: (Show a, ToJSON a) => String -> [a] -> String+mkSumEncodeTest = mkEncodeTest "Sum" "_s"++mkRecordEncodeTest :: (Show a, ToJSON a) => String -> [a] -> String+mkRecordEncodeTest = mkEncodeTest "Record" "_r"++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"++ $(deriveBoth defaultOptions{ fieldLabelModifier = drop 3, omitNothingFields = False } ''Record1) $(deriveBoth defaultOptions{ fieldLabelModifier = drop 3, omitNothingFields = True } ''Record2) @@ -73,6 +180,11 @@ $(deriveBoth defaultOptions{ sumEncoding = UntaggedValue } ''SumUntagged) +$(deriveBoth defaultOptions ''NT1)+$(deriveBoth defaultOptions { fieldLabelModifier = drop 4 } ''NT2)+$(deriveBoth defaultOptions { unwrapUnaryRecords = False }''NT3)+$(deriveBoth defaultOptions { fieldLabelModifier = drop 4, unwrapUnaryRecords = False } ''NT4)+ instance Arbitrary a => Arbitrary (Record1 a) where arbitrary = Record1 <$> arbitrary <*> fmap Just arbitrary <*> arbitrary <*> fmap Just arbitrary instance Arbitrary a => Arbitrary (Record2 a) where@@ -111,10 +223,16 @@ instance Arbitrary a => Arbitrary (SumUntagged a) where arbitrary = oneof [ SMInt <$> arbitrary, SMList <$> arbitrary ] +instance Arbitrary NT1 where arbitrary = fmap NT1 arbitrary+instance Arbitrary NT2 where arbitrary = fmap NT2 arbitrary+instance Arbitrary NT3 where arbitrary = fmap NT3 arbitrary+instance Arbitrary NT4 where arbitrary = fmap NT4 arbitrary+ elmModuleContent :: String elmModuleContent = unlines [ "-- This module requires the following packages:" , "-- * elm-community/elm-test"+ , "-- * elm-community/html-test-runner" , "-- * bartavelle/json-helpers" , "module MyTests exposing (..)" , ""@@ -126,7 +244,24 @@ , "import Test exposing (..)" , "import Expect exposing (..)" , "import String"+ , "import Test.Runner.Html" , ""+ , "newtypeDecode : Test"+ , "newtypeDecode = describe \"Newtype decoding checks\""+ , " [ ntDecode1"+ , " , ntDecode2"+ , " , ntDecode3"+ , " , ntDecode4"+ , " ]"+ , ""+ , "newtypeEncode : Test"+ , "newtypeEncode = describe \"Newtype encoding checks\""+ , " [ ntEncode1"+ , " , ntEncode2"+ , " , ntEncode3"+ , " , ntEncode4"+ , " ]"+ , "" , "recordDecode : Test" , "recordDecode = describe \"Record decoding checks\"" , " [ recordDecode1"@@ -174,7 +309,7 @@ , " ]" , "" , "simpleDecode : Test"- , "simpleDecode = describe \"Simple records/types checks\""+ , "simpleDecode = describe \"Simple records/types decode checks\"" , " [ simpleDecode01" , " , simpleDecode02" , " , simpleDecode03"@@ -186,7 +321,7 @@ , " ]" , "" , "simpleEncode : Test"- , "simpleEncode = describe \"Simple records/types checks\""+ , "simpleEncode = describe \"Simple records/types encode checks\"" , " [ simpleEncode01" , " , simpleEncode02" , " , simpleEncode03"@@ -203,6 +338,9 @@ , " let remix = Json.Decode.decodeString Json.Decode.value" , " in equal (remix a) (remix b)" , ""+ , "main : Test.Runner.Html.TestProgram"+ , "main = concat [newtypeDecode, newtypeEncode, recordDecode, recordEncode, sumDecode, sumEncode, simpleDecode, simpleEncode ] |> Test.Runner.Html.run"+ , "" , makeModuleContentWithAlterations (newtypeAliases ["Record1", "Record2", "SimpleRecord01", "SimpleRecord02", "SimpleRecord03", "SimpleRecord04"] . defaultAlterations) [ DefineElm (Proxy :: Proxy (Record1 a)) , DefineElm (Proxy :: Proxy (Record2 a))@@ -227,63 +365,14 @@ , DefineElm (Proxy :: Proxy (SimpleRecord03 a)) , DefineElm (Proxy :: Proxy (SimpleRecord04 a)) , DefineElm (Proxy :: Proxy (SumUntagged a))+ , DefineElm (Proxy :: Proxy NT1)+ , DefineElm (Proxy :: Proxy NT2)+ , DefineElm (Proxy :: Proxy NT3)+ , DefineElm (Proxy :: Proxy NT4) ] ] -mkDecodeTest :: (Show a, ToJSON a) => String -> String -> String -> [a] -> String-mkDecodeTest pred prefix num elems = unlines (- [ map toLower pred ++ "Decode" ++ num ++ " : Test"- , map toLower pred ++ "Decode" ++ num ++ " = describe \"" ++ pred ++ " decode " ++ num ++ "\""- ]- ++ map mktest (zip ([1..] :: [Int]) elems)- ++ [" ]"]- )- where- mktest (n,e) = pfix ++ "test \"" ++ show n ++ "\" (\\_ -> equal (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)- pfix = if n == 1 then " [ " else " , " -mkSumDecodeTest :: (Show a, ToJSON a) => String -> [a] -> String-mkSumDecodeTest = mkDecodeTest "Sum" "_s"--mkRecordDecodeTest :: (Show a, ToJSON a) => String -> [a] -> String-mkRecordDecodeTest = mkDecodeTest "Record" "_r"--mkEncodeTest :: (Show a, ToJSON a) => String -> String -> String -> [a] -> String-mkEncodeTest pred prefix num elems = unlines (- [ map toLower pred ++ "Encode" ++ num ++ " : Test"- , map toLower pred ++ "Encode" ++ num ++ " = describe \"" ++ pred ++ " encode " ++ num ++ "\""- ]- ++ map mktest (zip ([1..] :: [Int]) elems)- ++ [" ]"]- )- where- mktest (n,e) = pfix ++ "test \"" ++ show n ++ "\" (\\_ -> equalHack " ++ 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)- pfix = if n == 1 then " [ " else " , "--mkSumEncodeTest :: (Show a, ToJSON a) => String -> [a] -> String-mkSumEncodeTest = mkEncodeTest "Sum" "_s"--mkRecordEncodeTest :: (Show a, ToJSON a) => String -> [a] -> String-mkRecordEncodeTest = mkEncodeTest "Record" "_r"--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]]@@ -309,6 +398,10 @@ sr03 <- sample' arbitrary :: IO [SimpleRecord03 [Int]] sr04 <- sample' arbitrary :: IO [SimpleRecord04 [Int]] sm <- sample' arbitrary :: IO [SumUntagged [Int]]+ nt1 <- sample' arbitrary :: IO [NT1]+ nt2 <- sample' arbitrary :: IO [NT2]+ nt3 <- sample' arbitrary :: IO [NT3]+ nt4 <- sample' arbitrary :: IO [NT4] args <- getArgs case args of [] -> return ()@@ -360,5 +453,13 @@ , mkSimpleRecordDecodeTest "04" sr04 , mkSumEncodeTest "Untagged" sm , mkSumDecodeTest "Untagged" sm+ , mkDecodeTestNT "NT" "_nt" "1" extractNT1 nt1+ , mkEncodeTestNT "NT" "_nt" "1" extractNT1 nt1+ , mkDecodeTestNT "NT" "_nt" "2" extractNT2 nt2+ , mkEncodeTestNT "NT" "_nt" "2" extractNT2 nt2+ , mkDecodeTestNT "NT" "_nt" "3" extractNT3 nt3+ , mkEncodeTestNT "NT" "_nt" "3" extractNT3 nt3+ , dropAll "(Json.Decode.list Json.Decode.int)" (mkDecodeTest "NT" "_nt" "4" nt4)+ , dropAll "(Json.Encode.list << List.map Json.Encode.int)" (mkEncodeTest "NT" "_nt" "4" nt4) ]
test/Spec.hs view
@@ -1,1 +1,15 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+module Main where++import qualified Elm.DeriveSpec+import qualified Elm.TyRenderSpec+import qualified Elm.JsonSpec+import qualified Elm.ModuleSpec++import Test.Hspec++main :: IO ()+main = hspec $ do+ describe "Elm.DeriveSpec" Elm.DeriveSpec.spec+ describe "Elm.TyRenderSpec" Elm.TyRenderSpec.spec+ describe "Elm.JsonSpec" Elm.JsonSpec.spec+ describe "Elm.ModuleSpec" Elm.ModuleSpec.spec