elm-bridge 0.8.0 → 0.8.1
raw patch · 5 files changed
+52/−16 lines, 5 files
Files
- elm-bridge.cabal +1/−1
- src/Elm/Json.hs +20/−14
- src/Elm/TyRender.hs +1/−1
- src/Elm/TyRep.hs +5/−0
- test/EndToEnd.hs +25/−0
elm-bridge.cabal view
@@ -1,5 +1,5 @@ name: elm-bridge-version: 0.8.0+version: 0.8.1 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, and derive the aeson and elm functions at the same time, using any aeson
src/Elm/Json.hs view
@@ -128,7 +128,12 @@ 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 _ _- | length opts > 1 -> "\n" ++ tab 8 (isObjectSetName ++ " = " ++ "Set.fromList [" ++ intercalate ", " (map (show . _stcName) $ filter (isNamed . _stcFields) opts) ++ "]")+ | length opts > 1 ->+ "\n" ++ tab 8 (isObjectSetName ++ " = " ++ "Set.fromList [" ++ intercalate ", " objectSet ++ "]")+ where objectSet =+ (map (show . _stcName) $ filter (isNamed . _stcFields) opts) +++ -- if field is empty, it do not have content, so add to objectSet.+ (map (show . _stcName) $ filter (isEmpty . _stcFields) opts) _ -> "" dictEntry (STC cname oname args) = "(" ++ show oname ++ ", " ++ mkDecoder cname args ++ ")" mkDecoder cname (Named args) = lazy $ "Json.Decode.map "@@ -161,10 +166,10 @@ The 'omitNothingFields' option is currently not implemented! -} jsonSerForType :: EType -> String-jsonSerForType = jsonSerForType' False+jsonSerForType = jsonSerForType' False [1..] -jsonSerForType' :: Bool -> EType -> String-jsonSerForType' omitnull ty =+jsonSerForType' :: Bool -> [Int] -> EType -> String+jsonSerForType' omitnull ns ty = case ty of ETyVar (ETVar v) -> "localEncoder_" ++ v ETyCon (ETCon "Int") -> "Json.Encode.int"@@ -172,28 +177,29 @@ ETyCon (ETCon "String") -> "Json.Encode.string" ETyCon (ETCon "Bool") -> "Json.Encode.bool" ETyCon (ETCon c) -> "jsonEnc" ++ c- ETyApp (ETyCon (ETCon "List")) t' -> "(Json.Encode.list " ++ jsonSerForType t' ++ ")"+ ETyApp (ETyCon (ETCon "List")) t' -> "(Json.Encode.list " ++ jsonSerForType' omitnull ns t' ++ ")" ETyApp (ETyCon (ETCon "Maybe")) t' -> if omitnull- then jsonSerForType t'- else "(maybeEncode (" ++ jsonSerForType t' ++ "))"- ETyApp (ETyCon (ETCon "Set")) t' -> "(encodeSet " ++ jsonSerForType t' ++ ")"- ETyApp (ETyApp (ETyCon (ETCon "Dict")) (ETyCon (ETCon "String"))) value -> "(Json.Encode.dict identity (" ++ jsonSerForType value ++ "))"- ETyApp (ETyApp (ETyCon (ETCon "Dict")) key) value -> "(encodeMap (" ++ jsonSerForType key ++ ") (" ++ jsonSerForType value ++ "))"+ then jsonSerForType' omitnull ns t'+ else "(maybeEncode (" ++ jsonSerForType' omitnull ns t' ++ "))"+ ETyApp (ETyCon (ETCon "Set")) t' -> "(encodeSet " ++ jsonSerForType' omitnull ns t' ++ ")"+ ETyApp (ETyApp (ETyCon (ETCon "Dict")) (ETyCon (ETCon "String"))) value -> "(Json.Encode.dict identity (" ++ jsonSerForType' omitnull ns value ++ "))"+ ETyApp (ETyApp (ETyCon (ETCon "Dict")) key) value -> "(encodeMap (" ++ jsonSerForType' omitnull ns key ++ ") (" ++ jsonSerForType' omitnull ns value ++ "))" _ -> case unpackTupleType ty of [] -> error $ "This should never happen. Failed to unpackTupleType: " ++ show ty [x] -> case unpackToplevelConstr x of (y : ys) ->- "(" ++ jsonSerForType y ++ " "- ++ unwords (map (\t' -> "(" ++ jsonSerForType t' ++ ")") ys)+ "(" ++ jsonSerForType' omitnull ns y ++ " "+ ++ unwords (map (\t' -> "(" ++ jsonSerForType' omitnull ns t' ++ ")") ys) ++ ")" _ -> error $ "Do suitable json serialiser found for " ++ show ty xs ->- let tupleArgsV = zip xs ([1..] :: [Int])+ let (ns', rest) = splitAt (length xs) ns+ tupleArgsV = zip xs ns' tupleArgs = intercalate "," $ map (\(_, v) -> "t" ++ show v) tupleArgsV- in "(\\(" ++ tupleArgs ++ ") -> Json.Encode.list identity [" ++ intercalate "," (map (\(t', idx) -> "(" ++ jsonSerForType t' ++ ") t" ++ show idx) tupleArgsV) ++ "])"+ in "(\\(" ++ tupleArgs ++ ") -> Json.Encode.list identity [" ++ intercalate "," (map (\(t', idx) -> "(" ++ jsonSerForType' omitnull rest t' ++ ") t" ++ show idx) tupleArgsV) ++ "])" -- | Compile a JSON serializer for an Elm type definition
src/Elm/TyRender.hs view
@@ -20,7 +20,7 @@ renderElm ty = case unpackTupleType ty of [t] -> renderSingleTy t- xs -> "(" ++ intercalate ", " (map renderSingleTy xs) ++ ")"+ xs -> "(" ++ intercalate ", " (map renderElm xs) ++ ")" where renderApp (ETyApp l r) = renderApp l ++ " " ++ renderElm r renderApp x = renderElm x
src/Elm/TyRep.hs view
@@ -82,6 +82,11 @@ Named _ -> True _ -> False +isEmpty :: SumTypeFields -> Bool+isEmpty (Anonymous []) = True+isEmpty (Named []) = True+isEmpty _ = False+ data SumTypeConstructor = STC { _stcName :: String
test/EndToEnd.hs view
@@ -19,6 +19,7 @@ data Record1 a = Record1 { _r1foo :: Int, _r1bar :: Maybe Int, _r1baz :: a, _r1qux :: Maybe a, _r1jmap :: M.Map String Int } deriving Show data Record2 a = Record2 { _r2foo :: Int, _r2bar :: Maybe Int, _r2baz :: a, _r2qux :: Maybe a } deriving Show+data RecordNestTuple a = RecordNestTuple (a, (a, a)) deriving Show data Sum01 a = Sum01A a | Sum01B (Maybe a) | Sum01C a a | Sum01D { _s01foo :: a } | Sum01E { _s01bar :: Int, _s01baz :: Int } deriving Show data Sum02 a = Sum02A a | Sum02B (Maybe a) | Sum02C a a | Sum02D { _s02foo :: a } | Sum02E { _s02bar :: Int, _s02baz :: Int } deriving Show@@ -45,6 +46,9 @@ data SumUntagged a = SMInt Int | SMList a deriving Show +-- | It include unit, and non single field.+data SumIncludeUnit a = SumIncludeUnitZero | SumIncludeUnitOne a | SumIncludeUnitTwo a a deriving Show+ newtype NT1 = NT1 [Int] deriving Show newtype NT2 = NT2 { _nt2foo :: [Int] } deriving Show newtype NT3 = NT3 [Int] deriving Show@@ -153,6 +157,7 @@ $(deriveBoth defaultOptions{ fieldLabelModifier = drop 3, omitNothingFields = False } ''Record1) $(deriveBoth defaultOptions{ fieldLabelModifier = drop 3, omitNothingFields = True } ''Record2)+$(deriveBoth defaultOptions ''RecordNestTuple) $(deriveBoth defaultOptions{ fieldLabelModifier = drop 4, omitNothingFields = False, allNullaryToStringTag = False, sumEncoding = TaggedObject "tag" "content" } ''Sum01) $(deriveBoth defaultOptions{ fieldLabelModifier = drop 4, omitNothingFields = True , allNullaryToStringTag = False, sumEncoding = TaggedObject "tag" "content" } ''Sum02)@@ -181,6 +186,9 @@ $(deriveBoth defaultOptions{ sumEncoding = UntaggedValue } ''SumUntagged) +-- servant-elm use TaggedObject.+$(deriveBoth defaultOptions{ fieldLabelModifier = drop 14, sumEncoding = TaggedObject "tag" "content" } ''SumIncludeUnit)+ $(deriveBoth defaultOptions ''NT1) $(deriveBoth defaultOptions { fieldLabelModifier = drop 4 } ''NT2) $(deriveBoth defaultOptions { unwrapUnaryRecords = False }''NT3)@@ -200,6 +208,8 @@ , c5 <$> arbitrary <*> arbitrary ] +instance Arbitrary a => Arbitrary (RecordNestTuple a) where+ arbitrary = (\x y z -> RecordNestTuple (x, (y, z))) <$> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary a => Arbitrary (Sum01 a) where arbitrary = arb Sum01A Sum01B Sum01C Sum01D Sum01E instance Arbitrary a => Arbitrary (Sum02 a) where arbitrary = arb Sum02A Sum02B Sum02C Sum02D Sum02E instance Arbitrary a => Arbitrary (Sum03 a) where arbitrary = arb Sum03A Sum03B Sum03C Sum03D Sum03E@@ -224,6 +234,9 @@ instance Arbitrary a => Arbitrary (SumUntagged a) where arbitrary = oneof [ SMInt <$> arbitrary, SMList <$> arbitrary ] +instance Arbitrary a => Arbitrary (SumIncludeUnit a) where+ arbitrary = oneof [ return SumIncludeUnitZero, SumIncludeUnitOne <$> arbitrary, SumIncludeUnitTwo <$> arbitrary <*> 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@@ -267,12 +280,14 @@ , "recordDecode = describe \"Record decoding checks\"" , " [ recordDecode1" , " , recordDecode2"+ , " , recordDecodeNestTuple" , " ]" , "" , "recordEncode : Test" , "recordEncode = describe \"Record encoding checks\"" , " [ recordEncode1" , " , recordEncode2"+ , " , recordEncodeNestTuple" , " ]" , "" , "sumDecode : Test"@@ -290,6 +305,7 @@ , " , sumDecode11" , " , sumDecode12" , " , sumDecodeUntagged"+ , " , sumDecodeIncludeUnit" , " ]" , "" , "sumEncode : Test"@@ -307,6 +323,7 @@ , " , sumEncode11" , " , sumEncode12" , " , sumEncodeUntagged"+ , " , sumEncodeIncludeUnit" , " ]" , "" , "simpleDecode : Test"@@ -343,6 +360,7 @@ , makeModuleContentWithAlterations (newtypeAliases ["Record1", "Record2", "SimpleRecord01", "SimpleRecord02", "SimpleRecord03", "SimpleRecord04"] . defaultAlterations) [ DefineElm (Proxy :: Proxy (Record1 a)) , DefineElm (Proxy :: Proxy (Record2 a))+ , DefineElm (Proxy :: Proxy (RecordNestTuple a)) , DefineElm (Proxy :: Proxy (Sum01 a)) , DefineElm (Proxy :: Proxy (Sum02 a)) , DefineElm (Proxy :: Proxy (Sum03 a))@@ -364,6 +382,7 @@ , DefineElm (Proxy :: Proxy (SimpleRecord03 a)) , DefineElm (Proxy :: Proxy (SimpleRecord04 a)) , DefineElm (Proxy :: Proxy (SumUntagged a))+ , DefineElm (Proxy :: Proxy (SumIncludeUnit a)) , DefineElm (Proxy :: Proxy NT1) , DefineElm (Proxy :: Proxy NT2) , DefineElm (Proxy :: Proxy NT3)@@ -388,6 +407,7 @@ ss12 <- sample' arbitrary :: IO [Sum12 [Int]] re01 <- sample' arbitrary :: IO [Record1 [Int]] re02 <- sample' arbitrary :: IO [Record2 [Int]]+ rent <- sample' arbitrary :: IO [RecordNestTuple [Int]] sp01 <- sample' arbitrary :: IO [Simple01 [Int]] sp02 <- sample' arbitrary :: IO [Simple02 [Int]] sp03 <- sample' arbitrary :: IO [Simple03 [Int]]@@ -397,6 +417,7 @@ sr03 <- sample' arbitrary :: IO [SimpleRecord03 [Int]] sr04 <- sample' arbitrary :: IO [SimpleRecord04 [Int]] sm <- sample' arbitrary :: IO [SumUntagged [Int]]+ smiu <- sample' arbitrary :: IO [SumIncludeUnit [Int]] nt1 <- sample' arbitrary :: IO [NT1] nt2 <- sample' arbitrary :: IO [NT2] nt3 <- sample' arbitrary :: IO [NT3]@@ -434,6 +455,8 @@ , mkRecordDecodeTest "2" re02 , mkRecordEncodeTest "1" re01 , mkRecordEncodeTest "2" re02+ , mkRecordDecodeTest "NestTuple" rent+ , mkRecordEncodeTest "NestTuple" rent , mkSimpleEncodeTest "01" sp01 , mkSimpleEncodeTest "02" sp02 , mkSimpleEncodeTest "03" sp03@@ -452,6 +475,8 @@ , mkSimpleRecordDecodeTest "04" sr04 , mkSumEncodeTest "Untagged" sm , mkSumDecodeTest "Untagged" sm+ , mkSumEncodeTest "IncludeUnit" smiu+ , mkSumDecodeTest "IncludeUnit" smiu , mkDecodeTestNT "NT" "_nt" "1" extractNT1 nt1 , mkEncodeTestNT "NT" "_nt" "1" extractNT1 nt1 , mkDecodeTestNT "NT" "_nt" "2" extractNT2 nt2