diff --git a/elm-bridge.cabal b/elm-bridge.cabal --- a/elm-bridge.cabal +++ b/elm-bridge.cabal @@ -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 diff --git a/src/Elm/Json.hs b/src/Elm/Json.hs --- a/src/Elm/Json.hs +++ b/src/Elm/Json.hs @@ -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 diff --git a/src/Elm/TyRender.hs b/src/Elm/TyRender.hs --- a/src/Elm/TyRender.hs +++ b/src/Elm/TyRender.hs @@ -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 diff --git a/src/Elm/TyRep.hs b/src/Elm/TyRep.hs --- a/src/Elm/TyRep.hs +++ b/src/Elm/TyRep.hs @@ -82,6 +82,11 @@ Named _ -> True _ -> False +isEmpty :: SumTypeFields -> Bool +isEmpty (Anonymous []) = True +isEmpty (Named []) = True +isEmpty _ = False + data SumTypeConstructor = STC { _stcName :: String diff --git a/test/EndToEnd.hs b/test/EndToEnd.hs --- a/test/EndToEnd.hs +++ b/test/EndToEnd.hs @@ -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