haskell: TH support and refactoring

haskell/msgpack.cabal

@@ -1,5 +1,5 @@
 Name:               msgpack
-Version:            0.3.1.1
+Version:            0.4.0
 Synopsis:           A Haskell binding to MessagePack
 Description:
   A Haskell binding to MessagePack <http://msgpack.org/>
@@ -25,17 +25,19 @@ Library
                     attoparsec >= 0.8.1 && < 0.8.2,
                     binary >= 0.5.0 && < 0.5.1,
                     data-binary-ieee754 >= 0.4 && < 0.5,
-                    deepseq >= 1.1 && <1.2
+                    deepseq >= 1.1 && <1.2,
+                    template-haskell >= 2.4 && < 2.5
 
   Ghc-options:      -Wall
   Hs-source-dirs:   src
 
   Exposed-modules:
     Data.MessagePack
+    Data.MessagePack.Pack
+    Data.MessagePack.Unpack
     Data.MessagePack.Object
-    Data.MessagePack.Put
-    Data.MessagePack.Parser
     Data.MessagePack.Iteratee
+    Data.MessagePack.Derive
 
 Source-repository head
   Type:     git

haskell/src/Data/MessagePack.hs

@@ -13,14 +13,11 @@
 --------------------------------------------------------------------
 
 module Data.MessagePack(
+  module Data.MessagePack.Pack,
+  module Data.MessagePack.Unpack,
   module Data.MessagePack.Object,
-  module Data.MessagePack.Put,
-  module Data.MessagePack.Parser,
   module Data.MessagePack.Iteratee,
-  
+  module Data.MessagePack.Derive,
-  -- * Simple functions of Pack and Unpack
-  pack,
-  unpack,
   
   -- * Pack functions
   packToString,
@@ -44,38 +41,18 @@ import qualified Data.Attoparsec as A
 import Data.Binary.Put
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as L
-import Data.Functor.Identity
 import qualified Data.Iteratee as I
 import System.IO
 
+import Data.MessagePack.Pack
+import Data.MessagePack.Unpack
 import Data.MessagePack.Object
-import Data.MessagePack.Put
-import Data.MessagePack.Parser
 import Data.MessagePack.Iteratee
+import Data.MessagePack.Derive
 
 bufferSize :: Int
 bufferSize = 4 * 1024
 
-class IsByteString s where
-  toBS :: s -> B.ByteString
-
-instance IsByteString B.ByteString where
-  toBS = id
-
-instance IsByteString L.ByteString where
-  toBS = B.concat . L.toChunks
-
--- | Pack Haskell data to MessagePack string.
-pack :: ObjectPut a => a -> L.ByteString
-pack = packToString . put
-
--- | Unpack MessagePack string to Haskell data.
-unpack :: (ObjectGet a, IsByteString s) => s -> a
-unpack bs =
-  runIdentity $ I.run $ I.joinIM $ I.enumPure1Chunk (toBS bs) getI
-
--- TODO: tryUnpack
-
 -- | Pack to ByteString.
 packToString :: Put -> L.ByteString
 packToString = runPut

haskell/src/Data/MessagePack/Derive.hs

@@ -0,0 +1,74 @@
+{-# Language TemplateHaskell #-}
+
+module Data.MessagePack.Derive (
+  derivePack,
+  deriveUnpack,
+  deriveObject,
+  ) where
+
+import Control.Applicative
+import Language.Haskell.TH
+
+import Data.MessagePack.Pack
+import Data.MessagePack.Unpack
+
+deriveUnpack :: Name -> Q [Dec]
+deriveUnpack typName = do
+  TyConI (DataD cxt name tyVarBndrs cons names) <- reify typName
+  
+  return
+    [ InstanceD [] (AppT (ConT ''Unpackable) (ConT name))
+      [ FunD 'get [Clause [] (NormalB $ ch $ map body cons) []]
+        ]]
+        
+  where
+    body (NormalC conName elms) =
+      DoE
+      [ BindS (tupOrList $ 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
+
+    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
+  
+  return
+    [ InstanceD [] (AppT (ConT ''Packable) (ConT name))
+      [ FunD 'put (map body cons)
+        ]]
+        
+  where
+    body (NormalC conName elms) =
+      Clause
+        [ ConP conName $ map VarP names ]
+        (NormalB $ AppE (VarE 'put) $ tupOrList $ map VarE names) []
+      where
+        names = zipWith (\ix _ -> mkName $ "a" ++ show (ix :: Int)) [1..] elms
+
+    tupOrList ls
+      | length ls <= 1 = ListE ls
+      | otherwise = TupE ls
+
+deriveObject :: Name -> Q [Dec]
+deriveObject typName = do
+  g <- derivePack typName
+  p <- deriveUnpack typName
+  {-
+  TyConI (DataD cxt name tyVarBndrs cons names) <- reify typName
+  let o = InstanceD [] (AppT (ConT ''OBJECT) (ConT name))
+          [ FunD 'toObject (map toObjectBody cons) ]
+  -}
+  return $ g ++ p -- ++ [o]
+{-
+  where
+    toObjectBody (NormalC conName elms) =
+      Clause
+        [ ConP conP
+-}

haskell/src/Data/MessagePack/Iteratee.hs

@@ -28,10 +28,10 @@ import qualified Data.ByteString as B
 import qualified Data.Iteratee as I
 import System.IO
 
-import Data.MessagePack.Parser
+import Data.MessagePack.Unpack
 
 -- | Deserialize a value
-getI :: (Monad m, ObjectGet a) => I.Iteratee B.ByteString m a
+getI :: (Monad m, Unpackable a) => I.Iteratee B.ByteString m a
 getI = parserToIteratee get
 
 -- | Enumerator

haskell/src/Data/MessagePack/Object.hs

@@ -1,6 +1,7 @@
 {-# Language TypeSynonymInstances #-}
 {-# Language FlexibleInstances #-}
 {-# Language OverlappingInstances #-}
+{-# Language IncoherentInstances #-}
 {-# Language DeriveDataTypeable #-}
 
 --------------------------------------------------------------------
@@ -23,16 +24,21 @@ module Data.MessagePack.Object(
   
   -- * Serialization to and from Object
   OBJECT(..),
-  Result,
+  -- Result,
   ) where
 
 import Control.DeepSeq
+import Control.Exception
 import Control.Monad
 import Control.Monad.Trans.Error ()
+import qualified Data.Attoparsec as A
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Char8 as C8
 import Data.Typeable
 
+import Data.MessagePack.Pack
+import Data.MessagePack.Unpack
+
 -- | Object Representation of MessagePack data.
 data Object =
   ObjectNil
@@ -55,70 +61,241 @@ instance NFData Object where
       ObjectArray a -> rnf a
       ObjectMap m -> rnf m
 
+instance Unpackable Object where
+  get =
+    A.choice
+    [ liftM ObjectInteger get
+    , liftM (\() -> ObjectNil) get
+    , liftM ObjectBool get
+    , liftM ObjectDouble get
+    , liftM ObjectRAW get
+    , liftM ObjectArray get
+    , liftM ObjectMap get
+    ]
+
+instance Packable Object where
+  put obj =
+    case obj of
+      ObjectInteger n ->
+        put n
+      ObjectNil ->
+        put ()
+      ObjectBool b ->
+        put b
+      ObjectDouble d ->
+        put d
+      ObjectRAW raw ->
+        put raw
+      ObjectArray arr ->
+        put arr
+      ObjectMap m ->
+        put m
+
 -- | The class of types serializable to and from MessagePack object
-class OBJECT a where
+class (Unpackable a, Packable a) => OBJECT a where
   -- | Encode a value to MessagePack object
   toObject :: a -> Object
+  toObject = unpack . pack
+  
   -- | Decode a value from MessagePack object
-  fromObject :: Object -> Result a
+  fromObject :: Object -> a
+  fromObject a =
+    case tryFromObject a of
+      Left err ->
+        throw $ UnpackError err
+      Right ret ->
+        ret
 
--- | A type for parser results
+  -- | Decode a value from MessagePack object
-type Result a = Either String a
+  tryFromObject :: Object -> Either String a
+  tryFromObject = tryUnpack . pack
 
 instance OBJECT Object where
   toObject = id
-  fromObject = Right
+  tryFromObject = Right
 
-fromObjectError :: String
+tryFromObjectError :: Either String a
-fromObjectError = "fromObject: cannot cast"
+tryFromObjectError = Left "tryFromObject: cannot cast"
 
 instance OBJECT () where
   toObject = const ObjectNil
-  fromObject ObjectNil = Right ()
+  tryFromObject ObjectNil = Right ()
-  fromObject _ = Left fromObjectError
+  tryFromObject _ = tryFromObjectError
 
 instance OBJECT Int where
   toObject = ObjectInteger
-  fromObject (ObjectInteger n) = Right n
+  tryFromObject (ObjectInteger n) = Right n
-  fromObject _ = Left fromObjectError
+  tryFromObject _ = tryFromObjectError
 
 instance OBJECT Bool where
   toObject = ObjectBool
-  fromObject (ObjectBool b) = Right b
+  tryFromObject (ObjectBool b) = Right b
-  fromObject _ = Left fromObjectError
+  tryFromObject _ = tryFromObjectError
 
 instance OBJECT Double where
   toObject = ObjectDouble
-  fromObject (ObjectDouble d) = Right d
+  tryFromObject (ObjectDouble d) = Right d
-  fromObject _ = Left fromObjectError
+  tryFromObject _ = tryFromObjectError
 
 instance OBJECT B.ByteString where
   toObject = ObjectRAW
-  fromObject (ObjectRAW bs) = Right bs
+  tryFromObject (ObjectRAW bs) = Right bs
-  fromObject _ = Left fromObjectError
+  tryFromObject _ = tryFromObjectError
 
 instance OBJECT String where
   toObject = toObject . C8.pack
-  fromObject obj = liftM C8.unpack $ fromObject obj
+  tryFromObject obj = liftM C8.unpack $ tryFromObject obj
 
 instance OBJECT a => OBJECT [a] where
   toObject = ObjectArray . map toObject
-  fromObject (ObjectArray arr) =
+  tryFromObject (ObjectArray arr) =
-    mapM fromObject arr
+    mapM tryFromObject arr
-  fromObject _ =
+  tryFromObject _ =
-    Left fromObjectError
+    tryFromObjectError
+
+instance (OBJECT a1, OBJECT a2) => OBJECT (a1, a2) where
+  toObject (a1, a2) = ObjectArray [toObject a1, toObject a2]
+  tryFromObject (ObjectArray arr) =
+    case arr of
+      [o1, o2] -> do
+        v1 <- tryFromObject o1
+        v2 <- tryFromObject o2
+        return (v1, v2)
+      _ ->
+        tryFromObjectError
+  tryFromObject _ =
+    tryFromObjectError
+
+instance (OBJECT a1, OBJECT a2, OBJECT a3) => OBJECT (a1, a2, a3) where
+  toObject (a1, a2, a3) = ObjectArray [toObject a1, toObject a2, toObject a3]
+  tryFromObject (ObjectArray arr) =
+    case arr of
+      [o1, o2, o3] -> do
+        v1 <- tryFromObject o1
+        v2 <- tryFromObject o2
+        v3 <- tryFromObject o3
+        return (v1, v2, v3)
+      _ ->
+        tryFromObjectError
+  tryFromObject _ =
+    tryFromObjectError
+
+instance (OBJECT a1, OBJECT a2, OBJECT a3, OBJECT a4) => OBJECT (a1, a2, a3, a4) where
+  toObject (a1, a2, a3, a4) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4]
+  tryFromObject (ObjectArray arr) =
+    case arr of
+      [o1, o2, o3, o4] -> do
+        v1 <- tryFromObject o1
+        v2 <- tryFromObject o2
+        v3 <- tryFromObject o3
+        v4 <- tryFromObject o4
+        return (v1, v2, v3, v4)
+      _ ->
+        tryFromObjectError
+  tryFromObject _ =
+    tryFromObjectError
+
+instance (OBJECT a1, OBJECT a2, OBJECT a3, OBJECT a4, OBJECT a5) => OBJECT (a1, a2, a3, a4, a5) where
+  toObject (a1, a2, a3, a4, a5) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5]
+  tryFromObject (ObjectArray arr) =
+    case arr of
+      [o1, o2, o3, o4, o5] -> do
+        v1 <- tryFromObject o1
+        v2 <- tryFromObject o2
+        v3 <- tryFromObject o3
+        v4 <- tryFromObject o4
+        v5 <- tryFromObject o5
+        return (v1, v2, v3, v4, v5)
+      _ ->
+        tryFromObjectError
+  tryFromObject _ =
+    tryFromObjectError
+
+instance (OBJECT a1, OBJECT a2, OBJECT a3, OBJECT a4, OBJECT a5, OBJECT a6) => OBJECT (a1, a2, a3, a4, a5, a6) where
+  toObject (a1, a2, a3, a4, a5, a6) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5, toObject a6]
+  tryFromObject (ObjectArray arr) =
+    case arr of
+      [o1, o2, o3, o4, o5, o6] -> do
+        v1 <- tryFromObject o1
+        v2 <- tryFromObject o2
+        v3 <- tryFromObject o3
+        v4 <- tryFromObject o4
+        v5 <- tryFromObject o5
+        v6 <- tryFromObject o6
+        return (v1, v2, v3, v4, v5, v6)
+      _ ->
+        tryFromObjectError
+  tryFromObject _ =
+    tryFromObjectError
+
+instance (OBJECT a1, OBJECT a2, OBJECT a3, OBJECT a4, OBJECT a5, OBJECT a6, OBJECT a7) => OBJECT (a1, a2, a3, a4, a5, a6, a7) where
+  toObject (a1, a2, a3, a4, a5, a6, a7) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5, toObject a6, toObject a7]
+  tryFromObject (ObjectArray arr) =
+    case arr of
+      [o1, o2, o3, o4, o5, o6, o7] -> do
+        v1 <- tryFromObject o1
+        v2 <- tryFromObject o2
+        v3 <- tryFromObject o3
+        v4 <- tryFromObject o4
+        v5 <- tryFromObject o5
+        v6 <- tryFromObject o6
+        v7 <- tryFromObject o7
+        return (v1, v2, v3, v4, v5, v6, v7)
+      _ ->
+        tryFromObjectError
+  tryFromObject _ =
+    tryFromObjectError
+
+instance (OBJECT a1, OBJECT a2, OBJECT a3, OBJECT a4, OBJECT a5, OBJECT a6, OBJECT a7, OBJECT a8) => OBJECT (a1, a2, a3, a4, a5, a6, a7, a8) where
+  toObject (a1, a2, a3, a4, a5, a6, a7, a8) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5, toObject a6, toObject a7, toObject a8]
+  tryFromObject (ObjectArray arr) =
+    case arr of
+      [o1, o2, o3, o4, o5, o6, o7, o8] -> do
+        v1 <- tryFromObject o1
+        v2 <- tryFromObject o2
+        v3 <- tryFromObject o3
+        v4 <- tryFromObject o4
+        v5 <- tryFromObject o5
+        v6 <- tryFromObject o6
+        v7 <- tryFromObject o7
+        v8 <- tryFromObject o8
+        return (v1, v2, v3, v4, v5, v6, v7, v8)
+      _ ->
+        tryFromObjectError
+  tryFromObject _ =
+    tryFromObjectError
+
+instance (OBJECT a1, OBJECT a2, OBJECT a3, OBJECT a4, OBJECT a5, OBJECT a6, OBJECT a7, OBJECT a8, OBJECT a9) => OBJECT (a1, a2, a3, a4, a5, a6, a7, a8, a9) where
+  toObject (a1, a2, a3, a4, a5, a6, a7, a8, a9) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5, toObject a6, toObject a7, toObject a8, toObject a9]
+  tryFromObject (ObjectArray arr) =
+    case arr of
+      [o1, o2, o3, o4, o5, o6, o7, o8, o9] -> do
+        v1 <- tryFromObject o1
+        v2 <- tryFromObject o2
+        v3 <- tryFromObject o3
+        v4 <- tryFromObject o4
+        v5 <- tryFromObject o5
+        v6 <- tryFromObject o6
+        v7 <- tryFromObject o7
+        v8 <- tryFromObject o8
+        v9 <- tryFromObject o9
+        return (v1, v2, v3, v4, v5, v6, v7, v8, v9)
+      _ ->
+        tryFromObjectError
+  tryFromObject _ =
+    tryFromObjectError
 
 instance (OBJECT a, OBJECT b) => OBJECT [(a, b)] where
   toObject =
     ObjectMap . map (\(a, b) -> (toObject a, toObject b))
-  fromObject (ObjectMap mem) = do
+  tryFromObject (ObjectMap mem) = do
-    mapM (\(a, b) -> liftM2 (,) (fromObject a) (fromObject b)) mem
+    mapM (\(a, b) -> liftM2 (,) (tryFromObject a) (tryFromObject b)) mem
-  fromObject _ =
+  tryFromObject _ =
-    Left fromObjectError
+    tryFromObjectError
 
 instance OBJECT a => OBJECT (Maybe a) where
   toObject (Just a) = toObject a
   toObject Nothing = ObjectNil
   
-  fromObject ObjectNil = return Nothing
+  tryFromObject ObjectNil = return Nothing
-  fromObject obj = liftM Just $ fromObject obj
+  tryFromObject obj = liftM Just $ tryFromObject obj

haskell/src/Data/MessagePack/Pack.hs

@@ -5,7 +5,7 @@
 
 --------------------------------------------------------------------
 -- |
--- Module    : Data.MessagePack.Put
+-- Module    : Data.MessagePack.Pack
 -- Copyright : (c) Hideyuki Tanaka, 2009-2010
 -- License   : BSD3
 --
@@ -13,13 +13,15 @@
 -- Stability :  experimental
 -- Portability: portable
 --
--- MessagePack Serializer using @Data.Binary.Put@
+-- MessagePack Serializer using @Data.Binary.Pack@
 --
 --------------------------------------------------------------------
 
-module Data.MessagePack.Put(
+module Data.MessagePack.Pack (
   -- * Serializable class
-  ObjectPut(..),
+  Packable(..),
+  -- * Simple function to pack a Haskell value
+  pack,
   ) where
 
 import Data.Binary.Put
@@ -30,32 +32,16 @@ import qualified Data.ByteString.Char8 as B8
 import qualified Data.ByteString.Lazy as L
 import qualified Data.Vector as V
 
-import Data.MessagePack.Object
-
 -- | Serializable class
-class ObjectPut a where
+class Packable a where
   -- | Serialize a value
   put :: a -> Put
 
-instance ObjectPut Object where
+-- | Pack Haskell data to MessagePack string.
-  put obj =
+pack :: Packable a => a -> L.ByteString
-    case obj of
+pack = runPut . put
-      ObjectInteger n ->
-        put n
-      ObjectNil ->
-        put ()
-      ObjectBool b ->
-        put b
-      ObjectDouble d ->
-        put d
-      ObjectRAW raw ->
-        put raw
-      ObjectArray arr ->
-        put arr
-      ObjectMap m ->
-        put m
 
-instance ObjectPut Int where
+instance Packable Int where
   put n =
     case n of
       _ | n >= 0 && n <= 127 ->
@@ -87,26 +73,26 @@ instance ObjectPut Int where
         putWord8 0xD3
         putWord64be $ fromIntegral n
 
-instance ObjectPut () where
+instance Packable () where
   put _ = 
     putWord8 0xC0
 
-instance ObjectPut Bool where
+instance Packable Bool where
   put True = putWord8 0xC3
   put False = putWord8 0xC2
 
-instance ObjectPut Double where
+instance Packable Double where
   put d = do
     putWord8 0xCB
     putFloat64be d
 
-instance ObjectPut String where
+instance Packable String where
   put = putString length (putByteString . B8.pack)
 
-instance ObjectPut B.ByteString where
+instance Packable B.ByteString where
   put = putString B.length putByteString
 
-instance ObjectPut L.ByteString where
+instance Packable L.ByteString where
   put = putString (fromIntegral . L.length) putLazyByteString
 
 putString :: (s -> Int) -> (s -> Put) -> s -> Put
@@ -122,41 +108,41 @@ putString lf pf str = do
       putWord32be $ fromIntegral len
   pf str
 
-instance ObjectPut a => ObjectPut [a] where
+instance Packable a => Packable [a] where
   put = putArray length (mapM_ put)
 
-instance ObjectPut a => ObjectPut (V.Vector a) where
+instance Packable a => Packable (V.Vector a) where
   put = putArray V.length (V.mapM_ put)
 
-instance (ObjectPut a1, ObjectPut a2) => ObjectPut (a1, a2) where
+instance (Packable a1, Packable a2) => Packable (a1, a2) where
   put = putArray (const 2) f where
     f (a1, a2) = put a1 >> put a2
 
-instance (ObjectPut a1, ObjectPut a2, ObjectPut a3) => ObjectPut (a1, a2, a3) where
+instance (Packable a1, Packable a2, Packable a3) => Packable (a1, a2, a3) where
   put = putArray (const 3) f where
     f (a1, a2, a3) = put a1 >> put a2 >> put a3
 
-instance (ObjectPut a1, ObjectPut a2, ObjectPut a3, ObjectPut a4) => ObjectPut (a1, a2, a3, a4) where
+instance (Packable a1, Packable a2, Packable a3, Packable a4) => Packable (a1, a2, a3, a4) where
   put = putArray (const 4) f where
     f (a1, a2, a3, a4) = put a1 >> put a2 >> put a3 >> put a4
 
-instance (ObjectPut a1, ObjectPut a2, ObjectPut a3, ObjectPut a4, ObjectPut a5) => ObjectPut (a1, a2, a3, a4, a5) where
+instance (Packable a1, Packable a2, Packable a3, Packable a4, Packable a5) => Packable (a1, a2, a3, a4, a5) where
   put = putArray (const 5) f where
     f (a1, a2, a3, a4, a5) = put a1 >> put a2 >> put a3 >> put a4 >> put a5
 
-instance (ObjectPut a1, ObjectPut a2, ObjectPut a3, ObjectPut a4, ObjectPut a5, ObjectPut a6) => ObjectPut (a1, a2, a3, a4, a5, a6) where
+instance (Packable a1, Packable a2, Packable a3, Packable a4, Packable a5, Packable a6) => Packable (a1, a2, a3, a4, a5, a6) where
   put = putArray (const 6) f where
     f (a1, a2, a3, a4, a5, a6) = put a1 >> put a2 >> put a3 >> put a4 >> put a5 >> put a6
 
-instance (ObjectPut a1, ObjectPut a2, ObjectPut a3, ObjectPut a4, ObjectPut a5, ObjectPut a6, ObjectPut a7) => ObjectPut (a1, a2, a3, a4, a5, a6, a7) where
+instance (Packable a1, Packable a2, Packable a3, Packable a4, Packable a5, Packable a6, Packable a7) => Packable (a1, a2, a3, a4, a5, a6, a7) where
   put = putArray (const 7) f where
     f (a1, a2, a3, a4, a5, a6, a7) = put a1 >> put a2 >> put a3 >> put a4 >> put a5 >> put a6 >> put a7
 
-instance (ObjectPut a1, ObjectPut a2, ObjectPut a3, ObjectPut a4, ObjectPut a5, ObjectPut a6, ObjectPut a7, ObjectPut a8) => ObjectPut (a1, a2, a3, a4, a5, a6, a7, a8) where
+instance (Packable a1, Packable a2, Packable a3, Packable a4, Packable a5, Packable a6, Packable a7, Packable a8) => Packable (a1, a2, a3, a4, a5, a6, a7, a8) where
   put = putArray (const 8) f where
     f (a1, a2, a3, a4, a5, a6, a7, a8) = put a1 >> put a2 >> put a3 >> put a4 >> put a5 >> put a6 >> put a7 >> put a8
 
-instance (ObjectPut a1, ObjectPut a2, ObjectPut a3, ObjectPut a4, ObjectPut a5, ObjectPut a6, ObjectPut a7, ObjectPut a8, ObjectPut a9) => ObjectPut (a1, a2, a3, a4, a5, a6, a7, a8, a9) where
+instance (Packable a1, Packable a2, Packable a3, Packable a4, Packable a5, Packable a6, Packable a7, Packable a8, Packable a9) => Packable (a1, a2, a3, a4, a5, a6, a7, a8, a9) where
   put = putArray (const 9) f where
     f (a1, a2, a3, a4, a5, a6, a7, a8, a9) = put a1 >> put a2 >> put a3 >> put a4 >> put a5 >> put a6 >> put a7 >> put a8 >> put a9
 
@@ -173,13 +159,13 @@ putArray lf pf arr = do
       putWord32be $ fromIntegral len
   pf arr
 
-instance (ObjectPut k, ObjectPut v) => ObjectPut [(k, v)] where
+instance (Packable k, Packable v) => Packable [(k, v)] where
   put = putMap length (mapM_ putPair)
 
-instance (ObjectPut k, ObjectPut v) => ObjectPut (V.Vector (k, v)) where
+instance (Packable k, Packable v) => Packable (V.Vector (k, v)) where
   put = putMap V.length (V.mapM_ putPair)
 
-putPair :: (ObjectPut a, ObjectPut b) => (a, b) -> Put
+putPair :: (Packable a, Packable b) => (a, b) -> Put
 putPair (a, b) = put a >> put b
 
 putMap :: (a -> Int) -> (a -> Put) -> a -> Put
@@ -194,3 +180,7 @@ putMap lf pf m = do
       putWord8 0xDF
       putWord32be $ fromIntegral len
   pf m
+
+instance Packable a => Packable (Maybe a) where
+  put Nothing = put ()
+  put (Just a) = put a

haskell/src/Data/MessagePack/Unpack.hs

@@ -2,10 +2,11 @@
 {-# Language IncoherentInstances #-}
 {-# Language OverlappingInstances #-}
 {-# Language TypeSynonymInstances #-}
+{-# Language DeriveDataTypeable #-}
 
 --------------------------------------------------------------------
 -- |
--- Module    : Data.MessagePack.Parser
+-- Module    : Data.MessagePack.Unpack
 -- Copyright : (c) Hideyuki Tanaka, 2009-2010
 -- License   : BSD3
 --
@@ -17,11 +18,19 @@
 --
 --------------------------------------------------------------------
 
-module Data.MessagePack.Parser(
+module Data.MessagePack.Unpack(
   -- * MessagePack deserializer
-  ObjectGet(..),
+  Unpackable(..),
+  -- * Simple function to unpack a Haskell value
+  unpack,
+  tryUnpack,
+  -- * Unpack exception
+  UnpackError(..),
+  -- * ByteString utils
+  IsByteString(..),
   ) where
 
+import Control.Exception
 import Control.Monad
 import qualified Data.Attoparsec as A
 import Data.Binary.Get
@@ -31,30 +40,53 @@ import qualified Data.ByteString as B
 import qualified Data.ByteString.Char8 as B8
 import qualified Data.ByteString.Lazy as L
 import Data.Int
+import Data.Typeable
 import qualified Data.Vector as V
 import Data.Word
 import Text.Printf
 
-import Data.MessagePack.Object
-
 -- | Deserializable class
-class ObjectGet a where
+class Unpackable a where
   -- | Deserialize a value
   get :: A.Parser a
 
-instance ObjectGet Object where
+class IsByteString s where
-  get =
+  toBS :: s -> B.ByteString
-    A.choice
-    [ liftM ObjectInteger get
-    , liftM (\() -> ObjectNil) get
-    , liftM ObjectBool get
-    , liftM ObjectDouble get
-    , liftM ObjectRAW get
-    , liftM ObjectArray get
-    , liftM ObjectMap get
-    ]
 
-instance ObjectGet Int where
+instance IsByteString B.ByteString where
+  toBS = id
+
+instance IsByteString L.ByteString where
+  toBS = B.concat . L.toChunks
+
+-- | The exception of unpack
+data UnpackError =
+  UnpackError String
+  deriving (Show, Typeable)
+
+instance Exception UnpackError
+
+-- | Unpack MessagePack string to Haskell data.
+unpack :: (Unpackable a, IsByteString s) => s -> a
+unpack bs =
+  case tryUnpack bs of
+    Left err ->
+      throw $ UnpackError err
+    Right ret ->
+      ret
+
+-- | Unpack MessagePack string to Haskell data.
+tryUnpack :: (Unpackable a, IsByteString s) => s -> Either String a
+tryUnpack bs =
+  case A.parse get (toBS bs) of
+    A.Fail _ _ err ->
+      Left err
+    A.Partial _ ->
+      Left "not enough input"
+    A.Done _ ret ->
+      Right ret
+
+instance Unpackable Int where
   get = do
     c <- A.anyWord8
     case c of
@@ -81,7 +113,7 @@ instance ObjectGet Int where
       _ ->
         fail $ printf "invlid integer tag: 0x%02X" c
 
-instance ObjectGet () where
+instance Unpackable () where
   get = do
     c <- A.anyWord8
     case c of
@@ -90,7 +122,7 @@ instance ObjectGet () where
       _ ->
         fail $ printf "invlid nil tag: 0x%02X" c
 
-instance ObjectGet Bool where
+instance Unpackable Bool where
   get = do
     c <- A.anyWord8
     case c of
@@ -101,7 +133,7 @@ instance ObjectGet Bool where
       _ ->
         fail $ printf "invlid bool tag: 0x%02X" c
 
-instance ObjectGet Double where
+instance Unpackable Double where
   get = do
     c <- A.anyWord8
     case c of
@@ -112,13 +144,13 @@ instance ObjectGet Double where
       _ ->
         fail $ printf "invlid double tag: 0x%02X" c
 
-instance ObjectGet String where
+instance Unpackable String where
   get = parseString (\n -> return . B8.unpack =<< A.take n)
 
-instance ObjectGet B.ByteString where
+instance Unpackable B.ByteString where
   get = parseString A.take
 
-instance ObjectGet L.ByteString where
+instance Unpackable L.ByteString where
   get = parseString (\n -> do bs <- A.take n; return $ L.fromChunks [bs])
 
 parseString :: (Int -> A.Parser a) -> A.Parser a
@@ -134,48 +166,48 @@ parseString aget = do
     _ ->
       fail $ printf "invlid raw tag: 0x%02X" c
 
-instance ObjectGet a => ObjectGet [a] where
+instance Unpackable a => Unpackable [a] where
   get = parseArray (flip replicateM get)
 
-instance ObjectGet a => ObjectGet (V.Vector a) where
+instance Unpackable a => Unpackable (V.Vector a) where
   get = parseArray (flip V.replicateM get)
 
-instance (ObjectGet a1, ObjectGet a2) => ObjectGet (a1, a2) where
+instance (Unpackable a1, Unpackable a2) => Unpackable (a1, a2) where
   get = parseArray f where
     f 2 = get >>= \a1 -> get >>= \a2 -> return (a1, a2)
     f n = fail $ printf "wrong tupple size: expected 2 but got " n
 
-instance (ObjectGet a1, ObjectGet a2, ObjectGet a3) => ObjectGet (a1, a2, a3) where
+instance (Unpackable a1, Unpackable a2, Unpackable a3) => Unpackable (a1, a2, a3) where
   get = parseArray f where
     f 3 = get >>= \a1 -> get >>= \a2 -> get >>= \a3 -> return (a1, a2, a3)
     f n = fail $ printf "wrong tupple size: expected 3 but got " n
 
-instance (ObjectGet a1, ObjectGet a2, ObjectGet a3, ObjectGet a4) => ObjectGet (a1, a2, a3, a4) where
+instance (Unpackable a1, Unpackable a2, Unpackable a3, Unpackable a4) => Unpackable (a1, a2, a3, a4) where
   get = parseArray f where
     f 4 = get >>= \a1 -> get >>= \a2 -> get >>= \a3 -> get >>= \a4 -> return (a1, a2, a3, a4)
     f n = fail $ printf "wrong tupple size: expected 4 but got " n
 
-instance (ObjectGet a1, ObjectGet a2, ObjectGet a3, ObjectGet a4, ObjectGet a5) => ObjectGet (a1, a2, a3, a4, a5) where
+instance (Unpackable a1, Unpackable a2, Unpackable a3, Unpackable a4, Unpackable a5) => Unpackable (a1, a2, a3, a4, a5) where
   get = parseArray f where
     f 5 = get >>= \a1 -> get >>= \a2 -> get >>= \a3 -> get >>= \a4 -> get >>= \a5 -> return (a1, a2, a3, a4, a5)
     f n = fail $ printf "wrong tupple size: expected 5 but got " n
 
-instance (ObjectGet a1, ObjectGet a2, ObjectGet a3, ObjectGet a4, ObjectGet a5, ObjectGet a6) => ObjectGet (a1, a2, a3, a4, a5, a6) where
+instance (Unpackable a1, Unpackable a2, Unpackable a3, Unpackable a4, Unpackable a5, Unpackable a6) => Unpackable (a1, a2, a3, a4, a5, a6) where
   get = parseArray f where
     f 6 = get >>= \a1 -> get >>= \a2 -> get >>= \a3 -> get >>= \a4 -> get >>= \a5 -> get >>= \a6 -> return (a1, a2, a3, a4, a5, a6)
     f n = fail $ printf "wrong tupple size: expected 6 but got " n
 
-instance (ObjectGet a1, ObjectGet a2, ObjectGet a3, ObjectGet a4, ObjectGet a5, ObjectGet a6, ObjectGet a7) => ObjectGet (a1, a2, a3, a4, a5, a6, a7) where
+instance (Unpackable a1, Unpackable a2, Unpackable a3, Unpackable a4, Unpackable a5, Unpackable a6, Unpackable a7) => Unpackable (a1, a2, a3, a4, a5, a6, a7) where
   get = parseArray f where
     f 7 = get >>= \a1 -> get >>= \a2 -> get >>= \a3 -> get >>= \a4 -> get >>= \a5 -> get >>= \a6 -> get >>= \a7 -> return (a1, a2, a3, a4, a5, a6, a7)
     f n = fail $ printf "wrong tupple size: expected 7 but got " n
 
-instance (ObjectGet a1, ObjectGet a2, ObjectGet a3, ObjectGet a4, ObjectGet a5, ObjectGet a6, ObjectGet a7, ObjectGet a8) => ObjectGet (a1, a2, a3, a4, a5, a6, a7, a8) where
+instance (Unpackable a1, Unpackable a2, Unpackable a3, Unpackable a4, Unpackable a5, Unpackable a6, Unpackable a7, Unpackable a8) => Unpackable (a1, a2, a3, a4, a5, a6, a7, a8) where
   get = parseArray f where
     f 8 = get >>= \a1 -> get >>= \a2 -> get >>= \a3 -> get >>= \a4 -> get >>= \a5 -> get >>= \a6 -> get >>= \a7 -> get >>= \a8 -> return (a1, a2, a3, a4, a5, a6, a7, a8)
     f n = fail $ printf "wrong tupple size: expected 8 but got " n
 
-instance (ObjectGet a1, ObjectGet a2, ObjectGet a3, ObjectGet a4, ObjectGet a5, ObjectGet a6, ObjectGet a7, ObjectGet a8, ObjectGet a9) => ObjectGet (a1, a2, a3, a4, a5, a6, a7, a8, a9) where
+instance (Unpackable a1, Unpackable a2, Unpackable a3, Unpackable a4, Unpackable a5, Unpackable a6, Unpackable a7, Unpackable a8, Unpackable a9) => Unpackable (a1, a2, a3, a4, a5, a6, a7, a8, a9) where
   get = parseArray f where
     f 9 = get >>= \a1 -> get >>= \a2 -> get >>= \a3 -> get >>= \a4 -> get >>= \a5 -> get >>= \a6 -> get >>= \a7 -> get >>= \a8 -> get >>= \a9 -> return (a1, a2, a3, a4, a5, a6, a7, a8, a9)
     f n = fail $ printf "wrong tupple size: expected 9 but got " n
@@ -193,13 +225,13 @@ parseArray aget = do
     _ ->
       fail $ printf "invlid array tag: 0x%02X" c
 
-instance (ObjectGet k, ObjectGet v) => ObjectGet [(k, v)] where
+instance (Unpackable k, Unpackable v) => Unpackable [(k, v)] where
   get = parseMap (flip replicateM parsePair)
 
-instance (ObjectGet k, ObjectGet v) => ObjectGet (V.Vector (k, v)) where
+instance (Unpackable k, Unpackable v) => Unpackable (V.Vector (k, v)) where
   get = parseMap (flip V.replicateM parsePair)
 
-parsePair :: (ObjectGet k, ObjectGet v) => A.Parser (k, v)
+parsePair :: (Unpackable k, Unpackable v) => A.Parser (k, v)
 parsePair = do
   a <- get
   b <- get
@@ -218,6 +250,12 @@ parseMap aget = do
     _ ->
       fail $ printf "invlid map tag: 0x%02X" c
 
+instance Unpackable a => Unpackable (Maybe a) where
+  get = 
+    A.choice
+    [ liftM Just get
+    , liftM (\() -> Nothing) get ]
+
 parseUint16 :: A.Parser Word16
 parseUint16 = do
   b0 <- A.anyWord8

haskell/test/UserData.hs

@@ -0,0 +1,19 @@
+{-# Language TemplateHaskell #-}
+
+import Data.MessagePack
+import Data.MessagePack.Derive
+
+data T
+  = A Int String
+  | B Double
+  deriving (Show)
+
+$(deriveObject ''T)
+
+main = do
+  let bs = pack $ A 123 "hoge"
+  print bs
+  print (unpack bs :: T)
+  let cs = pack $ B 3.14
+  print cs
+  print (unpack cs :: T)