Merge branch 'master' of github.com:msgpack/msgpack

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/>
@@ -15,6 +15,10 @@ Stability:          Experimental
 Cabal-Version:      >= 1.6
 Build-Type:         Simple
 
+Extra-source-files:
+  test/Test.hs
+  test/UserData.hs
+
 Library
   Build-depends:    base >=4 && <5,
                     transformers >= 0.2.1 && < 0.2.2,

haskell/src/Data/MessagePack/Derive.hs

@@ -7,14 +7,16 @@ module Data.MessagePack.Derive (
   ) where
 
 import Control.Applicative
+import Control.Monad
 import Language.Haskell.TH
 
 import Data.MessagePack.Pack
 import Data.MessagePack.Unpack
+import Data.MessagePack.Object
 
 deriveUnpack :: Name -> Q [Dec]
 deriveUnpack typName = do
-  TyConI (DataD cxt name tyVarBndrs cons names) <- reify typName
+  TyConI (DataD _ name _ cons _) <- reify typName
   
   return
     [ InstanceD [] (AppT (ConT ''Unpackable) (ConT name))
@@ -23,21 +25,20 @@ deriveUnpack typName = do
         
   where
     body (NormalC conName elms) =
-      DoE
-      [ BindS (tupOrList $ map VarP names) (VarE 'get)
-      , NoBindS $ AppE (VarE 'return) $ foldl AppE (ConE conName) $ map VarE names ]
+      DoE $
+      tupOrListP (map VarP names) (VarE 'get) ++
+      [ NoBindS $ AppE (VarE 'return) $ foldl AppE (ConE conName) $ map VarE names ]
         where
           names = zipWith (\ix _ -> mkName $ "a" ++ show (ix :: Int)) [1..] elms
 
-    tupOrList ls
-      | length ls <= 1 = ListP ls
-      | otherwise = TupP ls
+    body (RecC conName elms) =
+      body (NormalC conName $ map (\(_, b, c) -> (b, c)) elms)
 
     ch = foldl1 (\e f -> AppE (AppE (VarE '(<|>)) e) f)
 
 derivePack :: Name -> Q [Dec]
 derivePack typName = do
-  TyConI (DataD cxt name tyVarBndrs cons names) <- reify typName
+  TyConI (DataD _ name _ cons _) <- reify typName
   
   return
     [ InstanceD [] (AppT (ConT ''Packable) (ConT name))
@@ -48,27 +49,58 @@ derivePack typName = do
     body (NormalC conName elms) =
       Clause
         [ ConP conName $ map VarP names ]
-        (NormalB $ AppE (VarE 'put) $ tupOrList $ map VarE names) []
+        (NormalB $ AppE (VarE 'put) $ tupOrListE $ map VarE names) []
       where
         names = zipWith (\ix _ -> mkName $ "a" ++ show (ix :: Int)) [1..] elms
 
-    tupOrList ls
-      | length ls <= 1 = ListE ls
-      | otherwise = TupE ls
+    body (RecC conName elms) =
+      body (NormalC conName $ map (\(_, b, c) -> (b, c)) elms)
 
 deriveObject :: Name -> Q [Dec]
 deriveObject typName = do
   g <- derivePack typName
   p <- deriveUnpack typName
-  {-
-  TyConI (DataD cxt name tyVarBndrs cons names) <- reify typName
+
+  TyConI (DataD _ name _ cons _) <- reify typName
   let o = InstanceD [] (AppT (ConT ''OBJECT) (ConT name))
-          [ FunD 'toObject (map toObjectBody cons) ]
-  -}
-  return $ g ++ p -- ++ [o]
-{-
+          [ FunD 'toObject (map toObjectBody cons),
+            FunD 'tryFromObject [Clause [ VarP oname ]
+                                 (NormalB $ ch $ map tryFromObjectBody cons) []]]
+
+  return $ g ++ p ++ [o]
   where
     toObjectBody (NormalC conName elms) =
       Clause
-        [ ConP conP
--}
+        [ ConP conName $ map VarP names ]
+        (NormalB $ AppE (VarE 'toObject) $ tupOrListE $ map VarE names) []
+      where
+        names = zipWith (\ix _ -> mkName $ "a" ++ show (ix :: Int)) [1..] elms
+    toObjectBody (RecC conName elms) =
+      toObjectBody (NormalC conName $ map (\(_, b, c) -> (b, c)) elms)
+
+    tryFromObjectBody (NormalC conName elms) =
+      DoE $
+      tupOrListP (map VarP names) (AppE (VarE 'tryFromObject) (VarE oname)) ++
+      [ 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) =
+      tryFromObjectBody (NormalC conName $ map (\(_, b, c) -> (b, c)) elms)
+
+    oname = mkName "o"
+    ch = foldl1 (\e f -> AppE (AppE (VarE '(<|>)) e) f)
+
+tupOrListP :: [Pat] -> Exp -> [Stmt]
+tupOrListP ls e
+  | length ls == 0 =
+    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 == 0 = SigE (ListE []) (AppT ListT (ConT ''()))
+  | length ls == 1 = ListE ls
+  | otherwise = TupE ls

haskell/test/Test.hs

@@ -7,7 +7,7 @@ import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as L
 import Data.MessagePack
 
-mid :: (ObjectGet a, ObjectPut a) => a -> a
+mid :: (Packable a, Unpackable a) => a -> a
 mid = unpack . pack
 
 prop_mid_int a = a == mid a

haskell/test/UserData.hs

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