Merge pull request #56 from ncaq/fix-nest-tuple

fixed: avoid error when nested tuple

src/Elm/Json.hs

@@ -166,10 +166,10 @@ jsonParserForDef etd =
 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"
@@ -177,28 +177,29 @@ jsonSerForType' omitnull ty =
       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

@@ -20,7 +20,7 @@ instance ElmRenderable EType where
     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

test/EndToEnd.hs

@@ -19,6 +19,7 @@ import           Test.QuickCheck.Gen       (Gen, oneof, sample')
 
 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
@@ -156,6 +157,7 @@ mkSimpleEncodeTest = mkEncodeTest "Simple" "_s"
 
 $(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)
@@ -206,6 +208,8 @@ arb c1 c2 c3 c4 c5 = oneof
     , 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
@@ -276,12 +280,14 @@ elmModuleContent = unlines
     , "recordDecode = describe \"Record decoding checks\""
     , "              [ recordDecode1"
     , "              , recordDecode2"
+    , "              , recordDecodeNestTuple"
     , "              ]"
     , ""
     , "recordEncode : Test"
     , "recordEncode = describe \"Record encoding checks\""
     , "              [ recordEncode1"
     , "              , recordEncode2"
+    , "              , recordEncodeNestTuple"
     , "              ]"
     , ""
     , "sumDecode : Test"
@@ -354,6 +360,7 @@ elmModuleContent = unlines
     , 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))
@@ -400,6 +407,7 @@ main = do
     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]]
@@ -447,6 +455,8 @@ main = do
                        , mkRecordDecodeTest "2" re02
                        , mkRecordEncodeTest "1" re01
                        , mkRecordEncodeTest "2" re02
+                       , mkRecordDecodeTest "NestTuple" rent
+                       , mkRecordEncodeTest "NestTuple" rent
                        , mkSimpleEncodeTest "01" sp01
                        , mkSimpleEncodeTest "02" sp02
                        , mkSimpleEncodeTest "03" sp03