diff --git a/elm-bridge.cabal b/elm-bridge.cabal --- a/elm-bridge.cabal +++ b/elm-bridge.cabal @@ -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 diff --git a/src/Elm/Derive.hs b/src/Elm/Derive.hs --- a/src/Elm/Derive.hs +++ b/src/Elm/Derive.hs @@ -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) diff --git a/src/Elm/Json.hs b/src/Elm/Json.hs --- a/src/Elm/Json.hs +++ b/src/Elm/Json.hs @@ -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 " diff --git a/src/Elm/Module.hs b/src/Elm/Module.hs --- a/src/Elm/Module.hs +++ b/src/Elm/Module.hs @@ -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") diff --git a/test/Elm/DeriveSpec.hs b/test/Elm/DeriveSpec.hs --- a/test/Elm/DeriveSpec.hs +++ b/test/Elm/DeriveSpec.hs @@ -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 diff --git a/test/Elm/JsonSpec.hs b/test/Elm/JsonSpec.hs --- a/test/Elm/JsonSpec.hs +++ b/test/Elm/JsonSpec.hs @@ -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 diff --git a/test/EndToEnd.hs b/test/EndToEnd.hs --- a/test/EndToEnd.hs +++ b/test/EndToEnd.hs @@ -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) ] diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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