packages feed

msgpack 0.3.1.1 → 0.4.0

raw patch · 11 files changed

+927/−530 lines, 11 filesdep +template-haskell

Dependencies added: template-haskell

Files

msgpack.cabal view
@@ -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/>@@ -15,6 +15,10 @@ 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,@@ -25,17 +29,19 @@                     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
src/Data/MessagePack.hs view
@@ -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,-  -  -- * Simple functions of Pack and Unpack-  pack,-  unpack,+  module Data.MessagePack.Derive,      -- * Pack functions   packToString,@@ -44,37 +41,17 @@ 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
+ src/Data/MessagePack/Derive.hs view
@@ -0,0 +1,100 @@+{-# 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+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+      [ 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++    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 _ name _ cons _) <- 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) $ tupOrListE $ 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)++deriveObject :: Name -> Q [Dec]+deriveObject typName = do+  g <- derivePack typName+  p <- deriveUnpack typName++  TyConI (DataD _ name _ cons _) <- reify typName+  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+      [ 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
src/Data/MessagePack/Iteratee.hs view
@@ -28,10 +28,10 @@ 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
src/Data/MessagePack/Object.hs view
@@ -1,6 +1,7 @@ {-# Language TypeSynonymInstances #-} {-# Language FlexibleInstances #-} {-# Language OverlappingInstances #-}+{-# Language IncoherentInstances #-} {-# Language DeriveDataTypeable #-}  --------------------------------------------------------------------@@ -23,16 +24,21 @@      -- * 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 @@       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-type Result a = Either String a+  -- | Decode a value from MessagePack object+  tryFromObject :: Object -> Either String a+  tryFromObject = tryUnpack . pack  instance OBJECT Object where   toObject = id-  fromObject = Right+  tryFromObject = Right -fromObjectError :: String-fromObjectError = "fromObject: cannot cast"+tryFromObjectError :: Either String a+tryFromObjectError = Left "tryFromObject: cannot cast"  instance OBJECT () where   toObject = const ObjectNil-  fromObject ObjectNil = Right ()-  fromObject _ = Left fromObjectError+  tryFromObject ObjectNil = Right ()+  tryFromObject _ = tryFromObjectError  instance OBJECT Int where   toObject = ObjectInteger-  fromObject (ObjectInteger n) = Right n-  fromObject _ = Left fromObjectError+  tryFromObject (ObjectInteger n) = Right n+  tryFromObject _ = tryFromObjectError  instance OBJECT Bool where   toObject = ObjectBool-  fromObject (ObjectBool b) = Right b-  fromObject _ = Left fromObjectError+  tryFromObject (ObjectBool b) = Right b+  tryFromObject _ = tryFromObjectError  instance OBJECT Double where   toObject = ObjectDouble-  fromObject (ObjectDouble d) = Right d-  fromObject _ = Left fromObjectError+  tryFromObject (ObjectDouble d) = Right d+  tryFromObject _ = tryFromObjectError  instance OBJECT B.ByteString where   toObject = ObjectRAW-  fromObject (ObjectRAW bs) = Right bs-  fromObject _ = Left fromObjectError+  tryFromObject (ObjectRAW bs) = Right bs+  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) =-    mapM fromObject arr-  fromObject _ =-    Left fromObjectError+  tryFromObject (ObjectArray arr) =+    mapM tryFromObject arr+  tryFromObject _ =+    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-    mapM (\(a, b) -> liftM2 (,) (fromObject a) (fromObject b)) mem-  fromObject _ =-    Left fromObjectError+  tryFromObject (ObjectMap mem) = do+    mapM (\(a, b) -> liftM2 (,) (tryFromObject a) (tryFromObject b)) mem+  tryFromObject _ =+    tryFromObjectError  instance OBJECT a => OBJECT (Maybe a) where   toObject (Just a) = toObject a   toObject Nothing = ObjectNil   -  fromObject ObjectNil = return Nothing-  fromObject obj = liftM Just $ fromObject obj+  tryFromObject ObjectNil = return Nothing+  tryFromObject obj = liftM Just $ tryFromObject obj
+ src/Data/MessagePack/Pack.hs view
@@ -0,0 +1,186 @@+{-# Language FlexibleInstances #-}+{-# Language IncoherentInstances #-}+{-# Language OverlappingInstances #-}+{-# Language TypeSynonymInstances #-}++--------------------------------------------------------------------+-- |+-- Module    : Data.MessagePack.Pack+-- Copyright : (c) Hideyuki Tanaka, 2009-2010+-- License   : BSD3+--+-- Maintainer:  tanaka.hideyuki@gmail.com+-- Stability :  experimental+-- Portability: portable+--+-- MessagePack Serializer using @Data.Binary.Pack@+--+--------------------------------------------------------------------++module Data.MessagePack.Pack (+  -- * Serializable class+  Packable(..),+  -- * Simple function to pack a Haskell value+  pack,+  ) where++import Data.Binary.Put+import Data.Binary.IEEE754+import Data.Bits+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy as L+import qualified Data.Vector as V++-- | Serializable class+class Packable a where+  -- | Serialize a value+  put :: a -> Put++-- | Pack Haskell data to MessagePack string.+pack :: Packable a => a -> L.ByteString+pack = runPut . put++instance Packable Int where+  put n =+    case n of+      _ | n >= 0 && n <= 127 ->+        putWord8 $ fromIntegral n+      _ | n >= -32 && n <= -1 ->+        putWord8 $ fromIntegral n+      _ | n >= 0 && n < 0x100 -> do+        putWord8 0xCC+        putWord8 $ fromIntegral n+      _ | n >= 0 && n < 0x10000 -> do+        putWord8 0xCD+        putWord16be $ fromIntegral n+      _ | n >= 0 && n < 0x100000000 -> do+        putWord8 0xCE+        putWord32be $ fromIntegral n+      _ | n >= 0 -> do+        putWord8 0xCF+        putWord64be $ fromIntegral n+      _ | n >= -0x80 -> do+        putWord8 0xD0+        putWord8 $ fromIntegral n+      _ | n >= -0x8000 -> do+        putWord8 0xD1+        putWord16be $ fromIntegral n+      _ | n >= -0x80000000 -> do+        putWord8 0xD2+        putWord32be $ fromIntegral n+      _ -> do+        putWord8 0xD3+        putWord64be $ fromIntegral n++instance Packable () where+  put _ = +    putWord8 0xC0++instance Packable Bool where+  put True = putWord8 0xC3+  put False = putWord8 0xC2++instance Packable Double where+  put d = do+    putWord8 0xCB+    putFloat64be d++instance Packable String where+  put = putString length (putByteString . B8.pack)++instance Packable B.ByteString where+  put = putString B.length putByteString++instance Packable L.ByteString where+  put = putString (fromIntegral . L.length) putLazyByteString++putString :: (s -> Int) -> (s -> Put) -> s -> Put+putString lf pf str = do+  case lf str of+    len | len <= 31 -> do+      putWord8 $ 0xA0 .|. fromIntegral len+    len | len < 0x10000 -> do+      putWord8 0xDA+      putWord16be $ fromIntegral len+    len -> do+      putWord8 0xDB+      putWord32be $ fromIntegral len+  pf str++instance Packable a => Packable [a] where+  put = putArray length (mapM_ put)++instance Packable a => Packable (V.Vector a) where+  put = putArray V.length (V.mapM_ put)++instance (Packable a1, Packable a2) => Packable (a1, a2) where+  put = putArray (const 2) f where+    f (a1, a2) = put a1 >> put a2++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 (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 (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 (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 (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 (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 (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++putArray :: (a -> Int) -> (a -> Put) -> a -> Put+putArray lf pf arr = do+  case lf arr of+    len | len <= 15 ->+      putWord8 $ 0x90 .|. fromIntegral len+    len | len < 0x10000 -> do+      putWord8 0xDC+      putWord16be $ fromIntegral len+    len -> do+      putWord8 0xDD+      putWord32be $ fromIntegral len+  pf arr++instance (Packable k, Packable v) => Packable [(k, v)] where+  put = putMap length (mapM_ putPair)++instance (Packable k, Packable v) => Packable (V.Vector (k, v)) where+  put = putMap V.length (V.mapM_ putPair)++putPair :: (Packable a, Packable b) => (a, b) -> Put+putPair (a, b) = put a >> put b++putMap :: (a -> Int) -> (a -> Put) -> a -> Put+putMap lf pf m = do+  case lf m of+    len | len <= 15 ->+      putWord8 $ 0x80 .|. fromIntegral len+    len | len < 0x10000 -> do+      putWord8 0xDE+      putWord16be $ fromIntegral len+    len -> do+      putWord8 0xDF+      putWord32be $ fromIntegral len+  pf m++instance Packable a => Packable (Maybe a) where+  put Nothing = put ()+  put (Just a) = put a
− src/Data/MessagePack/Parser.hs 
@@ -1,270 +0,0 @@-{-# Language FlexibleInstances #-}-{-# Language IncoherentInstances #-}-{-# Language OverlappingInstances #-}-{-# Language TypeSynonymInstances #-}------------------------------------------------------------------------- |--- Module    : Data.MessagePack.Parser--- Copyright : (c) Hideyuki Tanaka, 2009-2010--- License   : BSD3------ Maintainer:  tanaka.hideyuki@gmail.com--- Stability :  experimental--- Portability: portable------ MessagePack Deserializer using @Data.Attoparsec@--------------------------------------------------------------------------module Data.MessagePack.Parser(-  -- * MessagePack deserializer-  ObjectGet(..),-  ) where--import Control.Monad-import qualified Data.Attoparsec as A-import Data.Binary.Get-import Data.Binary.IEEE754-import Data.Bits-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Lazy as L-import Data.Int-import qualified Data.Vector as V-import Data.Word-import Text.Printf--import Data.MessagePack.Object---- | Deserializable class-class ObjectGet a where-  -- | Deserialize a value-  get :: A.Parser a--instance ObjectGet 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 ObjectGet Int where-  get = do-    c <- A.anyWord8-    case c of-      _ | c .&. 0x80 == 0x00 ->-        return $ fromIntegral c-      _ | c .&. 0xE0 == 0xE0 ->-        return $ fromIntegral (fromIntegral c :: Int8)-      0xCC ->-        return . fromIntegral =<< A.anyWord8-      0xCD ->-        return . fromIntegral =<< parseUint16-      0xCE ->-        return . fromIntegral =<< parseUint32-      0xCF ->-        return . fromIntegral =<< parseUint64-      0xD0 ->-        return . fromIntegral =<< parseInt8-      0xD1 ->-        return . fromIntegral =<< parseInt16-      0xD2 ->-        return . fromIntegral =<< parseInt32-      0xD3 ->-        return . fromIntegral =<< parseInt64-      _ ->-        fail $ printf "invlid integer tag: 0x%02X" c--instance ObjectGet () where-  get = do-    c <- A.anyWord8-    case c of-      0xC0 ->-        return ()-      _ ->-        fail $ printf "invlid nil tag: 0x%02X" c--instance ObjectGet Bool where-  get = do-    c <- A.anyWord8-    case c of-      0xC3 ->-        return True-      0xC2 ->-        return False-      _ ->-        fail $ printf "invlid bool tag: 0x%02X" c--instance ObjectGet Double where-  get = do-    c <- A.anyWord8-    case c of-      0xCA ->-        return . realToFrac . runGet getFloat32be . toLBS =<< A.take 4-      0xCB ->-        return . runGet getFloat64be . toLBS =<< A.take 8-      _ ->-        fail $ printf "invlid double tag: 0x%02X" c--instance ObjectGet String where-  get = parseString (\n -> return . B8.unpack =<< A.take n)--instance ObjectGet B.ByteString where-  get = parseString A.take--instance ObjectGet L.ByteString where-  get = parseString (\n -> do bs <- A.take n; return $ L.fromChunks [bs])--parseString :: (Int -> A.Parser a) -> A.Parser a-parseString aget = do-  c <- A.anyWord8-  case c of-    _ | c .&. 0xE0 == 0xA0 ->-      aget . fromIntegral $ c .&. 0x1F-    0xDA ->-      aget . fromIntegral =<< parseUint16-    0xDB ->-      aget . fromIntegral =<< parseUint32-    _ ->-      fail $ printf "invlid raw tag: 0x%02X" c--instance ObjectGet a => ObjectGet [a] where-  get = parseArray (flip replicateM get)--instance ObjectGet a => ObjectGet (V.Vector a) where-  get = parseArray (flip V.replicateM get)--instance (ObjectGet a1, ObjectGet a2) => ObjectGet (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-  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-  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-  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-  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-  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-  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-  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--parseArray :: (Int -> A.Parser a) -> A.Parser a-parseArray aget = do-  c <- A.anyWord8-  case c of-    _ | c .&. 0xF0 == 0x90 ->-      aget . fromIntegral $ c .&. 0x0F-    0xDC ->-      aget . fromIntegral =<< parseUint16-    0xDD ->-      aget . fromIntegral =<< parseUint32-    _ ->-      fail $ printf "invlid array tag: 0x%02X" c--instance (ObjectGet k, ObjectGet v) => ObjectGet [(k, v)] where-  get = parseMap (flip replicateM parsePair)--instance (ObjectGet k, ObjectGet v) => ObjectGet (V.Vector (k, v)) where-  get = parseMap (flip V.replicateM parsePair)--parsePair :: (ObjectGet k, ObjectGet v) => A.Parser (k, v)-parsePair = do-  a <- get-  b <- get-  return (a, b)--parseMap :: (Int -> A.Parser a) -> A.Parser a-parseMap aget = do-  c <- A.anyWord8-  case c of-    _ | c .&. 0xF0 == 0x80 ->-      aget . fromIntegral $ c .&. 0x0F-    0xDE ->-      aget . fromIntegral =<< parseUint16-    0xDF ->-      aget . fromIntegral =<< parseUint32-    _ ->-      fail $ printf "invlid map tag: 0x%02X" c--parseUint16 :: A.Parser Word16-parseUint16 = do-  b0 <- A.anyWord8-  b1 <- A.anyWord8-  return $ (fromIntegral b0 `shiftL` 8) .|. fromIntegral b1--parseUint32 :: A.Parser Word32-parseUint32 = do-  b0 <- A.anyWord8-  b1 <- A.anyWord8-  b2 <- A.anyWord8-  b3 <- A.anyWord8-  return $ (fromIntegral b0 `shiftL` 24) .|.-           (fromIntegral b1 `shiftL` 16) .|.-           (fromIntegral b2 `shiftL` 8) .|.-           fromIntegral b3--parseUint64 :: A.Parser Word64-parseUint64 = do-  b0 <- A.anyWord8-  b1 <- A.anyWord8-  b2 <- A.anyWord8-  b3 <- A.anyWord8-  b4 <- A.anyWord8-  b5 <- A.anyWord8-  b6 <- A.anyWord8-  b7 <- A.anyWord8-  return $ (fromIntegral b0 `shiftL` 56) .|.-           (fromIntegral b1 `shiftL` 48) .|.-           (fromIntegral b2 `shiftL` 40) .|.-           (fromIntegral b3 `shiftL` 32) .|.-           (fromIntegral b4 `shiftL` 24) .|.-           (fromIntegral b5 `shiftL` 16) .|.-           (fromIntegral b6 `shiftL` 8) .|.-           fromIntegral b7--parseInt8 :: A.Parser Int8-parseInt8 = return . fromIntegral =<< A.anyWord8--parseInt16 :: A.Parser Int16-parseInt16 = return . fromIntegral =<< parseUint16--parseInt32 :: A.Parser Int32-parseInt32 = return . fromIntegral =<< parseUint32--parseInt64 :: A.Parser Int64-parseInt64 = return . fromIntegral =<< parseUint64--toLBS :: B.ByteString -> L.ByteString-toLBS bs = L.fromChunks [bs]
− src/Data/MessagePack/Put.hs 
@@ -1,196 +0,0 @@-{-# Language FlexibleInstances #-}-{-# Language IncoherentInstances #-}-{-# Language OverlappingInstances #-}-{-# Language TypeSynonymInstances #-}------------------------------------------------------------------------- |--- Module    : Data.MessagePack.Put--- Copyright : (c) Hideyuki Tanaka, 2009-2010--- License   : BSD3------ Maintainer:  tanaka.hideyuki@gmail.com--- Stability :  experimental--- Portability: portable------ MessagePack Serializer using @Data.Binary.Put@--------------------------------------------------------------------------module Data.MessagePack.Put(-  -- * Serializable class-  ObjectPut(..),-  ) where--import Data.Binary.Put-import Data.Binary.IEEE754-import Data.Bits-import qualified Data.ByteString as B-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-  -- | Serialize a value-  put :: a -> Put--instance ObjectPut 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--instance ObjectPut Int where-  put n =-    case n of-      _ | n >= 0 && n <= 127 ->-        putWord8 $ fromIntegral n-      _ | n >= -32 && n <= -1 ->-        putWord8 $ fromIntegral n-      _ | n >= 0 && n < 0x100 -> do-        putWord8 0xCC-        putWord8 $ fromIntegral n-      _ | n >= 0 && n < 0x10000 -> do-        putWord8 0xCD-        putWord16be $ fromIntegral n-      _ | n >= 0 && n < 0x100000000 -> do-        putWord8 0xCE-        putWord32be $ fromIntegral n-      _ | n >= 0 -> do-        putWord8 0xCF-        putWord64be $ fromIntegral n-      _ | n >= -0x80 -> do-        putWord8 0xD0-        putWord8 $ fromIntegral n-      _ | n >= -0x8000 -> do-        putWord8 0xD1-        putWord16be $ fromIntegral n-      _ | n >= -0x80000000 -> do-        putWord8 0xD2-        putWord32be $ fromIntegral n-      _ -> do-        putWord8 0xD3-        putWord64be $ fromIntegral n--instance ObjectPut () where-  put _ = -    putWord8 0xC0--instance ObjectPut Bool where-  put True = putWord8 0xC3-  put False = putWord8 0xC2--instance ObjectPut Double where-  put d = do-    putWord8 0xCB-    putFloat64be d--instance ObjectPut String where-  put = putString length (putByteString . B8.pack)--instance ObjectPut B.ByteString where-  put = putString B.length putByteString--instance ObjectPut L.ByteString where-  put = putString (fromIntegral . L.length) putLazyByteString--putString :: (s -> Int) -> (s -> Put) -> s -> Put-putString lf pf str = do-  case lf str of-    len | len <= 31 -> do-      putWord8 $ 0xA0 .|. fromIntegral len-    len | len < 0x10000 -> do-      putWord8 0xDA-      putWord16be $ fromIntegral len-    len -> do-      putWord8 0xDB-      putWord32be $ fromIntegral len-  pf str--instance ObjectPut a => ObjectPut [a] where-  put = putArray length (mapM_ put)--instance ObjectPut a => ObjectPut (V.Vector a) where-  put = putArray V.length (V.mapM_ put)--instance (ObjectPut a1, ObjectPut a2) => ObjectPut (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-  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-  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-  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-  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-  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-  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-  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--putArray :: (a -> Int) -> (a -> Put) -> a -> Put-putArray lf pf arr = do-  case lf arr of-    len | len <= 15 ->-      putWord8 $ 0x90 .|. fromIntegral len-    len | len < 0x10000 -> do-      putWord8 0xDC-      putWord16be $ fromIntegral len-    len -> do-      putWord8 0xDD-      putWord32be $ fromIntegral len-  pf arr--instance (ObjectPut k, ObjectPut v) => ObjectPut [(k, v)] where-  put = putMap length (mapM_ putPair)--instance (ObjectPut k, ObjectPut v) => ObjectPut (V.Vector (k, v)) where-  put = putMap V.length (V.mapM_ putPair)--putPair :: (ObjectPut a, ObjectPut b) => (a, b) -> Put-putPair (a, b) = put a >> put b--putMap :: (a -> Int) -> (a -> Put) -> a -> Put-putMap lf pf m = do-  case lf m of-    len | len <= 15 ->-      putWord8 $ 0x80 .|. fromIntegral len-    len | len < 0x10000 -> do-      putWord8 0xDE-      putWord16be $ fromIntegral len-    len -> do-      putWord8 0xDF-      putWord32be $ fromIntegral len-  pf m
+ src/Data/MessagePack/Unpack.hs view
@@ -0,0 +1,308 @@+{-# Language FlexibleInstances #-}+{-# Language IncoherentInstances #-}+{-# Language OverlappingInstances #-}+{-# Language TypeSynonymInstances #-}+{-# Language DeriveDataTypeable #-}++--------------------------------------------------------------------+-- |+-- Module    : Data.MessagePack.Unpack+-- Copyright : (c) Hideyuki Tanaka, 2009-2010+-- License   : BSD3+--+-- Maintainer:  tanaka.hideyuki@gmail.com+-- Stability :  experimental+-- Portability: portable+--+-- MessagePack Deserializer using @Data.Attoparsec@+--+--------------------------------------------------------------------++module Data.MessagePack.Unpack(+  -- * MessagePack deserializer+  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+import Data.Binary.IEEE754+import Data.Bits+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++-- | Deserializable class+class Unpackable a where+  -- | Deserialize a value+  get :: A.Parser a++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++-- | 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+      _ | c .&. 0x80 == 0x00 ->+        return $ fromIntegral c+      _ | c .&. 0xE0 == 0xE0 ->+        return $ fromIntegral (fromIntegral c :: Int8)+      0xCC ->+        return . fromIntegral =<< A.anyWord8+      0xCD ->+        return . fromIntegral =<< parseUint16+      0xCE ->+        return . fromIntegral =<< parseUint32+      0xCF ->+        return . fromIntegral =<< parseUint64+      0xD0 ->+        return . fromIntegral =<< parseInt8+      0xD1 ->+        return . fromIntegral =<< parseInt16+      0xD2 ->+        return . fromIntegral =<< parseInt32+      0xD3 ->+        return . fromIntegral =<< parseInt64+      _ ->+        fail $ printf "invlid integer tag: 0x%02X" c++instance Unpackable () where+  get = do+    c <- A.anyWord8+    case c of+      0xC0 ->+        return ()+      _ ->+        fail $ printf "invlid nil tag: 0x%02X" c++instance Unpackable Bool where+  get = do+    c <- A.anyWord8+    case c of+      0xC3 ->+        return True+      0xC2 ->+        return False+      _ ->+        fail $ printf "invlid bool tag: 0x%02X" c++instance Unpackable Double where+  get = do+    c <- A.anyWord8+    case c of+      0xCA ->+        return . realToFrac . runGet getFloat32be . toLBS =<< A.take 4+      0xCB ->+        return . runGet getFloat64be . toLBS =<< A.take 8+      _ ->+        fail $ printf "invlid double tag: 0x%02X" c++instance Unpackable String where+  get = parseString (\n -> return . B8.unpack =<< A.take n)++instance Unpackable B.ByteString where+  get = parseString A.take++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+parseString aget = do+  c <- A.anyWord8+  case c of+    _ | c .&. 0xE0 == 0xA0 ->+      aget . fromIntegral $ c .&. 0x1F+    0xDA ->+      aget . fromIntegral =<< parseUint16+    0xDB ->+      aget . fromIntegral =<< parseUint32+    _ ->+      fail $ printf "invlid raw tag: 0x%02X" c++instance Unpackable a => Unpackable [a] where+  get = parseArray (flip replicateM get)++instance Unpackable a => Unpackable (V.Vector a) where+  get = parseArray (flip V.replicateM get)++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 (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 (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 (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 (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 (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 (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 (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++parseArray :: (Int -> A.Parser a) -> A.Parser a+parseArray aget = do+  c <- A.anyWord8+  case c of+    _ | c .&. 0xF0 == 0x90 ->+      aget . fromIntegral $ c .&. 0x0F+    0xDC ->+      aget . fromIntegral =<< parseUint16+    0xDD ->+      aget . fromIntegral =<< parseUint32+    _ ->+      fail $ printf "invlid array tag: 0x%02X" c++instance (Unpackable k, Unpackable v) => Unpackable [(k, v)] where+  get = parseMap (flip replicateM parsePair)++instance (Unpackable k, Unpackable v) => Unpackable (V.Vector (k, v)) where+  get = parseMap (flip V.replicateM parsePair)++parsePair :: (Unpackable k, Unpackable v) => A.Parser (k, v)+parsePair = do+  a <- get+  b <- get+  return (a, b)++parseMap :: (Int -> A.Parser a) -> A.Parser a+parseMap aget = do+  c <- A.anyWord8+  case c of+    _ | c .&. 0xF0 == 0x80 ->+      aget . fromIntegral $ c .&. 0x0F+    0xDE ->+      aget . fromIntegral =<< parseUint16+    0xDF ->+      aget . fromIntegral =<< parseUint32+    _ ->+      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+  b1 <- A.anyWord8+  return $ (fromIntegral b0 `shiftL` 8) .|. fromIntegral b1++parseUint32 :: A.Parser Word32+parseUint32 = do+  b0 <- A.anyWord8+  b1 <- A.anyWord8+  b2 <- A.anyWord8+  b3 <- A.anyWord8+  return $ (fromIntegral b0 `shiftL` 24) .|.+           (fromIntegral b1 `shiftL` 16) .|.+           (fromIntegral b2 `shiftL` 8) .|.+           fromIntegral b3++parseUint64 :: A.Parser Word64+parseUint64 = do+  b0 <- A.anyWord8+  b1 <- A.anyWord8+  b2 <- A.anyWord8+  b3 <- A.anyWord8+  b4 <- A.anyWord8+  b5 <- A.anyWord8+  b6 <- A.anyWord8+  b7 <- A.anyWord8+  return $ (fromIntegral b0 `shiftL` 56) .|.+           (fromIntegral b1 `shiftL` 48) .|.+           (fromIntegral b2 `shiftL` 40) .|.+           (fromIntegral b3 `shiftL` 32) .|.+           (fromIntegral b4 `shiftL` 24) .|.+           (fromIntegral b5 `shiftL` 16) .|.+           (fromIntegral b6 `shiftL` 8) .|.+           fromIntegral b7++parseInt8 :: A.Parser Int8+parseInt8 = return . fromIntegral =<< A.anyWord8++parseInt16 :: A.Parser Int16+parseInt16 = return . fromIntegral =<< parseUint16++parseInt32 :: A.Parser Int32+parseInt32 = return . fromIntegral =<< parseUint32++parseInt64 :: A.Parser Int64+parseInt64 = return . fromIntegral =<< parseUint64++toLBS :: B.ByteString -> L.ByteString+toLBS bs = L.fromChunks [bs]
+ test/Test.hs view
@@ -0,0 +1,64 @@+import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck++import Control.Monad+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as L+import Data.MessagePack++mid :: (Packable a, Unpackable a) => a -> a+mid = unpack . pack++prop_mid_int a = a == mid a+  where types = a :: Int+prop_mid_nil a = a == mid a+  where types = a :: ()+prop_mid_bool a = a == mid a+  where types = a :: Bool+prop_mid_double a = a == mid a+  where types = a :: Double+prop_mid_string a = a == mid a+  where types = a :: String+prop_mid_bytestring a = B.pack a == mid (B.pack a)+  where types = a :: String+prop_mid_lazy_bytestring a = (L.pack a) == mid (L.pack a)+  where types = a :: String+prop_mid_array_int a = a == mid a+  where types = a :: [Int]+prop_mid_array_string a = a == mid a+  where types = a :: [String]+prop_mid_pair2 a = a == mid a+  where types = a :: (Int, Int)+prop_mid_pair3 a = a == mid a+  where types = a :: (Int, Int, Int)+prop_mid_pair4 a = a == mid a+  where types = a :: (Int, Int, Int, Int)+prop_mid_pair5 a = a == mid a+  where types = a :: (Int, Int, Int, Int, Int)+prop_mid_map_int_double a = a == mid a+  where types = a :: [(Int, Double)]+prop_mid_map_string_string a = a == mid a+  where types = a :: [(String, String)]++tests =+  [ testGroup "simple"+    [ testProperty "int" prop_mid_int+    , testProperty "nil" prop_mid_nil+    , testProperty "bool" prop_mid_bool+    , testProperty "double" prop_mid_double+    , testProperty "string" prop_mid_string+    , testProperty "bytestring" prop_mid_bytestring+    , testProperty "lazy-bytestring" prop_mid_lazy_bytestring+    , testProperty "[int]" prop_mid_array_int+    , testProperty "[string]" prop_mid_array_string+    , testProperty "(int, int)" prop_mid_pair2+    , testProperty "(int, int, int)" prop_mid_pair3+    , testProperty "(int, int, int, int)" prop_mid_pair4+    , testProperty "(int, int, int, int, int)" prop_mid_pair5+    , testProperty "[(int, double)]" prop_mid_map_int_double+    , testProperty "[(string, string)]" prop_mid_map_string_string+    ]+  ]++main = defaultMain tests
+ test/UserData.hs view
@@ -0,0 +1,45 @@+{-# Language TemplateHaskell #-}++import Data.MessagePack+import Data.MessagePack.Derive++data T+  = A Int String+  | B Double+  deriving (Show)++$(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+  print (unpack bs :: T)+  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)