improve and change user data auto-deriver

haskell/msgpack.cabal

@@ -1,5 +1,5 @@
 Name:               msgpack
-Version:            0.6.1.3
+Version:            0.6.2
 Synopsis:           A Haskell implementation of MessagePack
 Description:
   A Haskell implementation of MessagePack <http://msgpack.org/>

haskell/src/Data/MessagePack/Derive.hs

@@ -1,4 +1,5 @@
 {-# Language TemplateHaskell #-}
+{-# Language FlexibleInstances #-}
 
 module Data.MessagePack.Derive (
   derivePack,
@@ -6,101 +7,89 @@ module Data.MessagePack.Derive (
   deriveObject,
   ) where
 
-import Control.Applicative
 import Control.Monad
+import Control.Monad.Error () -- for MonadPlus instance of Either e
 import Language.Haskell.TH
 
+import Data.MessagePack.Assoc
 import Data.MessagePack.Pack
 import Data.MessagePack.Unpack
 import Data.MessagePack.Object
 
-deriveUnpack :: Name -> Q [Dec]
-deriveUnpack typName = do
-  TyConI (DataD _ name _ cons _) <- reify typName
-  
-  return
-    [ InstanceD [] (AppT (ConT ''Unpackable) (ConT name))
-      [ FunD 'get [Clause [] (NormalB $ ch $ map body cons) []]
-        ]]
-        
-  where
-    body (NormalC conName elms) =
-      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
-
-    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
+derivePack tyName = do
-  TyConI (DataD _ name _ cons _) <- reify typName
+  info <- reify tyName
+  case info of
+    TyConI (DataD _ {- cxt -} name _ {- tyVarBndr -} cons _ {- derivings -}) -> do
+      [d|
+       instance Packable $(conT name) where
+         put v = $(caseE [| v |] (map alt cons))
+       |]
 
-  return
+    _ -> error $ "cant derive Packable: " ++ show tyName
-    [ InstanceD [] (AppT (ConT ''Packable) (ConT name))
-      [ FunD 'put (map body cons)
-        ]]
 
   where
-    body (NormalC conName elms) =
+    alt (NormalC conName elms) = do
-      Clause
+      vars <- replicateM (length elms) (newName "v")
-        [ ConP conName $ map VarP names ]
+      match (conP conName $ map varP vars)
-        (NormalB $ AppE (VarE 'put) $ tupOrListE $ map VarE names) []
+        (normalB [| put $(tupE $ map varE vars) |])
-      where
+        []
-        names = zipWith (\ix _ -> mkName $ "a" ++ show (ix :: Int)) [1..] elms
+
+    alt (RecC conName elms) = do
+      vars <- replicateM (length elms) (newName "v")
+      match (conP conName $ map varP vars)
+        (normalB
+         [| put $ Assoc
+              $(listE [ [| ( $(return $ LitE $ StringL $ show fname)
+                           , toObject $(varE v)) |]
+                      | (v, (fname, _, _)) <- zip vars elms])
+          |])
+        []
+
+    alt c = error $ "unsupported constructor: " ++ pprint c
+
+deriveUnpack :: Name -> Q [Dec]
+deriveUnpack tyName = do
+  info <- reify tyName
+  case info of
+    TyConI (DataD _ {- cxt -} name _ {- tyVarBndr -} cons _ {- derivings -}) -> do
+      [d|
+       instance Unpackable $(conT name) where
+         get = $(foldl1 (\x y -> [| $x `mplus` $y |]) $ map alt cons)
+       |]
+
+    _ -> error $ "cant derive Packable: " ++ show tyName
+
+  where
+    alt (NormalC conName elms) = do
+      vars <- replicateM (length elms) (newName "v")
+      doE [ bindS (tupP $ map varP vars) [| get |]
+          , noBindS [| return $(foldl appE (conE conName) $ map varE vars) |]
+          ]
+
+    alt (RecC conName elms) = do
+      var <- newName "v"
+      vars <- replicateM (length elms) (newName "w")
+      doE $ [ bindS (conP 'Assoc [varP var]) [| get |] ]
+            ++ zipWith (binds var) vars elms ++
+            [ noBindS [| return $(foldl appE (conE conName) $ map varE vars) |] ]
+
+    alt c = error $ "unsupported constructor: " ++ pprint c
+
+    binds var res (fname, _, _) =
+      bindS (varP res)
+            [| failN $ lookup $(return $ LitE $ StringL $ show fname) $(varE var) |]
+
+failN Nothing = mzero
+failN (Just a) =
+  case tryFromObject a of
+    Left _ -> mzero
+    Right v -> return v
 
-    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
-
+  o <- [d| instance OBJECT $(conT typName) where |]
-  TyConI (DataD _ name _ cons _) <- reify typName
+  return $ g ++ p ++ o
-  let o = InstanceD [] (AppT (ConT ''OBJECT) (ConT name))
-          [ 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 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/UserData.hs

@@ -1,27 +1,26 @@
 {-# Language TemplateHaskell #-}
 
 import Data.MessagePack
-import Data.MessagePack.Derive
 
 data T
   = A Int String
   | B Double
   deriving (Show, Eq)
 
-$(deriveObject ''T)
+deriveObject ''T
 
 data U
   = C { c1 :: Int, c2 :: String }
   | D { d1 :: Double }
   deriving (Show, Eq)
 
-$(deriveObject ''U)
+deriveObject ''U
 
 data V
   = E String | F
   deriving (Show, Eq)
 
-$(deriveObject ''V)
+deriveObject ''V
 
 test :: (OBJECT a, Show a, Eq a) => a -> IO ()
 test v = do
@@ -33,6 +32,7 @@ test v = do
   print oa
   print (fromObject oa == v)
 
+main :: IO ()
 main = do
   test $ A 123 "hoge"
   test $ B 3.14