support auto-derive parameterized type

haskell/src/Data/MessagePack/Derive.hs

@@ -22,14 +22,14 @@ import Data.MessagePack.Object
 derivePack :: Name -> Q [Dec]
 derivePack tyName = do
   info <- reify tyName
-  case info of
+  d <- case info of
-    TyConI (DataD _ {- cxt -} name _ {- tyVarBndr -} cons _ {- derivings -}) -> do
+    TyConI (DataD _ {- cxt -} name tyVars cons _ {- derivings -}) -> do
-      [d|
+      ds <- [d| put v = $(caseE [| v |] (map alt cons)) |]
-       instance Packable $(conT name) where
+      instanceD (cx tyVars) (ct ''Packable name tyVars) $
-         put v = $(caseE [| v |] (map alt cons))
+        map return ds
-       |]
 
     _ -> error $ "cant derive Packable: " ++ show tyName
+  return [d]
 
   where
     alt (NormalC conName elms) = do
@@ -51,17 +51,18 @@ derivePack tyName = do
 
     alt c = error $ "unsupported constructor: " ++ pprint c
 
+
 deriveUnpack :: Name -> Q [Dec]
 deriveUnpack tyName = do
   info <- reify tyName
-  case info of
+  d <- case info of
-    TyConI (DataD _ {- cxt -} name _ {- tyVarBndr -} cons _ {- derivings -}) -> do
+    TyConI (DataD _ {- cxt -} name tyVars cons _ {- derivings -}) -> do
-      [d|
+      ds <- [d| get = $(foldl1 (\x y -> [| $x `mplus` $y |]) $ map alt cons) |]
-       instance Unpackable $(conT name) where
+      instanceD (cx tyVars) (ct ''Unpackable name tyVars) $
-         get = $(foldl1 (\x y -> [| $x `mplus` $y |]) $ map alt cons)
+        map return ds
-       |]
 
-    _ -> error $ "cant derive Packable: " ++ show tyName
+    _ -> error $ "cant derive Unpackable: " ++ show tyName
+  return [d]
 
   where
     alt (NormalC conName elms) = do
@@ -85,11 +86,16 @@ deriveUnpack tyName = do
                               $(varE var) |]
 
 deriveObject :: Name -> Q [Dec]
-deriveObject typName = do
+deriveObject tyName = do
-  g <- derivePack typName
+  g <- derivePack tyName
-  p <- deriveUnpack typName
+  p <- deriveUnpack tyName
-  o <- [d| instance OBJECT $(conT typName) where |]
+  info <- reify tyName
-  return $ g ++ p ++ o
+  o <- case info of
+    TyConI (DataD _ {- cxt -} name tyVars cons _ {- derivings -}) ->
+      -- use default implement
+      instanceD (cx tyVars) (ct ''OBJECT name tyVars) []
+    _ -> error $ "cant derive Object: " ++ show tyName
+  return $ g ++ p ++ [o]
 
 failN Nothing = mzero
 failN (Just a) =
@@ -97,7 +103,18 @@ failN (Just a) =
     Left _ -> mzero
     Right v -> return v
 
+cx tyVars =
+  cxt [ classP cl [varT tv]
+      | cl <- [''Packable, ''Unpackable, ''OBJECT]
+      , PlainTV tv <- tyVars ]
+
+ct tc tyName tyVars =
+  appT (conT tc) $ foldl appT (conT tyName) $
+  map (\(PlainTV n) -> varT n) tyVars
+
 key conName fname
+  | (prefix ++ "_") `isPrefixOf` sFname && length sFname > length prefix + 1 =
+    drop (length prefix + 1) sFname  
   | prefix `isPrefixOf` sFname && length sFname > length prefix =
     uncapital $ drop (length prefix) sFname
   | otherwise = sFname

haskell/test/UserData.hs

@@ -22,6 +22,13 @@ data V
 
 deriveObject ''V
 
+data W a
+  = G a String
+  | H { hHoge :: Int, h_age :: a }
+  deriving (Show, Eq)
+
+deriveObject ''W
+
 test :: (OBJECT a, Show a, Eq a) => a -> IO ()
 test v = do
   let bs = pack v
@@ -40,4 +47,6 @@ main = do
   test $ D 3.14
   test $ E "hello"
   test $ F
+  test $ G (E "hello") "world"
+  test $ H 123 F
   return ()