From 93bed9c5df6d4fe7a0defdaeb2f158e27d4feb1d Mon Sep 17 00:00:00 2001
From: tanakh <tanaka.hideyuki@gmail.com>
Date: Fri, 24 Sep 2010 01:24:13 +0900
Subject: [PATCH] haskell: finish template-haskell deriving implement

---
 haskell/msgpack.cabal                  |  4 ++
 haskell/src/Data/MessagePack/Derive.hs | 62 ++++++++++++++++++--------
 haskell/test/Test.hs                   |  2 +-
 haskell/test/UserData.hs               | 26 +++++++++++
 4 files changed, 75 insertions(+), 19 deletions(-)

diff --git a/haskell/msgpack.cabal b/haskell/msgpack.cabal
index 9c67bdce..99502732 100644
--- a/haskell/msgpack.cabal
+++ b/haskell/msgpack.cabal
@@ -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,
diff --git a/haskell/src/Data/MessagePack/Derive.hs b/haskell/src/Data/MessagePack/Derive.hs
index cfdb6588..e9984730 100644
--- a/haskell/src/Data/MessagePack/Derive.hs
+++ b/haskell/src/Data/MessagePack/Derive.hs
@@ -11,10 +11,11 @@ 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))
@@ -24,20 +25,19 @@ deriveUnpack typName = do
   where
     body (NormalC conName elms) =
       DoE
-      [ BindS (tupOrList $ map VarP names) (VarE 'get)
+      [ BindS (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 +48,53 @@ 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
+      [ BindS (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] -> Pat
+tupOrListP ls
+  | length ls <= 1 = ListP ls
+  | otherwise = TupP ls
+
+tupOrListE :: [Exp] -> Exp
+tupOrListE ls
+  | length ls <= 1 = ListE ls
+  | otherwise = TupE ls
diff --git a/haskell/test/Test.hs b/haskell/test/Test.hs
index a73ac9ab..43af2efc 100644
--- a/haskell/test/Test.hs
+++ b/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
diff --git a/haskell/test/UserData.hs b/haskell/test/UserData.hs
index 8aced13f..73647ff1 100644
--- a/haskell/test/UserData.hs
+++ b/haskell/test/UserData.hs
@@ -10,6 +10,13 @@ data T
 
 $(deriveObject ''T)
 
+data U
+  = C { c1 :: Int, c2 :: String }
+  | D { d1 :: Double }
+  deriving (Show)
+
+$(deriveObject ''U)
+
 main = do
   let bs = pack $ A 123 "hoge"
   print bs
@@ -17,3 +24,22 @@ main = do
   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"
+  print ds
+  print (unpack ds :: U)
+  let es = pack $ D 3.14
+  print es
+  print (unpack es :: U)
+  let oc = toObject $ C 123 "hoge"
+  print oc
+  print (fromObject oc :: U)
+  let od = toObject $ D 3.14
+  print od
+  print (fromObject od :: U)