haskell: fix for empty constructor

haskell/msgpack.cabal

@@ -1,5 +1,5 @@
 Name:               msgpack
-Version:            0.4.0
+Version:            0.4.0.1
 Synopsis:           A Haskell binding to MessagePack
 Description:
   A Haskell binding to MessagePack <http://msgpack.org/>

haskell/src/Data/MessagePack/Derive.hs

@@ -7,6 +7,7 @@ module Data.MessagePack.Derive (
   ) where
 
 import Control.Applicative
+import Control.Monad
 import Language.Haskell.TH
 
 import Data.MessagePack.Pack
@@ -24,9 +25,9 @@ deriveUnpack typName = do
         
   where
     body (NormalC conName elms) =
-      DoE
+      DoE $
-      [ BindS (tupOrListP $ map VarP names) (VarE 'get)
+      tupOrListP (map VarP names) (VarE 'get) ++
-      , NoBindS $ AppE (VarE 'return) $ foldl AppE (ConE conName) $ map VarE names ]
+      [ NoBindS $ AppE (VarE 'return) $ foldl AppE (ConE conName) $ map VarE names ]
         where
           names = zipWith (\ix _ -> mkName $ "a" ++ show (ix :: Int)) [1..] elms
 
@@ -78,9 +79,9 @@ deriveObject typName = do
       toObjectBody (NormalC conName $ map (\(_, b, c) -> (b, c)) elms)
 
     tryFromObjectBody (NormalC conName elms) =
-      DoE
+      DoE $
-      [ BindS (tupOrListP $ map VarP names) (AppE (VarE 'tryFromObject) (VarE oname))
+      tupOrListP (map VarP names) (AppE (VarE 'tryFromObject) (VarE oname)) ++
-      , NoBindS $ AppE (VarE 'return) $ foldl AppE (ConE conName) $ map VarE names ]
+      [ NoBindS $ AppE (VarE 'return) $ foldl AppE (ConE conName) $ map VarE names ]
         where
           names = zipWith (\ix _ -> mkName $ "a" ++ show (ix :: Int)) [1..] elms
     tryFromObjectBody (RecC conName elms) =
@@ -89,12 +90,17 @@ deriveObject typName = do
     oname = mkName "o"
     ch = foldl1 (\e f -> AppE (AppE (VarE '(<|>)) e) f)
 
-tupOrListP :: [Pat] -> Pat
+tupOrListP :: [Pat] -> Exp -> [Stmt]
-tupOrListP ls
+tupOrListP ls e
-  | length ls <= 1 = ListP ls
+  | length ls == 0 =
-  | otherwise = TupP ls
+    let lsname = mkName "ls" in
+    [ BindS (VarP lsname) e
+    , NoBindS $ AppE (VarE 'guard) $ AppE (VarE 'null) $ SigE (VarE lsname) (AppT ListT (ConT ''())) ]
+  | length ls == 1 = [ BindS (ListP ls) e ]
+  | otherwise = [ BindS (TupP ls) e ]
 
 tupOrListE :: [Exp] -> Exp
 tupOrListE ls
-  | length ls <= 1 = ListE ls
+  | length ls == 0 = SigE (ListE []) (AppT ListT (ConT ''()))
+  | length ls == 1 = ListE ls
   | otherwise = TupE ls

haskell/test/UserData.hs

@@ -6,40 +6,38 @@ import Data.MessagePack.Derive
 data T
   = A Int String
   | B Double
-  deriving (Show)
+  deriving (Show, Eq)
 
 $(deriveObject ''T)
 
 data U
   = C { c1 :: Int, c2 :: String }
   | D { d1 :: Double }
-  deriving (Show)
+  deriving (Show, Eq)
 
 $(deriveObject ''U)
 
-main = do
+data V
-  let bs = pack $ A 123 "hoge"
+  = E String | F
-  print bs
+  deriving (Show, Eq)
-  print (unpack bs :: T)
-  let cs = pack $ B 3.14
-  print cs
-  print (unpack cs :: T)
-  let oa = toObject $ A 123 "hoge"
-  print oa
-  print (fromObject oa :: T)
-  let ob = toObject $ B 3.14
-  print ob
-  print (fromObject ob :: T)
 
-  let ds = pack $ C 123 "hoge"
+$(deriveObject ''V)
-  print ds
+
-  print (unpack ds :: U)
+test :: (OBJECT a, Show a, Eq a) => a -> IO ()
-  let es = pack $ D 3.14
+test v = do
-  print es
+  let bs = pack v
-  print (unpack es :: U)
+  print bs
-  let oc = toObject $ C 123 "hoge"
+  print (unpack bs == v)
-  print oc
+
-  print (fromObject oc :: U)
+  let oa = toObject v
-  let od = toObject $ D 3.14
+  print oa
-  print od
+  print (fromObject oa == v)
-  print (fromObject od :: U)
+
+main = do
+  test $ A 123 "hoge"
+  test $ B 3.14
+  test $ C 123 "hoge"
+  test $ D 3.14
+  test $ E "hello"
+  test $ F
+  return ()