packages feed

msgpack 0.6.4 → 0.7.0

raw patch · 17 files changed

+1188/−1238 lines, 17 filesdep +QuickCheckdep +blaze-builderdep +containersdep −binarydep −data-binary-ieee754dep ~attoparsec

Dependencies added: QuickCheck, blaze-builder, containers, hashable, test-framework, test-framework-quickcheck2, unordered-containers

Dependencies removed: binary, data-binary-ieee754

Dependency ranges changed: attoparsec

Files

+ Data/MessagePack.hs view
@@ -0,0 +1,27 @@+--------------------------------------------------------------------+-- |+-- Module    : Data.MessagePack+-- Copyright : (c) Hideyuki Tanaka, 2009-2011+-- License   : BSD3+--+-- Maintainer:  tanaka.hideyuki@gmail.com+-- Stability :  experimental+-- Portability: portable+--+-- Simple interface to pack and unpack MessagePack data.+--+--------------------------------------------------------------------++module Data.MessagePack(+  module Data.MessagePack.Assoc,+  module Data.MessagePack.Pack,+  module Data.MessagePack.Unpack,+  module Data.MessagePack.Object,+  module Data.MessagePack.Derive,+  ) where++import Data.MessagePack.Assoc+import Data.MessagePack.Pack+import Data.MessagePack.Unpack+import Data.MessagePack.Object+import Data.MessagePack.Derive
+ Data/MessagePack/Assoc.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}++--------------------------------------------------------------------+-- |+-- Module    : Data.MessagePack.Assoc+-- Copyright : (c) Daiki Handa, 2010-2011+-- License   : BSD3+--+-- Maintainer:  tanaka.hideyuki@gmail.com+-- Stability :  experimental+-- Portability: portable+--+-- MessagePack map labeling type+--+--------------------------------------------------------------------++module Data.MessagePack.Assoc (+  Assoc(..)+  ) where++import Control.DeepSeq+import Data.Typeable++-- not defined for general Functor for performance reason.+-- (ie. you would want to write custom instances for each type using specialized mapM-like functions)+newtype Assoc a+  = Assoc { unAssoc :: a }+  deriving (Show, Eq, Ord, Typeable, NFData)
+ Data/MessagePack/Derive.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances #-}++module Data.MessagePack.Derive (+  -- | deriving OBJECT+  derivePack,+  deriveUnpack,+  deriveObject,+  ) where++import Control.Monad+import Control.Monad.Error () -- MonadPlus instance for Either e+import Data.Char+import Data.List+import qualified Data.Text as T+import Language.Haskell.TH++import Data.MessagePack.Assoc+import Data.MessagePack.Pack+import Data.MessagePack.Unpack+import Data.MessagePack.Object++derivePack :: Bool -> Name -> Q [Dec]+derivePack asObject tyName = do+  info <- reify tyName+  d <- case info of+    TyConI (DataD _ {- cxt -} name tyVars cons _ {- derivings -}) -> do+      ds <- [d| from v = $(caseE [| v |] (map alt cons)) |]+      instanceD (cx tyVars) (ct ''Packable name tyVars) $+        map return ds++    _ -> error $ "cant derive Packable: " ++ show tyName+  return [d]++  where+    alt (NormalC conName elms) = do+      vars <- replicateM (length elms) (newName "v")+      match (conP conName $ map varP vars)+        (normalB [| from $(tupE $ map varE vars) |])+        []++    alt (RecC conName elms) = do+      vars <- replicateM (length elms) (newName "v")+      if asObject+        then+        match (conP conName $ map varP vars)+        (normalB+         [| from $ Assoc+              $(listE [ [| ( $(return $ LitE $ StringL $ key conName fname) :: T.Text+                           , toObject $(varE v)) |]+                      | (v, (fname, _, _)) <- zip vars elms])+          |])+        []+        else+        match (conP conName $ map varP vars)+        (normalB [| from $(tupE $ map varE vars) |])+        []++    alt c = error $ "unsupported constructor: " ++ pprint c++deriveUnpack :: Bool -> Name -> Q [Dec]+deriveUnpack asObject tyName = do+  info <- reify tyName+  d <- case info of+    TyConI (DataD _ {- cxt -} name tyVars cons _ {- derivings -}) -> do+      ds <- [d| get = $(foldl1 (\x y -> [| $x `mplus` $y |]) $ map alt cons) |]+      instanceD (cx tyVars) (ct ''Unpackable name tyVars) $+        map return ds++    _ -> error $ "cant derive Unpackable: " ++ show tyName+  return [d]++  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")+      if asObject+        then+        doE $ [ bindS (conP 'Assoc [varP var]) [| get |] ]+            ++ zipWith (binds conName var) vars elms +++            [ noBindS [| return $(foldl appE (conE conName) $ map varE vars) |] ]+        else+        doE [ bindS (tupP $ map varP vars) [| get |]+            , noBindS [| return $(foldl appE (conE conName) $ map varE vars) |]+            ]++    alt c = error $ "unsupported constructor: " ++ pprint c++    binds conName var res (fname, _, _) =+      bindS (varP res)+            [| failN $ lookup ($(return $ LitE $ StringL $ key conName fname) :: T.Text)+                              $(varE var) |]++deriveObject :: Bool -> Name -> Q [Dec]+deriveObject asObject tyName = do+  g <- derivePack asObject tyName+  p <- deriveUnpack asObject tyName+  info <- reify tyName+  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) =+  case tryFromObject a of+    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+  where+    prefix = map toLower $ nameBase conName+    sFname = nameBase fname+    uncapital (c:cs) | isUpper c = toLower c : cs+    uncapital cs = cs
+ Data/MessagePack/Internal/Utf8.hs view
@@ -0,0 +1,28 @@+module Data.MessagePack.Internal.Utf8 (+  encodeUtf8,+  decodeUtf8,+  skipChar,+  toLBS,+  fromLBS,+  ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Encoding.Error as T++encodeUtf8 :: String -> B.ByteString+encodeUtf8 = T.encodeUtf8 . T.pack++decodeUtf8 :: B.ByteString -> String+decodeUtf8 = T.unpack . T.decodeUtf8With skipChar++skipChar :: T.OnDecodeError+skipChar _ _ = Nothing++toLBS :: B.ByteString -> BL.ByteString+toLBS bs = BL.fromChunks [bs]++fromLBS :: BL.ByteString -> B.ByteString+fromLBS = B.concat . BL.toChunks
+ Data/MessagePack/Object.hs view
@@ -0,0 +1,366 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, IncoherentInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}++--------------------------------------------------------------------+-- |+-- Module    : Data.MessagePack.Object+-- Copyright : (c) Hideyuki Tanaka, 2009-2011+-- License   : BSD3+--+-- Maintainer:  tanaka.hideyuki@gmail.com+-- Stability :  experimental+-- Portability: portable+--+-- MessagePack object definition+--+--------------------------------------------------------------------++module Data.MessagePack.Object(+  -- * MessagePack Object+  Object(..),+  +  -- * Serialization to and from Object+  OBJECT(..),+  -- Result,+  ) where++import Control.Applicative+import Control.DeepSeq+import Control.Exception+import Control.Monad+import qualified Data.Attoparsec as A+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Hashable+import qualified Data.HashMap.Strict as HM+import qualified Data.Map as M+import qualified Data.IntMap as IM+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL+import qualified Data.Vector as V+import Data.Typeable++import Data.MessagePack.Assoc+import Data.MessagePack.Pack+import Data.MessagePack.Unpack+import Data.MessagePack.Internal.Utf8++-- | Object Representation of MessagePack data.+data Object+  = ObjectNil+  | ObjectBool Bool+  | ObjectInteger Int+  | ObjectFloat Float+  | ObjectDouble Double+  | ObjectRAW B.ByteString+  | ObjectArray [Object]+  | ObjectMap [(Object, Object)]+  deriving (Show, Eq, Ord, Typeable)  ++instance NFData Object where+  rnf obj =+    case obj of+      ObjectNil -> ()+      ObjectBool b -> rnf b+      ObjectInteger n -> rnf n+      ObjectFloat f -> rnf f+      ObjectDouble d -> rnf d+      ObjectRAW bs -> bs `seq` ()+      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 ObjectFloat get+    , liftM ObjectDouble get+    , liftM ObjectRAW get+    , liftM ObjectArray get+    , liftM (ObjectMap . unAssoc) get+    ]++instance Packable Object where+  from obj =+    case obj of+      ObjectInteger n ->+        from n+      ObjectNil ->+        from ()+      ObjectBool b ->+        from b+      ObjectFloat f ->+        from f+      ObjectDouble d ->+        from d+      ObjectRAW raw ->+        from raw+      ObjectArray arr ->+        from arr+      ObjectMap m ->+        from $ Assoc m++-- | The class of types serializable to and from MessagePack object+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 -> a+  fromObject a =+    case tryFromObject a of+      Left err ->+        throw $ UnpackError err+      Right ret ->+        ret++  -- | Decode a value from MessagePack object+  tryFromObject :: Object -> Either String a+  tryFromObject = tryUnpack . pack++instance OBJECT Object where+  toObject = id+  tryFromObject = Right++tryFromObjectError :: Either String a+tryFromObjectError = Left "tryFromObject: cannot cast"++instance OBJECT () where+  toObject = const ObjectNil+  tryFromObject ObjectNil = Right ()+  tryFromObject _ = tryFromObjectError++instance OBJECT Int where+  toObject = ObjectInteger+  tryFromObject (ObjectInteger n) = Right n+  tryFromObject _ = tryFromObjectError++instance OBJECT Bool where+  toObject = ObjectBool+  tryFromObject (ObjectBool b) = Right b+  tryFromObject _ = tryFromObjectError++instance OBJECT Double where+  toObject = ObjectDouble+  tryFromObject (ObjectDouble d) = Right d+  tryFromObject _ = tryFromObjectError++instance OBJECT Float where+  toObject = ObjectFloat+  tryFromObject (ObjectFloat f) = Right f+  tryFromObject _ = tryFromObjectError++instance OBJECT String where+  toObject = toObject . encodeUtf8+  tryFromObject obj = liftM decodeUtf8 $ tryFromObject obj++instance OBJECT B.ByteString where+  toObject = ObjectRAW+  tryFromObject (ObjectRAW bs) = Right bs+  tryFromObject _ = tryFromObjectError++instance OBJECT BL.ByteString where+  toObject = ObjectRAW . fromLBS+  tryFromObject (ObjectRAW bs) = Right $ toLBS bs+  tryFromObject _ = tryFromObjectError++instance OBJECT T.Text where+  toObject = ObjectRAW . T.encodeUtf8+  tryFromObject (ObjectRAW bs) = Right $ T.decodeUtf8With skipChar bs+  tryFromObject _ = tryFromObjectError++instance OBJECT TL.Text where+  toObject = ObjectRAW . fromLBS . TL.encodeUtf8+  tryFromObject (ObjectRAW bs) = Right $ TL.decodeUtf8With skipChar $ toLBS bs+  tryFromObject _ = tryFromObjectError++instance OBJECT a => OBJECT [a] where+  toObject = ObjectArray . map toObject+  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 (Assoc [(a,b)]) where+  toObject =+    ObjectMap . map (\(a, b) -> (toObject a, toObject b)) . unAssoc+  tryFromObject (ObjectMap mem) = do+    Assoc <$> mapM (\(a, b) -> liftM2 (,) (tryFromObject a) (tryFromObject b)) mem+  tryFromObject _ =+    tryFromObjectError++instance (OBJECT a, OBJECT b) => OBJECT (Assoc (V.Vector (a,b))) where+  toObject =+    ObjectMap . V.toList . V.map (\(a, b) -> (toObject a, toObject b)) . unAssoc+  tryFromObject (ObjectMap mem) = do+    Assoc <$> V.mapM (\(a, b) -> liftM2 (,) (tryFromObject a) (tryFromObject b)) (V.fromList mem)+  tryFromObject _ =+    tryFromObjectError++instance (Ord a, OBJECT a, OBJECT b) => OBJECT (M.Map a b) where+  toObject =+    ObjectMap . map (\(a, b) -> (toObject a, toObject b)) . M.toList+  tryFromObject (ObjectMap mem) = do+    M.fromList <$> mapM (\(a, b) -> liftM2 (,) (tryFromObject a) (tryFromObject b)) mem+  tryFromObject _ =+    tryFromObjectError++instance OBJECT b => OBJECT (IM.IntMap b) where+  toObject =+    ObjectMap . map (\(a, b) -> (toObject a, toObject b)) . IM.toList+  tryFromObject (ObjectMap mem) = do+    IM.fromList <$> mapM (\(a, b) -> liftM2 (,) (tryFromObject a) (tryFromObject b)) mem+  tryFromObject _ =+    tryFromObjectError++instance (Hashable a, Eq a, OBJECT a, OBJECT b) => OBJECT (HM.HashMap a b) where+  toObject =+    ObjectMap . map (\(a, b) -> (toObject a, toObject b)) . HM.toList+  tryFromObject (ObjectMap mem) = do+    HM.fromList <$> 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+  +  tryFromObject ObjectNil = return Nothing+  tryFromObject obj = liftM Just $ tryFromObject obj
+ Data/MessagePack/Pack.hs view
@@ -0,0 +1,220 @@+{-# LANGUAGE FlexibleInstances, IncoherentInstances, TypeSynonymInstances #-}++--------------------------------------------------------------------+-- |+-- Module    : Data.MessagePack.Pack+-- Copyright : (c) Hideyuki Tanaka, 2009-2011+-- 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 Blaze.ByteString.Builder+import Data.Bits+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.HashMap.Strict as HM+import qualified Data.Map as M+import qualified Data.IntMap as IM+import Data.Monoid+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL+import qualified Data.Vector as V+import Foreign++import Data.MessagePack.Assoc+import Data.MessagePack.Internal.Utf8++(<>) :: Monoid m => m -> m -> m+(<>) = mappend++-- | Serializable class+class Packable a where+  -- | Serialize a value+  from :: a -> Builder++-- | Pack Haskell data to MessagePack string.+pack :: Packable a => a -> BL.ByteString+pack = toLazyByteString . from++instance Packable Int where+  from n =+    case n of+      _ | n >= 0 && n <= 127 ->+        fromWord8 $ fromIntegral n+      _ | n >= -32 && n <= -1 ->+        fromWord8 $ fromIntegral n+      _ | n >= 0 && n < 0x100 ->+        fromWord8 0xCC <>+        fromWord8 (fromIntegral n)+      _ | n >= 0 && n < 0x10000 ->+        fromWord8 0xCD <>+        fromWord16be (fromIntegral n)+      _ | n >= 0 && n < 0x100000000 ->+        fromWord8 0xCE <>+        fromWord32be (fromIntegral n)+      _ | n >= 0 ->+        fromWord8 0xCF <>+        fromWord64be (fromIntegral n)+      _ | n >= -0x80 ->+        fromWord8 0xD0 <>+        fromWord8 (fromIntegral n)+      _ | n >= -0x8000 ->+        fromWord8 0xD1 <>+        fromWord16be (fromIntegral n)+      _ | n >= -0x80000000 ->+        fromWord8 0xD2 <>+        fromWord32be (fromIntegral n)+      _ ->+        fromWord8 0xD3 <>+        fromWord64be (fromIntegral n)+      +instance Packable () where+  from _ = +    fromWord8 0xC0++instance Packable Bool where+  from True  = fromWord8 0xC3+  from False = fromWord8 0xC2++instance Packable Float where+  from f =+    fromWord8 0xCB <>+    fromWord32be (cast f)++instance Packable Double where+  from d =+    fromWord8 0xCB <>+    fromWord64be (cast d)++cast :: (Storable a, Storable b) => a -> b+cast v = unsafePerformIO $ with v $ peek . castPtr++instance Packable String where+  from = fromString encodeUtf8 B.length fromByteString++instance Packable B.ByteString where+  from = fromString id B.length fromByteString++instance Packable BL.ByteString where+  from = fromString id (fromIntegral . BL.length) fromLazyByteString++instance Packable T.Text where+  from = fromString T.encodeUtf8 B.length fromByteString++instance Packable TL.Text where+  from = fromString TL.encodeUtf8 (fromIntegral . BL.length) fromLazyByteString++fromString :: (s -> t) -> (t -> Int) -> (t -> Builder) -> s -> Builder+fromString cnv lf pf str =+  let bs = cnv str in+  case lf bs of+    len | len <= 31 ->+      fromWord8 $ 0xA0 .|. fromIntegral len+    len | len < 0x10000 ->+      fromWord8 0xDA <>+      fromWord16be (fromIntegral len)+    len ->+      fromWord8 0xDB <>+      fromWord32be (fromIntegral len)+  <> pf bs++instance Packable a => Packable [a] where+  from = fromArray length (mconcat . map from)++instance Packable a => Packable (V.Vector a) where+  from = fromArray V.length (V.foldl (\a b -> a <> from b) mempty)++instance (Packable a1, Packable a2) => Packable (a1, a2) where+  from = fromArray (const 2) f where+    f (a1, a2) = from a1 <> from a2++instance (Packable a1, Packable a2, Packable a3) => Packable (a1, a2, a3) where+  from = fromArray (const 3) f where+    f (a1, a2, a3) = from a1 <> from a2 <> from a3++instance (Packable a1, Packable a2, Packable a3, Packable a4) => Packable (a1, a2, a3, a4) where+  from = fromArray (const 4) f where+    f (a1, a2, a3, a4) = from a1 <> from a2 <> from a3 <> from a4++instance (Packable a1, Packable a2, Packable a3, Packable a4, Packable a5) => Packable (a1, a2, a3, a4, a5) where+  from = fromArray (const 5) f where+    f (a1, a2, a3, a4, a5) = from a1 <> from a2 <> from a3 <> from a4 <> from a5++instance (Packable a1, Packable a2, Packable a3, Packable a4, Packable a5, Packable a6) => Packable (a1, a2, a3, a4, a5, a6) where+  from = fromArray (const 6) f where+    f (a1, a2, a3, a4, a5, a6) = from a1 <> from a2 <> from a3 <> from a4 <> from a5 <> from 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+  from = fromArray (const 7) f where+    f (a1, a2, a3, a4, a5, a6, a7) = from a1 <> from a2 <> from a3 <> from a4 <> from a5 <> from a6 <> from 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+  from = fromArray (const 8) f where+    f (a1, a2, a3, a4, a5, a6, a7, a8) = from a1 <> from a2 <> from a3 <> from a4 <> from a5 <> from a6 <> from a7 <> from 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+  from = fromArray (const 9) f where+    f (a1, a2, a3, a4, a5, a6, a7, a8, a9) = from a1 <> from a2 <> from a3 <> from a4 <> from a5 <> from a6 <> from a7 <> from a8 <> from a9++fromArray :: (a -> Int) -> (a -> Builder) -> a -> Builder+fromArray lf pf arr = do+  case lf arr of+    len | len <= 15 ->+      fromWord8 $ 0x90 .|. fromIntegral len+    len | len < 0x10000 ->+      fromWord8 0xDC <>+      fromWord16be (fromIntegral len)+    len ->+      fromWord8 0xDD <>+      fromWord32be (fromIntegral len)+  <> pf arr++instance (Packable k, Packable v) => Packable (Assoc [(k,v)]) where+  from = fromMap length (mconcat . map fromPair) . unAssoc++instance (Packable k, Packable v) => Packable (Assoc (V.Vector (k,v))) where+  from = fromMap V.length (V.foldl (\a b -> a <> fromPair b) mempty) . unAssoc++instance (Packable k, Packable v) => Packable (M.Map k v) where+  from = fromMap M.size (mconcat . map fromPair . M.toList)++instance Packable v => Packable (IM.IntMap v) where+  from = fromMap IM.size (mconcat . map fromPair . IM.toList)++instance (Packable k, Packable v) => Packable (HM.HashMap k v) where+  from = fromMap HM.size (mconcat . map fromPair . HM.toList)++fromPair :: (Packable a, Packable b) => (a, b) -> Builder+fromPair (a, b) = from a <> from b++fromMap :: (a -> Int) -> (a -> Builder) -> a -> Builder+fromMap lf pf m =+  case lf m of+    len | len <= 15 ->+      fromWord8 $ 0x80 .|. fromIntegral len+    len | len < 0x10000 ->+      fromWord8 0xDE <>+      fromWord16be (fromIntegral len)+    len ->+      fromWord8 0xDF <>+      fromWord32be (fromIntegral len)+  <> pf m++instance Packable a => Packable (Maybe a) where+  from Nothing = from ()+  from (Just a) = from a
+ Data/MessagePack/Unpack.hs view
@@ -0,0 +1,337 @@+{-# LANGUAGE FlexibleInstances, IncoherentInstances, TypeSynonymInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}++--------------------------------------------------------------------+-- |+-- Module    : Data.MessagePack.Unpack+-- Copyright : (c) Hideyuki Tanaka, 2009-2011+-- 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.Applicative+import Control.Exception+import Control.Monad+import qualified Data.Attoparsec as A+import Data.Bits+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Hashable+import qualified Data.HashMap.Strict as HM+import qualified Data.Map as M+import qualified Data.IntMap as IM+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL+import Data.Int+import Data.Typeable+import qualified Data.Vector as V+import Data.Word+import Foreign+import Text.Printf++import Data.MessagePack.Assoc+import Data.MessagePack.Internal.Utf8++-- | 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 BL.ByteString where+  toBS = B.concat . BL.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 Float where+  get = do+    c <- A.anyWord8+    case c of+      0xCA -> do+        bs <- A.take 4+        -- TODO: unsafePerformIO => unsafeLocalState+        return $! unsafePerformIO $ B.useAsCString (B.reverse bs) $ peek . castPtr+      _ ->+        fail $ printf "invlid float tag: 0x%02X" c++instance Unpackable Double where+  get = do+    c <- A.anyWord8+    case c of+      0xCB -> do+        bs <- A.take 8+        return $! unsafePerformIO $ B.useAsCString (B.reverse bs) $ peek . castPtr+      _ ->+        fail $ printf "invlid double tag: 0x%02X" c++instance Unpackable String where+  get = parseString (\n -> return . decodeUtf8 =<< A.take n)++instance Unpackable B.ByteString where+  get = parseString A.take++instance Unpackable BL.ByteString where+  get = parseString (\n -> return . toLBS =<< A.take n)++instance Unpackable T.Text where+  get = parseString (\n -> return . T.decodeUtf8With skipChar =<< A.take n)++instance Unpackable TL.Text where+  get = parseString (\n -> return . TL.decodeUtf8With skipChar . toLBS =<< A.take n)++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 %d" 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 %d" 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 %d" 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 %d" 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 %d" 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 %d" 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 %d" 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 %d" 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 (Assoc [(k,v)]) where+  get = liftM Assoc $ parseMap (flip replicateM parsePair)++instance (Unpackable k, Unpackable v) => Unpackable (Assoc (V.Vector (k, v))) where+  get = liftM Assoc $ parseMap (flip V.replicateM parsePair)++instance (Ord k, Unpackable k, Unpackable v) => Unpackable (M.Map k v) where+  get = parseMap (\n -> M.fromList <$> replicateM n parsePair)++instance Unpackable v => Unpackable (IM.IntMap v) where+  get = parseMap (\n -> IM.fromList <$> replicateM n parsePair)++instance (Hashable k, Eq k, Unpackable k, Unpackable v) => Unpackable (HM.HashMap k v) where+  get = parseMap (\n -> HM.fromList <$> replicateM n 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
msgpack.cabal view
@@ -1,50 +1,61 @@ Name:               msgpack-Version:            0.6.4+Version:            0.7.0 Synopsis:           A Haskell implementation of MessagePack-Description:-  A Haskell implementation of MessagePack <http://msgpack.org/>-+Description:        A Haskell implementation of MessagePack <http://msgpack.org/>+Homepage:           http://msgpack.org/ License:            BSD3 License-File:       LICENSE-Copyright:          Copyright (c) 2009-2011, Hideyuki Tanaka-Category:           Data Author:             Hideyuki Tanaka Maintainer:         Hideyuki Tanaka <tanaka.hideyuki@gmail.com>-Homepage:           http://github.com/msgpack/msgpack+Copyright:          Copyright (c) 2009-2011, Hideyuki Tanaka+Category:           Data Stability:          Experimental-Cabal-Version:      >= 1.6+Cabal-Version:      >= 1.8 Build-Type:         Simple -Extra-source-files:-  test/Test.hs-  test/UserData.hs+Source-repository head+  Type:             git+  Location:         git://github.com/msgpack/msgpack-haskell.git  Library-  Build-depends:    base >=4 && <5,-                    mtl >= 2.0 && < 2.1,-                    bytestring >= 0.9 && < 0.10,-                    text >= 0.11 && < 0.12,-                    vector >= 0.7 && < 0.10,-                    attoparsec >= 0.8 && < 0.10,-                    binary >= 0.5.0 && < 0.5.1,-                    data-binary-ieee754 >= 0.4 && < 0.5,-                    deepseq >= 1.1 && <1.3,-                    template-haskell >= 2.4 && < 2.7+  Build-depends:    base >=4 && <5+                  , mtl >= 2.0 && < 2.1+                  , bytestring >= 0.9 && < 0.10+                  , text >= 0.11 && < 0.12+                  , containers >= 0.4 && < 0.5+                  , unordered-containers >= 0.1 && < 0.2+                  , hashable >= 1.1 && < 1.2+                  , vector >= 0.7 && < 0.10+                  , attoparsec >= 0.8 && < 0.11+                  , blaze-builder >= 0.3 && < 0.4+                  , deepseq >= 1.1 && <1.3+                  , template-haskell >= 2.4 && < 2.7    Ghc-options:      -Wall-  Hs-source-dirs:   src -  Exposed-modules:-    Data.MessagePack-    Data.MessagePack.Assoc-    Data.MessagePack.Pack-    Data.MessagePack.Unpack-    Data.MessagePack.Object-    Data.MessagePack.Derive--  Other-modules:-    Data.MessagePack.Internal.Utf8+  Exposed-modules:  Data.MessagePack+                    Data.MessagePack.Assoc+                    Data.MessagePack.Pack+                    Data.MessagePack.Unpack+                    Data.MessagePack.Object+                    Data.MessagePack.Derive+                    Data.MessagePack.Internal.Utf8 -Source-repository head-  Type:     git-  Location: git://github.com/msgpack/msgpack.git+Test-suite msgpack-tests+  Type:             exitcode-stdio-1.0+  Main-is:          test/Test.hs+  Build-depends:    base >= 4 && < 5+                  , mtl >= 2.0 && < 2.1+                  , bytestring >= 0.9 && < 0.10+                  , text >= 0.11 && < 0.12+                  , containers >= 0.4 && < 0.5+                  , unordered-containers >= 0.1 && < 0.2+                  , hashable >= 1.1 && < 1.2+                  , vector >= 0.7 && < 0.10+                  , attoparsec >= 0.8 && < 0.11+                  , blaze-builder >= 0.3 && < 0.4+                  , deepseq >= 1.1 && <1.3+                  , template-haskell >= 2.4 && < 2.7+                  , QuickCheck >= 2.4 && < 2.5+                  , test-framework >= 0.4 && < 0.5+                  , test-framework-quickcheck2 >= 0.2 && < 0.3
− src/Data/MessagePack.hs 
@@ -1,27 +0,0 @@------------------------------------------------------------------------ |--- Module    : Data.MessagePack--- Copyright : (c) Hideyuki Tanaka, 2009-2010--- License   : BSD3------ Maintainer:  tanaka.hideyuki@gmail.com--- Stability :  experimental--- Portability: portable------ Simple interface to pack and unpack MessagePack data.--------------------------------------------------------------------------module Data.MessagePack(-  module Data.MessagePack.Assoc,-  module Data.MessagePack.Pack,-  module Data.MessagePack.Unpack,-  module Data.MessagePack.Object,-  module Data.MessagePack.Derive,-  ) where--import Data.MessagePack.Assoc-import Data.MessagePack.Pack-import Data.MessagePack.Unpack-import Data.MessagePack.Object-import Data.MessagePack.Derive
− src/Data/MessagePack/Assoc.hs 
@@ -1,28 +0,0 @@-{-# Language DeriveDataTypeable #-}-{-# Language GeneralizedNewtypeDeriving #-}------------------------------------------------------------------------- |--- Module    : Data.MessagePack.Assoc--- Copyright : (c) Daiki Handa, 2010--- License   : BSD3------ Maintainer:  tanaka.hideyuki@gmail.com--- Stability :  experimental--- Portability: portable------ MessagePack map labeling type--------------------------------------------------------------------------module Data.MessagePack.Assoc (-  Assoc(..)-  ) where--import Control.DeepSeq-import Data.Typeable---- not defined for general Functor for performance reason.--- (ie. you would want to write custom instances for each type using specialized mapM-like functions)-newtype Assoc a=Assoc{unAssoc :: a} deriving(Show,Eq,Ord,Typeable,NFData)-
− src/Data/MessagePack/Derive.hs 
@@ -1,137 +0,0 @@-{-# Language TemplateHaskell #-}-{-# Language FlexibleInstances #-}--module Data.MessagePack.Derive (-  -- | deriving OBJECT-  derivePack,-  deriveUnpack,-  deriveObject,-  ) where--import Control.Monad-import Control.Monad.Error () -- MonadPlus instance for Either e-import Data.Char-import Data.List-import qualified Data.Text as T-import Language.Haskell.TH--import Data.MessagePack.Assoc-import Data.MessagePack.Pack-import Data.MessagePack.Unpack-import Data.MessagePack.Object--derivePack :: Bool -> Name -> Q [Dec]-derivePack asObject tyName = do-  info <- reify tyName-  d <- case info of-    TyConI (DataD _ {- cxt -} name tyVars cons _ {- derivings -}) -> do-      ds <- [d| put v = $(caseE [| v |] (map alt cons)) |]-      instanceD (cx tyVars) (ct ''Packable name tyVars) $-        map return ds--    _ -> error $ "cant derive Packable: " ++ show tyName-  return [d]--  where-    alt (NormalC conName elms) = do-      vars <- replicateM (length elms) (newName "v")-      match (conP conName $ map varP vars)-        (normalB [| put $(tupE $ map varE vars) |])-        []--    alt (RecC conName elms) = do-      vars <- replicateM (length elms) (newName "v")-      if asObject-        then-        match (conP conName $ map varP vars)-        (normalB-         [| put $ Assoc-              $(listE [ [| ( $(return $ LitE $ StringL $ key conName fname) :: T.Text-                           , toObject $(varE v)) |]-                      | (v, (fname, _, _)) <- zip vars elms])-          |])-        []-        else-        match (conP conName $ map varP vars)-        (normalB [| put $(tupE $ map varE vars) |])-        []--    alt c = error $ "unsupported constructor: " ++ pprint c--deriveUnpack :: Bool -> Name -> Q [Dec]-deriveUnpack asObject tyName = do-  info <- reify tyName-  d <- case info of-    TyConI (DataD _ {- cxt -} name tyVars cons _ {- derivings -}) -> do-      ds <- [d| get = $(foldl1 (\x y -> [| $x `mplus` $y |]) $ map alt cons) |]-      instanceD (cx tyVars) (ct ''Unpackable name tyVars) $-        map return ds--    _ -> error $ "cant derive Unpackable: " ++ show tyName-  return [d]--  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")-      if asObject-        then-        doE $ [ bindS (conP 'Assoc [varP var]) [| get |] ]-            ++ zipWith (binds conName var) vars elms ++-            [ noBindS [| return $(foldl appE (conE conName) $ map varE vars) |] ]-        else-        doE [ bindS (tupP $ map varP vars) [| get |]-            , noBindS [| return $(foldl appE (conE conName) $ map varE vars) |]-            ]--    alt c = error $ "unsupported constructor: " ++ pprint c--    binds conName var res (fname, _, _) =-      bindS (varP res)-            [| failN $ lookup ($(return $ LitE $ StringL $ key conName fname) :: T.Text)-                              $(varE var) |]--deriveObject :: Bool -> Name -> Q [Dec]-deriveObject asObject tyName = do-  g <- derivePack asObject tyName-  p <- deriveUnpack asObject tyName-  info <- reify tyName-  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) =-  case tryFromObject a of-    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-  where-    prefix = map toLower $ nameBase conName-    sFname = nameBase fname-    uncapital (c:cs) | isUpper c = toLower c : cs-    uncapital cs = cs
− src/Data/MessagePack/Internal/Utf8.hs 
@@ -1,28 +0,0 @@-module Data.MessagePack.Internal.Utf8 (-  encodeUtf8,-  decodeUtf8,-  skipChar,-  toLBS,-  fromLBS,-  ) where--import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Text.Encoding.Error as T--encodeUtf8 :: String -> B.ByteString-encodeUtf8 = T.encodeUtf8 . T.pack--decodeUtf8 :: B.ByteString -> String-decodeUtf8 = T.unpack . T.decodeUtf8With skipChar--skipChar :: T.OnDecodeError-skipChar _ _ = Nothing--toLBS :: B.ByteString -> BL.ByteString-toLBS bs = BL.fromChunks [bs]--fromLBS :: BL.ByteString -> B.ByteString-fromLBS = B.concat . BL.toChunks
− src/Data/MessagePack/Object.hs 
@@ -1,333 +0,0 @@-{-# Language TypeSynonymInstances #-}-{-# Language FlexibleInstances #-}-{-# Language IncoherentInstances #-}-{-# Language DeriveDataTypeable #-}------------------------------------------------------------------------- |--- Module    : Data.MessagePack.Object--- Copyright : (c) Hideyuki Tanaka, 2009-2010--- License   : BSD3------ Maintainer:  tanaka.hideyuki@gmail.com--- Stability :  experimental--- Portability: portable------ MessagePack object definition--------------------------------------------------------------------------module Data.MessagePack.Object(-  -- * MessagePack Object-  Object(..),-  -  -- * Serialization to and from Object-  OBJECT(..),-  -- Result,-  ) where--import Control.DeepSeq-import Control.Exception-import Control.Monad-import qualified Data.Attoparsec as A-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Encoding as TL-import Data.Typeable--import Data.MessagePack.Assoc-import Data.MessagePack.Pack-import Data.MessagePack.Unpack-import Data.MessagePack.Internal.Utf8---- | Object Representation of MessagePack data.-data Object-  = ObjectNil-  | ObjectBool Bool-  | ObjectInteger Int-  | ObjectFloat Float-  | ObjectDouble Double-  | ObjectRAW B.ByteString-  | ObjectArray [Object]-  | ObjectMap [(Object, Object)]-  deriving (Show, Eq, Ord, Typeable)-  --instance NFData Object where-  rnf obj =-    case obj of-      ObjectNil -> ()-      ObjectBool b -> rnf b-      ObjectInteger n -> rnf n-      ObjectFloat f -> rnf f-      ObjectDouble d -> rnf d-      ObjectRAW bs -> bs `seq` ()-      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 ObjectFloat get-    , liftM ObjectDouble get-    , liftM ObjectRAW get-    , liftM ObjectArray get-    , liftM (ObjectMap . unAssoc) get-    ]--instance Packable Object where-  put obj =-    case obj of-      ObjectInteger n ->-        put n-      ObjectNil ->-        put ()-      ObjectBool b ->-        put b-      ObjectFloat f ->-        put f-      ObjectDouble d ->-        put d-      ObjectRAW raw ->-        put raw-      ObjectArray arr ->-        put arr-      ObjectMap m ->-        put $ Assoc m---- | The class of types serializable to and from MessagePack object-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 -> a-  fromObject a =-    case tryFromObject a of-      Left err ->-        throw $ UnpackError err-      Right ret ->-        ret--  -- | Decode a value from MessagePack object-  tryFromObject :: Object -> Either String a-  tryFromObject = tryUnpack . pack--instance OBJECT Object where-  toObject = id-  tryFromObject = Right--tryFromObjectError :: Either String a-tryFromObjectError = Left "tryFromObject: cannot cast"--instance OBJECT () where-  toObject = const ObjectNil-  tryFromObject ObjectNil = Right ()-  tryFromObject _ = tryFromObjectError--instance OBJECT Int where-  toObject = ObjectInteger-  tryFromObject (ObjectInteger n) = Right n-  tryFromObject _ = tryFromObjectError--instance OBJECT Bool where-  toObject = ObjectBool-  tryFromObject (ObjectBool b) = Right b-  tryFromObject _ = tryFromObjectError--instance OBJECT Double where-  toObject = ObjectDouble-  tryFromObject (ObjectDouble d) = Right d-  tryFromObject _ = tryFromObjectError--instance OBJECT Float where-  toObject = ObjectFloat-  tryFromObject (ObjectFloat f) = Right f-  tryFromObject _ = tryFromObjectError--instance OBJECT String where-  toObject = toObject . encodeUtf8-  tryFromObject obj = liftM decodeUtf8 $ tryFromObject obj--instance OBJECT B.ByteString where-  toObject = ObjectRAW-  tryFromObject (ObjectRAW bs) = Right bs-  tryFromObject _ = tryFromObjectError--instance OBJECT BL.ByteString where-  toObject = ObjectRAW . fromLBS-  tryFromObject (ObjectRAW bs) = Right $ toLBS bs-  tryFromObject _ = tryFromObjectError--instance OBJECT T.Text where-  toObject = ObjectRAW . T.encodeUtf8-  tryFromObject (ObjectRAW bs) = Right $ T.decodeUtf8With skipChar bs-  tryFromObject _ = tryFromObjectError--instance OBJECT TL.Text where-  toObject = ObjectRAW . fromLBS . TL.encodeUtf8-  tryFromObject (ObjectRAW bs) = Right $ TL.decodeUtf8With skipChar $ toLBS bs-  tryFromObject _ = tryFromObjectError--instance OBJECT a => OBJECT [a] where-  toObject = ObjectArray . map toObject-  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 (Assoc [(a,b)]) where-  toObject =-    ObjectMap . map (\(a, b) -> (toObject a, toObject b)) . unAssoc-  tryFromObject (ObjectMap mem) = do-    liftM Assoc $ 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-  -  tryFromObject ObjectNil = return Nothing-  tryFromObject obj = liftM Just $ tryFromObject obj-
− src/Data/MessagePack/Pack.hs 
@@ -1,204 +0,0 @@-{-# Language FlexibleInstances #-}-{-# Language IncoherentInstances #-}-{-# 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.Lazy as BL-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Encoding as TL-import qualified Data.Vector as V--import Data.MessagePack.Assoc-import Data.MessagePack.Internal.Utf8---- | Serializable class-class Packable a where-  -- | Serialize a value-  put :: a -> Put---- | Pack Haskell data to MessagePack string.-pack :: Packable a => a -> BL.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 Float where-  put f = do-    putWord8 0xCA-    putFloat32be f--instance Packable Double where-  put d = do-    putWord8 0xCB-    putFloat64be d--instance Packable String where-  put = putString encodeUtf8 B.length putByteString--instance Packable B.ByteString where-  put = putString id B.length putByteString--instance Packable BL.ByteString where-  put = putString id (fromIntegral . BL.length) putLazyByteString--instance Packable T.Text where-  put = putString T.encodeUtf8 B.length putByteString--instance Packable TL.Text where-  put = putString TL.encodeUtf8 (fromIntegral . BL.length) putLazyByteString--putString :: (s -> t) -> (t -> Int) -> (t -> Put) -> s -> Put-putString cnv lf pf str = do-  let bs = cnv str-  case lf bs 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 bs--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 (Assoc [(k,v)]) where-  put = putMap length (mapM_ putPair) . unAssoc--instance (Packable k, Packable v) => Packable (Assoc (V.Vector (k,v))) where-  put = putMap V.length (V.mapM_ putPair) . unAssoc--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/Unpack.hs 
@@ -1,323 +0,0 @@-{-# Language FlexibleInstances #-}-{-# Language IncoherentInstances #-}-{-# 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.Lazy as BL-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Encoding as TL-import Data.Int-import Data.Typeable-import qualified Data.Vector as V-import Data.Word-import Text.Printf--import Data.MessagePack.Assoc-import Data.MessagePack.Internal.Utf8---- | 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 BL.ByteString where-  toBS = B.concat . BL.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 Float where-  get = do-    c <- A.anyWord8-    case c of-      0xCA ->-        return . runGet getFloat32be . toLBS =<< A.take 4-      _ ->-        fail $ printf "invlid float tag: 0x%02X" c--instance Unpackable Double where-  get = do-    c <- A.anyWord8-    case c of-      0xCB ->-        return . runGet getFloat64be . toLBS =<< A.take 8-      _ ->-        fail $ printf "invlid double tag: 0x%02X" c--instance Unpackable String where-  get = parseString (\n -> return . decodeUtf8 =<< A.take n)--instance Unpackable B.ByteString where-  get = parseString A.take--instance Unpackable BL.ByteString where-  get = parseString (\n -> return . toLBS =<< A.take n)--instance Unpackable T.Text where-  get = parseString (\n -> return . T.decodeUtf8With skipChar =<< A.take n)--instance Unpackable TL.Text where-  get = parseString (\n -> return . TL.decodeUtf8With skipChar . toLBS =<< A.take n)--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 %d" 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 %d" 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 %d" 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 %d" 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 %d" 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 %d" 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 %d" 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 %d" 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 (Assoc [(k,v)]) where-  get = liftM Assoc $ parseMap (flip replicateM parsePair)--instance (Unpackable k, Unpackable v) => Unpackable (Assoc (V.Vector (k, v))) where-  get = liftM Assoc $ 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
− test/Test.hs 
@@ -1,70 +0,0 @@-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--instance Arbitrary a => Arbitrary (Assoc a) where-  arbitrary = liftM Assoc arbitrary--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_list_int_double a = a == mid a-  where types = a :: [(Int, Double)]-prop_mid_list_string_string a = a == mid a-  where types = a :: [(String, String)]-prop_mid_map_string_int a = a == mid a-  where types = a :: Assoc [(String,Int)]--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_list_int_double-    , testProperty "[(string, string)]" prop_mid_list_string_string-    , testProperty "Assoc [(string, int)]" prop_mid_map_string_int-    ]-  ]--main = defaultMain tests
− test/UserData.hs 
@@ -1,53 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE OverloadedStrings #-}--import Data.MessagePack--data T-  = A Int String-  | B Double-  deriving (Show, Eq)--deriveObject True ''T--data U-  = C { c1 :: Int, c2 :: String }-  | D { z1 :: Double }-  deriving (Show, Eq)--deriveObject True ''U--data V-  = E String | F-  deriving (Show, Eq)--deriveObject True ''V--data W a-  = G a String-  | H { hHoge :: Int, h_age :: a }-  deriving (Show, Eq)--deriveObject True ''W--test :: (OBJECT a, Show a, Eq a) => a -> IO ()-test v = do-  let bs = pack v-  print bs-  print (unpack bs == v)--  let oa = toObject v-  print oa-  print (fromObject oa == v)--main :: IO ()-main = do-  test $ A 123 "hoge"-  test $ B 3.14-  test $ C 123 "hoge"-  test $ D 3.14-  test $ E "hello"-  test $ F-  test $ G (E "hello") "world"-  test $ H 123 F-  return ()