msgpack 0.2.2 → 0.3.0

raw patch · 12 files changed

+692/−1187 lines, 12 filesdep +MonadCatchIO-transformersdep +attoparsecdep +binarydep −mtldep ~basedep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: MonadCatchIO-transformers, attoparsec, binary, data-binary-ieee754, iteratee, transformers, vector

Dependencies removed: mtl

Dependency ranges changed: base, bytestring

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• cbits/msgpack.c +0/−137
• msgpack.cabal +29/−26
• src/Data/MessagePack.hs +92/−38
• src/Data/MessagePack/Base.hsc +0/−584
• src/Data/MessagePack/Class.hs +0/−101
• src/Data/MessagePack/Feed.hs +0/−62
• src/Data/MessagePack/Monad.hs +0/−156
• src/Data/MessagePack/Object.hs +109/−0
• src/Data/MessagePack/Parser.hs +259/−0
• src/Data/MessagePack/Put.hs +202/−0
• src/Data/MessagePack/Stream.hs +0/−82

@@ -1,4 +1,4 @@-Copyright (c) 2009, Hideyuki Tanaka+Copyright (c) 2009-2010, Hideyuki Tanaka All rights reserved.  Redistribution and use in source and binary forms, with or without

@@ -1,137 +0,0 @@-#include <msgpack.h>--void msgpack_sbuffer_init_wrap(msgpack_sbuffer* sbuf)-{-  msgpack_sbuffer_init(sbuf);-}--void msgpack_sbuffer_destroy_wrap(msgpack_sbuffer* sbuf)-{-  msgpack_sbuffer_destroy(sbuf);-}--int msgpack_sbuffer_write_wrap(void* data, const char* buf, unsigned int len)-{-  return msgpack_sbuffer_write(data, buf, len);-}--msgpack_packer* msgpack_packer_new_wrap(void *data, msgpack_packer_write callback)-{-  return msgpack_packer_new(data, callback);-}--void msgpack_packer_free_wrap(msgpack_packer* pk)-{-  msgpack_packer_free(pk);-}--int msgpack_pack_uint8_wrap(msgpack_packer* pk, uint8_t d)-{-  return msgpack_pack_uint8(pk, d);-}--int msgpack_pack_uint16_wrap(msgpack_packer* pk, uint16_t d)-{-  return msgpack_pack_uint16(pk, d);-}--int msgpack_pack_uint32_wrap(msgpack_packer* pk, uint32_t d)-{-  return msgpack_pack_uint32(pk, d);-}--int msgpack_pack_uint64_wrap(msgpack_packer* pk, uint64_t d)-{-  return msgpack_pack_uint64(pk, d);-}--int msgpack_pack_int8_wrap(msgpack_packer* pk, int8_t d)-{-  return msgpack_pack_int8(pk, d);-}--int msgpack_pack_int16_wrap(msgpack_packer* pk, int16_t d)-{-  return msgpack_pack_int16(pk, d);-}--int msgpack_pack_int32_wrap(msgpack_packer* pk, int32_t d)-{-  return msgpack_pack_int32(pk, d);-}--int msgpack_pack_int64_wrap(msgpack_packer* pk, int64_t d)-{-  return msgpack_pack_int64(pk, d);-}--int msgpack_pack_double_wrap(msgpack_packer* pk, double d)-{-  return msgpack_pack_double(pk, d);-}--int msgpack_pack_nil_wrap(msgpack_packer* pk)-{-  return msgpack_pack_nil(pk);-}--int msgpack_pack_true_wrap(msgpack_packer* pk)-{-  return msgpack_pack_true(pk);-}--int msgpack_pack_false_wrap(msgpack_packer* pk)-{-  return msgpack_pack_false(pk);-}--int msgpack_pack_array_wrap(msgpack_packer* pk, unsigned int n)-{-  return msgpack_pack_array(pk, n);-}--int msgpack_pack_map_wrap(msgpack_packer* pk, unsigned int n)-{-  return msgpack_pack_map(pk, n);-}--int msgpack_pack_raw_wrap(msgpack_packer* pk, size_t l)-{-  return msgpack_pack_raw(pk, l);-}--int msgpack_pack_raw_body_wrap(msgpack_packer* pk, const void *b, size_t l)-{-  return msgpack_pack_raw_body(pk, b, l);-}--bool msgpack_unpacker_reserve_buffer_wrap(msgpack_unpacker *mpac, size_t size)-{-  return msgpack_unpacker_reserve_buffer(mpac, size);-}--char *msgpack_unpacker_buffer_wrap(msgpack_unpacker *mpac)-{-  return msgpack_unpacker_buffer(mpac);-}--size_t msgpack_unpacker_buffer_capacity_wrap(const msgpack_unpacker *mpac)-{-  return msgpack_unpacker_buffer_capacity(mpac);-}--void msgpack_unpacker_buffer_consumed_wrap(msgpack_unpacker *mpac, size_t size)-{-  msgpack_unpacker_buffer_consumed(mpac, size);-}--void msgpack_unpacker_data_wrap(msgpack_unpacker *mpac, msgpack_object *obj)-{-  *obj=msgpack_unpacker_data(mpac);-}--size_t msgpack_unpacker_message_size_wrap(const msgpack_unpacker *mpac)-{-  return msgpack_unpacker_message_size(mpac);-}-

@@ -1,32 +1,35 @@-Name:                msgpack-Version:             0.2.2-License:             BSD3-License-File:        LICENSE-Author:              Hideyuki Tanaka-Maintainer:          Hideyuki Tanaka <tanaka.hideyuki@gmail.com>-Category:            Data-Synopsis:            A Haskell binding to MessagePack+Name:               msgpack+Version:            0.3.0+Synopsis:           A Haskell binding to MessagePack Description:   A Haskell binding to MessagePack <http://msgpack.sourceforge.jp/>-Homepage:	     http://github.com/tanakh/hsmsgpack-Stability:	     Experimental-Tested-with:	     GHC==6.10.4-Cabal-Version:	     >=1.2-Build-Type:          Simple -library-  build-depends:	base>=4 && <5, mtl, bytestring-  ghc-options:		-O2 -Wall-  hs-source-dirs:	src-  extra-libraries:	msgpackc+License:            BSD3+License-File:       LICENSE+Category:           Data+Author:             Hideyuki Tanaka+Maintainer:         Hideyuki Tanaka <tanaka.hideyuki@gmail.com>+Homepage:           http://github.com/tanakh/hsmsgpack+Stability:          Experimental+Tested-with:        GHC == 6.12.3+Cabal-Version:      >= 1.2+Build-Type:         Simple +Library+  Build-depends:    base >=4 && <5,+                    transformers >= 0.2.1 && < 0.2.2,+                    MonadCatchIO-transformers >= 0.2.2 && < 0.2.3,+                    bytestring >= 0.9 && < 0.10,+                    vector >= 0.6.0 && < 0.6.1,+                    iteratee >= 0.4 && < 0.5,+                    attoparsec >= 0.8.1 && < 0.8.2,+                    binary >= 0.5.0 && < 0.5.1,+                    data-binary-ieee754 >= 0.4 && < 0.5+  Ghc-options:      -Wall -O2+  Hs-source-dirs:   src+   Exposed-modules:     Data.MessagePack-    Data.MessagePack.Base-    Data.MessagePack.Class-    Data.MessagePack.Feed-    Data.MessagePack.Monad-    Data.MessagePack.Stream--  C-Sources:-    cbits/msgpack.c+    Data.MessagePack.Object+    Data.MessagePack.Put+    Data.MessagePack.Parser

@@ -1,7 +1,7 @@ -------------------------------------------------------------------- -- | -- Module    : Data.MessagePack--- Copyright : (c) Hideyuki Tanaka, 2009+-- Copyright : (c) Hideyuki Tanaka, 2009-2010 -- License   : BSD3 -- -- Maintainer:  tanaka.hideyuki@gmail.com@@ -13,51 +13,105 @@ --------------------------------------------------------------------  module Data.MessagePack(-  module Data.MessagePack.Base,-  module Data.MessagePack.Class,-  module Data.MessagePack.Feed,-  module Data.MessagePack.Monad,-  module Data.MessagePack.Stream,+  module Data.MessagePack.Object,+  module Data.MessagePack.Put,+  module Data.MessagePack.Parser,   -  -- * Pack and Unpack-  packb,-  unpackb,+  -- * Simple functions of Pack and Unpack+  pack,+  unpack,   -  -- * Pure version of Pack and Unpack-  packb',-  unpackb',+  -- * Pack functions+  packToString,+  packToHandle,+  packToFile,+  +  -- * Unpack functions+  unpackFromString,+  unpackFromHandle,+  unpackFromFile,+     ) where -import Data.ByteString (ByteString)-import System.IO.Unsafe+import qualified Control.Monad.CatchIO as CIO+import Control.Monad.IO.Class+import qualified Data.Attoparsec as A+import Data.Binary.Put+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.Functor.Identity+import qualified Data.Iteratee as I+import qualified Data.Iteratee.IO as I+import System.IO -import Data.MessagePack.Base-import Data.MessagePack.Class-import Data.MessagePack.Feed-import Data.MessagePack.Monad-import Data.MessagePack.Stream+import Data.MessagePack.Object+import Data.MessagePack.Put+import Data.MessagePack.Parser +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.-packb :: OBJECT a => a -> IO ByteString-packb dat = do-  sb <- newSimpleBuffer-  pc <- newPacker sb-  pack pc dat-  simpleBufferData sb+pack :: ObjectPut a => a -> L.ByteString+pack = packToString . put  -- | Unpack MessagePack string to Haskell data.-unpackb :: OBJECT a => ByteString -> IO (Result a)-unpackb bs = do-  withZone $ \z -> do-    r <- unpackObject z bs-    return $ case r of-      Left err -> Left (show err)-      Right (_, dat) -> fromObject dat+unpack :: (ObjectGet a, IsByteString s) => s -> a+unpack bs =+  runIdentity $ I.run $ I.joinIM $ I.enumPure1Chunk (toBS bs) (parserToIteratee get) --- | Pure version of 'packb'.-packb' :: OBJECT a => a -> ByteString-packb' dat = unsafePerformIO $ packb dat+-- TODO: tryUnpack --- | Pure version of 'unpackb'.-unpackb' :: OBJECT a => ByteString -> Result a-unpackb' bs = unsafePerformIO $ unpackb bs+-- | Pack to ByteString.+packToString :: Put -> L.ByteString+packToString = runPut++-- | Pack to Handle+packToHandle :: Handle -> Put -> IO ()+packToHandle h = L.hPutStr h . packToString++-- | Pack to File+packToFile :: FilePath -> Put -> IO ()+packToFile path = L.writeFile path . packToString++-- | Unpack from ByteString+unpackFromString :: (Monad m, IsByteString s) => s -> A.Parser a -> m a+unpackFromString bs =+  I.run . I.joinIM . I.enumPure1Chunk (toBS bs) . parserToIteratee++-- | Unpack from Handle+unpackFromHandle :: CIO.MonadCatchIO m => Handle -> A.Parser a -> m a+unpackFromHandle h =+  I.run . I.joinIM . I.enumHandle bufferSize h . parserToIteratee++-- | Unpack from File+unpackFromFile :: CIO.MonadCatchIO m => FilePath -> A.Parser a -> m a+unpackFromFile path p =+  CIO.bracket+  (liftIO $ openBinaryFile path ReadMode)+  (liftIO . hClose)+  (flip unpackFromHandle p)++parserToIteratee :: Monad m => A.Parser a -> I.Iteratee B.ByteString m a+parserToIteratee p = I.icont (itr (A.parse p)) Nothing+  where+    itr pcont s = case s of+      I.EOF _ ->+        I.throwErr (I.setEOF s)+      I.Chunk bs ->+        case pcont bs of+          A.Fail _ _ msg ->+            I.throwErr (I.iterStrExc msg)+          A.Partial cont ->+            I.icont (itr cont) Nothing+          A.Done remain ret ->+            I.idone ret (I.Chunk remain)

@@ -1,584 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ForeignFunctionInterface #-}------------------------------------------------------------------------- |--- Module    : Data.MessagePack.Base--- Copyright : (c) Hideyuki Tanaka, 2009--- License   : BSD3------ Maintainer:  tanaka.hideyuki@gmail.com--- Stability :  experimental--- Portability: portable------ Low Level Interface to MessagePack C API--------------------------------------------------------------------------module Data.MessagePack.Base(-  -- * Simple Buffer-  SimpleBuffer,-  newSimpleBuffer,-  simpleBufferData,-  -  -- * Serializer-  Packer,-  newPacker,-  -  packU8,-  packU16,-  packU32,-  packU64,  -  packS8,-  packS16,-  packS32,-  packS64,-  -  packTrue,-  packFalse,-  -  packInt,-  packDouble,-  packNil,-  packBool,-  -  packArray,-  packMap,-  packRAW,-  packRAWBody,-  packRAW',-  -  -- * Stream Deserializer-  Unpacker,-  defaultInitialBufferSize,-  newUnpacker,-  unpackerReserveBuffer,-  unpackerBuffer,-  unpackerBufferCapacity,-  unpackerBufferConsumed,-  unpackerFeed,-  unpackerExecute,-  unpackerData,-  unpackerReleaseZone,-  unpackerResetZone,-  unpackerReset,-  unpackerMessageSize,-  -  -- * MessagePack Object-  Object(..),-  packObject,-  -  UnpackReturn(..),-  unpackObject,-  -  -- * Memory Zone-  Zone,-  newZone,-  freeZone,-  withZone,-  ) where--import Control.Exception-import Control.Monad-import Data.ByteString (ByteString)-import qualified Data.ByteString as BS hiding (pack, unpack)-import Data.Int-import Data.Word-import Foreign.C-import Foreign.Concurrent-import Foreign.ForeignPtr hiding (newForeignPtr)-import Foreign.Marshal.Alloc-import Foreign.Marshal.Array-import Foreign.Ptr-import Foreign.Storable--#include <msgpack.h>--type SimpleBuffer = ForeignPtr ()--type WriteCallback = Ptr () -> CString -> CUInt -> IO CInt---- | Create a new Simple Buffer. It will be deleted automatically.-newSimpleBuffer :: IO SimpleBuffer-newSimpleBuffer = do-  ptr <- mallocBytes (#size msgpack_sbuffer)-  fptr <- newForeignPtr ptr $ do-    msgpack_sbuffer_destroy ptr-    free ptr-  withForeignPtr fptr $ \p ->-    msgpack_sbuffer_init p-  return fptr---- | Get data of Simple Buffer.-simpleBufferData :: SimpleBuffer -> IO ByteString-simpleBufferData sb =-  withForeignPtr sb $ \ptr -> do-    size <- (#peek msgpack_sbuffer, size) ptr-    dat  <- (#peek msgpack_sbuffer, data) ptr-    BS.packCStringLen (dat, fromIntegral (size :: CSize))--foreign import ccall "msgpack_sbuffer_init_wrap" msgpack_sbuffer_init ::-  Ptr () -> IO ()--foreign import ccall "msgpack_sbuffer_destroy_wrap" msgpack_sbuffer_destroy ::-  Ptr () -> IO ()--foreign import ccall "msgpack_sbuffer_write_wrap" msgpack_sbuffer_write ::-  WriteCallback--type Packer = ForeignPtr ()---- | Create new Packer. It will be deleted automatically.-newPacker :: SimpleBuffer -> IO Packer-newPacker sbuf = do-  cb <- wrap_callback msgpack_sbuffer_write-  ptr <- withForeignPtr sbuf $ \ptr ->-    msgpack_packer_new ptr cb-  fptr <- newForeignPtr ptr $ do-    msgpack_packer_free ptr-  return fptr--foreign import ccall "msgpack_packer_new_wrap" msgpack_packer_new ::-  Ptr () -> FunPtr WriteCallback -> IO (Ptr ())--foreign import ccall "msgpack_packer_free_wrap" msgpack_packer_free ::-  Ptr () -> IO ()--foreign import ccall "wrapper" wrap_callback ::-  WriteCallback -> IO (FunPtr WriteCallback)--packU8 :: Packer -> Word8 -> IO Int-packU8 pc n =-  liftM fromIntegral $ withForeignPtr pc $ \ptr ->-    msgpack_pack_uint8 ptr n--foreign import ccall "msgpack_pack_uint8_wrap" msgpack_pack_uint8 ::-  Ptr () -> Word8 -> IO CInt--packU16 :: Packer -> Word16 -> IO Int-packU16 pc n =-  liftM fromIntegral $ withForeignPtr pc $ \ptr ->-    msgpack_pack_uint16 ptr n--foreign import ccall "msgpack_pack_uint16_wrap" msgpack_pack_uint16 ::-  Ptr () -> Word16 -> IO CInt--packU32 :: Packer -> Word32 -> IO Int-packU32 pc n =-  liftM fromIntegral $ withForeignPtr pc $ \ptr ->-    msgpack_pack_uint32 ptr n--foreign import ccall "msgpack_pack_uint32_wrap" msgpack_pack_uint32 ::-  Ptr () -> Word32 -> IO CInt--packU64 :: Packer -> Word64 -> IO Int-packU64 pc n =-  liftM fromIntegral $ withForeignPtr pc $ \ptr ->-    msgpack_pack_uint64 ptr n--foreign import ccall "msgpack_pack_uint64_wrap" msgpack_pack_uint64 ::-  Ptr () -> Word64 -> IO CInt--packS8 :: Packer -> Int8 -> IO Int-packS8 pc n =-  liftM fromIntegral $ withForeignPtr pc $ \ptr ->-    msgpack_pack_int8 ptr n--foreign import ccall "msgpack_pack_int8_wrap" msgpack_pack_int8 ::-  Ptr () -> Int8 -> IO CInt--packS16 :: Packer -> Int16 -> IO Int-packS16 pc n =-  liftM fromIntegral $ withForeignPtr pc $ \ptr ->-    msgpack_pack_int16 ptr n--foreign import ccall "msgpack_pack_int16_wrap" msgpack_pack_int16 ::-  Ptr () -> Int16 -> IO CInt--packS32 :: Packer -> Int32 -> IO Int-packS32 pc n =-  liftM fromIntegral $ withForeignPtr pc $ \ptr ->-    msgpack_pack_int32 ptr n--foreign import ccall "msgpack_pack_int32_wrap" msgpack_pack_int32 ::-  Ptr () -> Int32 -> IO CInt--packS64 :: Packer -> Int64 -> IO Int-packS64 pc n =-  liftM fromIntegral $ withForeignPtr pc $ \ptr ->-    msgpack_pack_int64 ptr n--foreign import ccall "msgpack_pack_int64_wrap" msgpack_pack_int64 ::-  Ptr () -> Int64 -> IO CInt---- | Pack an integral data.-packInt :: Integral a => Packer -> a -> IO Int-packInt pc n = packS64 pc $ fromIntegral n---- | Pack a double data.-packDouble :: Packer -> Double -> IO Int-packDouble pc d =-  liftM fromIntegral $ withForeignPtr pc $ \ptr ->-    msgpack_pack_double ptr (realToFrac d)--foreign import ccall "msgpack_pack_double_wrap" msgpack_pack_double ::-  Ptr () -> CDouble -> IO CInt---- | Pack a nil.-packNil :: Packer -> IO Int-packNil pc =-  liftM fromIntegral $ withForeignPtr pc $ \ptr ->-    msgpack_pack_nil ptr--foreign import ccall "msgpack_pack_nil_wrap" msgpack_pack_nil ::-  Ptr () -> IO CInt--packTrue :: Packer -> IO Int-packTrue pc =-  liftM fromIntegral $ withForeignPtr pc $ \ptr ->-    msgpack_pack_true ptr--foreign import ccall "msgpack_pack_true_wrap" msgpack_pack_true ::-  Ptr () -> IO CInt--packFalse :: Packer -> IO Int-packFalse pc =-  liftM fromIntegral $ withForeignPtr pc $ \ptr ->-    msgpack_pack_false ptr--foreign import ccall "msgpack_pack_false_wrap" msgpack_pack_false ::-  Ptr () -> IO CInt---- | Pack a bool data.-packBool :: Packer -> Bool -> IO Int-packBool pc True  = packTrue pc-packBool pc False = packFalse pc---- | 'packArray' @p n@ starts packing an array. --- Next @n@ data will consist this array.-packArray :: Packer -> Int -> IO Int-packArray pc n =-  liftM fromIntegral $ withForeignPtr pc $ \ptr ->-    msgpack_pack_array ptr (fromIntegral n)--foreign import ccall "msgpack_pack_array_wrap" msgpack_pack_array ::-  Ptr () -> CUInt -> IO CInt---- | 'packMap' @p n@ starts packing a map. --- Next @n@ pairs of data (2*n data) will consist this map.-packMap :: Packer -> Int -> IO Int-packMap pc n =-  liftM fromIntegral $ withForeignPtr pc $ \ptr ->-    msgpack_pack_map ptr (fromIntegral n)--foreign import ccall "msgpack_pack_map_wrap" msgpack_pack_map ::-  Ptr () -> CUInt -> IO CInt---- | 'packRAW' @p n@ starts packing a byte sequence. --- Next total @n@ bytes of 'packRAWBody' call will consist this sequence.-packRAW :: Packer -> Int -> IO Int-packRAW pc n =-  liftM fromIntegral $ withForeignPtr pc $ \ptr ->-    msgpack_pack_raw ptr (fromIntegral n)--foreign import ccall "msgpack_pack_raw_wrap" msgpack_pack_raw ::-  Ptr () -> CSize -> IO CInt---- | Pack a byte sequence.-packRAWBody :: Packer -> ByteString -> IO Int-packRAWBody pc bs =-  liftM fromIntegral $ withForeignPtr pc $ \ptr ->-  BS.useAsCStringLen bs $ \(str, len) ->-    msgpack_pack_raw_body ptr (castPtr str) (fromIntegral len)--foreign import ccall "msgpack_pack_raw_body_wrap" msgpack_pack_raw_body ::-  Ptr () -> Ptr () -> CSize -> IO CInt---- | Pack a single byte stream. It calls 'packRAW' and 'packRAWBody'.-packRAW' :: Packer -> ByteString -> IO Int-packRAW' pc bs = do-  _ <- packRAW pc (BS.length bs)-  packRAWBody pc bs--type Unpacker = ForeignPtr ()--defaultInitialBufferSize :: Int-defaultInitialBufferSize = 32 * 1024 -- #const MSGPACK_UNPACKER_DEFAULT_INITIAL_BUFFER_SIZE---- | 'newUnpacker' @initialBufferSize@ creates a new Unpacker. It will be deleted automatically.-newUnpacker :: Int -> IO Unpacker-newUnpacker initialBufferSize = do-  ptr <- msgpack_unpacker_new (fromIntegral initialBufferSize)-  fptr <- newForeignPtr ptr $ do-    msgpack_unpacker_free ptr-  return fptr--foreign import ccall "msgpack_unpacker_new" msgpack_unpacker_new ::-  CSize -> IO (Ptr ())--foreign import ccall "msgpack_unpacker_free" msgpack_unpacker_free ::-  Ptr() -> IO ()---- | 'unpackerReserveBuffer' @up size@ reserves at least @size@ bytes of buffer.-unpackerReserveBuffer :: Unpacker -> Int -> IO Bool-unpackerReserveBuffer up size =-  withForeignPtr up $ \ptr ->-  liftM (/=0) $ msgpack_unpacker_reserve_buffer ptr (fromIntegral size)--foreign import ccall "msgpack_unpacker_reserve_buffer_wrap" msgpack_unpacker_reserve_buffer ::-  Ptr () -> CSize -> IO CChar---- | Get a pointer of unpacker buffer.-unpackerBuffer :: Unpacker -> IO (Ptr CChar)-unpackerBuffer up =-  withForeignPtr up $ \ptr ->-  msgpack_unpacker_buffer ptr--foreign import ccall "msgpack_unpacker_buffer_wrap" msgpack_unpacker_buffer ::-  Ptr () -> IO (Ptr CChar)---- | Get size of allocated buffer.-unpackerBufferCapacity :: Unpacker -> IO Int-unpackerBufferCapacity up =-  withForeignPtr up $ \ptr ->-  liftM fromIntegral $ msgpack_unpacker_buffer_capacity ptr--foreign import ccall "msgpack_unpacker_buffer_capacity_wrap" msgpack_unpacker_buffer_capacity ::-  Ptr () -> IO CSize---- | 'unpackerBufferConsumed' @up size@ notices that writed @size@ bytes to buffer.-unpackerBufferConsumed :: Unpacker -> Int -> IO ()-unpackerBufferConsumed up size =-  withForeignPtr up $ \ptr ->-  msgpack_unpacker_buffer_consumed ptr (fromIntegral size)--foreign import ccall "msgpack_unpacker_buffer_consumed_wrap" msgpack_unpacker_buffer_consumed ::-  Ptr () -> CSize -> IO ()---- | Write byte sequence to Unpacker. It is utility funciton, calls 'unpackerReserveBuffer', 'unpackerBuffer' and 'unpackerBufferConsumed'.-unpackerFeed :: Unpacker -> ByteString -> IO ()-unpackerFeed up bs =-  BS.useAsCStringLen bs $ \(str, len) -> do-    True <- unpackerReserveBuffer up len-    ptr <- unpackerBuffer up-    copyArray ptr str len-    unpackerBufferConsumed up len---- | Execute deserializing. It returns 0 when buffer contains not enough bytes, returns 1 when succeeded, returns negative value when it failed.-unpackerExecute :: Unpacker -> IO Int-unpackerExecute up =-  withForeignPtr up $ \ptr ->-  liftM fromIntegral $ msgpack_unpacker_execute ptr--foreign import ccall "msgpack_unpacker_execute" msgpack_unpacker_execute ::-  Ptr () -> IO CInt---- | Returns a deserialized object when 'unpackerExecute' returned 1.-unpackerData :: Unpacker -> IO Object-unpackerData up =-  withForeignPtr up $ \ptr ->-  allocaBytes (#size msgpack_object) $ \pobj -> do-    msgpack_unpacker_data ptr pobj-    peekObject pobj--foreign import ccall "msgpack_unpacker_data_wrap" msgpack_unpacker_data ::-  Ptr () -> Ptr () -> IO ()---- | Release memory zone. The returned zone must be freed by calling 'freeZone'.-unpackerReleaseZone :: Unpacker -> IO Zone-unpackerReleaseZone up =-  withForeignPtr up $ \ptr ->-  msgpack_unpacker_release_zone ptr--foreign import ccall "msgpack_unpacker_release_zone" msgpack_unpacker_release_zone ::-  Ptr () -> IO (Ptr ())---- | Free memory zone used by Unapcker.-unpackerResetZone :: Unpacker -> IO ()-unpackerResetZone up =-  withForeignPtr up $ \ptr ->-  msgpack_unpacker_reset_zone ptr--foreign import ccall "msgpack_unpacker_reset_zone" msgpack_unpacker_reset_zone ::-  Ptr () -> IO ()---- | Reset Unpacker state except memory zone.-unpackerReset :: Unpacker -> IO ()-unpackerReset up =-  withForeignPtr up $ \ptr ->-  msgpack_unpacker_reset ptr--foreign import ccall "msgpack_unpacker_reset" msgpack_unpacker_reset ::-  Ptr () -> IO ()---- | Returns number of bytes of sequence of deserializing object.-unpackerMessageSize :: Unpacker -> IO Int-unpackerMessageSize up =-  withForeignPtr up $ \ptr ->-  liftM fromIntegral $ msgpack_unpacker_message_size ptr--foreign import ccall "msgpack_unpacker_message_size_wrap" msgpack_unpacker_message_size ::-  Ptr () -> IO CSize--type Zone = Ptr ()---- | Create a new memory zone. It must be freed manually.-newZone :: IO Zone-newZone =-  msgpack_zone_new (#const MSGPACK_ZONE_CHUNK_SIZE)---- | Free a memory zone.-freeZone :: Zone -> IO ()-freeZone z =-  msgpack_zone_free z---- | Create a memory zone, then execute argument, then free memory zone.-withZone :: (Zone -> IO a) -> IO a-withZone z =-  bracket newZone freeZone z--foreign import ccall "msgpack_zone_new" msgpack_zone_new ::-  CSize -> IO Zone--foreign import ccall "msgpack_zone_free" msgpack_zone_free ::-  Zone -> IO ()---- | Object Representation of MessagePack data.-data Object =-  ObjectNil-  | ObjectBool Bool-  | ObjectInteger Int-  | ObjectDouble Double-  | ObjectRAW ByteString-  | ObjectArray [Object]-  | ObjectMap [(Object, Object)]-  deriving (Show)--peekObject :: Ptr a -> IO Object-peekObject ptr = do-  typ <- (#peek msgpack_object, type) ptr-  case (typ :: CInt) of-    (#const MSGPACK_OBJECT_NIL) ->-      return ObjectNil-    (#const MSGPACK_OBJECT_BOOLEAN) ->-      peekObjectBool ptr-    (#const MSGPACK_OBJECT_POSITIVE_INTEGER) ->-      peekObjectPositiveInteger ptr-    (#const MSGPACK_OBJECT_NEGATIVE_INTEGER) ->-      peekObjectNegativeInteger ptr-    (#const MSGPACK_OBJECT_DOUBLE) ->-      peekObjectDouble ptr-    (#const MSGPACK_OBJECT_RAW) ->-      peekObjectRAW ptr-    (#const MSGPACK_OBJECT_ARRAY) ->-      peekObjectArray ptr-    (#const MSGPACK_OBJECT_MAP) ->-      peekObjectMap ptr-    _ ->-      fail $ "peekObject: unknown object type (" ++ show typ ++ ")"--peekObjectBool :: Ptr a -> IO Object-peekObjectBool ptr = do-  b <- (#peek msgpack_object, via.boolean) ptr-  return $ ObjectBool $ (b :: CUChar) /= 0--peekObjectPositiveInteger :: Ptr a -> IO Object-peekObjectPositiveInteger ptr = do-  n <- (#peek msgpack_object, via.u64) ptr-  return $ ObjectInteger $ fromIntegral (n :: Word64)--peekObjectNegativeInteger :: Ptr a -> IO Object-peekObjectNegativeInteger ptr = do-  n <- (#peek msgpack_object, via.i64) ptr-  return $ ObjectInteger $ fromIntegral (n :: Int64)--peekObjectDouble :: Ptr a -> IO Object-peekObjectDouble ptr = do-  d <- (#peek msgpack_object, via.dec) ptr-  return $ ObjectDouble $ realToFrac (d :: CDouble)--peekObjectRAW :: Ptr a -> IO Object-peekObjectRAW ptr = do-  size <- (#peek msgpack_object, via.raw.size) ptr-  p    <- (#peek msgpack_object, via.raw.ptr) ptr-  bs   <- BS.packCStringLen (p, fromIntegral (size :: Word32))-  return $ ObjectRAW bs--peekObjectArray :: Ptr a -> IO Object-peekObjectArray ptr = do-  csize <- (#peek msgpack_object, via.array.size) ptr-  let size = fromIntegral (csize :: Word32)-  p     <- (#peek msgpack_object, via.array.ptr) ptr-  objs  <- mapM (\i -> peekObject $ p `plusPtr`-                      ((#size msgpack_object) * i))-           [0..size-1]-  return $ ObjectArray objs--peekObjectMap :: Ptr a -> IO Object-peekObjectMap ptr = do-  csize <- (#peek msgpack_object, via.map.size) ptr-  let size = fromIntegral (csize :: Word32)-  p     <- (#peek msgpack_object, via.map.ptr) ptr-  dat   <- mapM (\i -> peekObjectKV $ p `plusPtr`-                      ((#size msgpack_object_kv) * i))-           [0..size-1]-  return $ ObjectMap dat--peekObjectKV :: Ptr a -> IO (Object, Object)-peekObjectKV ptr = do-  k <- peekObject $ ptr `plusPtr` (#offset msgpack_object_kv, key)-  v <- peekObject $ ptr `plusPtr` (#offset msgpack_object_kv, val)-  return (k, v)---- | Pack a Object.-packObject :: Packer -> Object -> IO ()-packObject pc ObjectNil = packNil pc >> return ()--packObject pc (ObjectBool b) = packBool pc b >> return ()--packObject pc (ObjectInteger n) = packInt pc n >> return ()--packObject pc (ObjectDouble d) = packDouble pc d >> return ()--packObject pc (ObjectRAW bs) = packRAW' pc bs >> return ()--packObject pc (ObjectArray ls) = do-  _ <- packArray pc (length ls)-  mapM_ (packObject pc) ls--packObject pc (ObjectMap ls) = do-  _ <- packMap pc (length ls)-  mapM_ (\(a, b) -> packObject pc a >> packObject pc b) ls--data UnpackReturn =-  UnpackContinue     -- ^ not enough bytes to unpack object-  | UnpackParseError -- ^ got invalid bytes-  | UnpackError      -- ^ other error-  deriving (Eq, Show)---- | Unpack a single MessagePack object from byte sequence.-unpackObject :: Zone -> ByteString -> IO (Either UnpackReturn (Int, Object))-unpackObject z dat =-  allocaBytes (#size msgpack_object) $ \ptr ->-  BS.useAsCStringLen dat $ \(str, len) ->-  alloca $ \poff -> do-    poke poff 0-    ret <- msgpack_unpack str (fromIntegral len) poff z ptr-    case ret of-      (#const MSGPACK_UNPACK_SUCCESS) -> do-        off <- peek poff-        obj <- peekObject ptr-        return $ Right (fromIntegral off, obj)-      (#const MSGPACK_UNPACK_EXTRA_BYTES) -> do-        off <- peek poff-        obj <- peekObject ptr-        return $ Right (fromIntegral off, obj)-      (#const MSGPACK_UNPACK_CONTINUE) ->-        return $ Left UnpackContinue-      (#const MSGPACK_UNPACK_PARSE_ERROR) ->-        return $ Left UnpackParseError-      _ ->-        return $ Left UnpackError--foreign import ccall "msgpack_unpack" msgpack_unpack ::-  Ptr CChar -> CSize -> Ptr CSize -> Zone -> Ptr () -> IO CInt

@@ -1,101 +0,0 @@-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverlappingInstances #-}-{-# LANGUAGE IncoherentInstances #-}------------------------------------------------------------------------- |--- Module    : Data.MessagePack.Class--- Copyright : (c) Hideyuki Tanaka, 2009--- License   : BSD3------ Maintainer:  tanaka.hideyuki@gmail.com--- Stability :  experimental--- Portability: portable------ Serializing Haskell values to and from MessagePack Objects.--------------------------------------------------------------------------module Data.MessagePack.Class(-  -- * Serialization to and from Object-  OBJECT(..),-  Result,-  pack,-  ) where--import Control.Monad.Error-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as C8--import Data.MessagePack.Base---- | The class of types serializable to and from MessagePack object-class OBJECT a where-  toObject :: a -> Object-  fromObject :: Object -> Result a---- | A type for parser results-type Result a = Either String a--instance OBJECT Object where-  toObject = id-  fromObject = Right--fromObjectError :: String-fromObjectError = "fromObject: cannot cast"--instance OBJECT () where-  toObject = const ObjectNil-  fromObject ObjectNil = Right ()-  fromObject _ = Left fromObjectError--instance OBJECT Int where-  toObject = ObjectInteger-  fromObject (ObjectInteger n) = Right n-  fromObject _ = Left fromObjectError--instance OBJECT Bool where-  toObject = ObjectBool-  fromObject (ObjectBool b) = Right b-  fromObject _ = Left fromObjectError--instance OBJECT Double where-  toObject = ObjectDouble-  fromObject (ObjectDouble d) = Right d-  fromObject _ = Left fromObjectError--instance OBJECT ByteString where-  toObject = ObjectRAW-  fromObject (ObjectRAW bs) = Right bs-  fromObject _ = Left fromObjectError--instance OBJECT String where-  toObject = toObject . C8.pack-  fromObject obj = liftM C8.unpack $ fromObject obj--instance OBJECT a => OBJECT [a] where-  toObject = ObjectArray . map toObject-  fromObject (ObjectArray arr) =-    mapM fromObject arr-  fromObject _ =-    Left fromObjectError--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--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---- | Pack a serializable Haskell value.-pack :: OBJECT a => Packer -> a -> IO ()-pack pc = packObject pc . toObject

@@ -1,62 +0,0 @@------------------------------------------------------------------------ |--- Module    : Data.MessagePack.Feed--- Copyright : (c) Hideyuki Tanaka, 2009--- License   : BSD3------ Maintainer:  tanaka.hideyuki@gmail.com--- Stability :  experimental--- Portability: portable------ Feeders for Stream Deserializers--------------------------------------------------------------------------module Data.MessagePack.Feed(-  -- * Feeder type-  Feeder,-  -- * Feeders-  feederFromHandle,-  feederFromFile,-  feederFromString,-  ) where--import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import Data.IORef-import System.IO---- | Feeder returns Just ByteString when bytes remains, otherwise Nothing.-type Feeder = IO (Maybe ByteString)---- | Feeder from Handle-feederFromHandle :: Handle -> IO Feeder-feederFromHandle h = return $ do-  bs <- BS.hGetNonBlocking h bufSize-  if BS.length bs > 0-    then do return $ Just bs-    else do-    c <- BS.hGet h 1-    if BS.length c > 0-      then do return $ Just c-      else do-      hClose h-      return Nothing-  where-    bufSize = 4096---- | Feeder from File-feederFromFile :: FilePath -> IO Feeder-feederFromFile path =-  openFile path ReadMode >>= feederFromHandle---- | Feeder from ByteString-feederFromString :: ByteString -> IO Feeder-feederFromString bs = do-  r <- newIORef (Just bs)-  return $ f r-  where-    f r = do-      mb <- readIORef r-      writeIORef r Nothing-      return mb

@@ -1,156 +0,0 @@------------------------------------------------------------------------ |--- Module    : Data.MessagePack.Monad--- Copyright : (c) Hideyuki Tanaka, 2009--- License   : BSD3------ Maintainer:  tanaka.hideyuki@gmail.com--- Stability :  experimental--- Portability: portable------ Monadic Stream Serializers and Deserializers--------------------------------------------------------------------------module Data.MessagePack.Monad(-  -- * Classes-  MonadPacker(..),-  MonadUnpacker(..),-  -  -- * Packer and Unpacker type-  PackerT(..),-  UnpackerT(..),-  -  -- * Packers-  packToString,-  packToHandle,-  packToFile,-  -  -- * Unpackers-  unpackFrom,-  unpackFromString,-  unpackFromHandle,-  unpackFromFile,-  ) where--import Control.Monad-import Control.Monad.Trans-import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import System.IO--import Data.MessagePack.Base hiding (Unpacker)-import qualified Data.MessagePack.Base as Base-import Data.MessagePack.Class-import Data.MessagePack.Feed--class Monad m => MonadPacker m where-  -- | Serialize a object-  put :: OBJECT a => a -> m ()--class Monad m => MonadUnpacker m where-  -- | Deserialize a object-  get :: OBJECT a => m a---- | Serializer Type-newtype PackerT m r = PackerT { runPackerT :: Base.Packer -> m r }--instance Monad m => Monad (PackerT m) where-  a >>= b =-    PackerT $ \pc -> do-      r <- runPackerT a pc-      runPackerT (b r) pc-  -  return r =-    PackerT $ \_ -> return r--instance MonadTrans PackerT where-  lift m = PackerT $ \_ -> m--instance MonadIO m => MonadIO (PackerT m) where-  liftIO = lift . liftIO--instance MonadIO m => MonadPacker (PackerT m) where-  put v = PackerT $ \pc -> liftIO $ do-    pack pc v---- | Execute given serializer and returns byte sequence.-packToString :: MonadIO m => PackerT m r -> m ByteString-packToString m = do-  sb <- liftIO $ newSimpleBuffer-  pc <- liftIO $ newPacker sb-  _ <- runPackerT m pc-  liftIO $ simpleBufferData sb---- | Execute given serializer and write byte sequence to Handle.-packToHandle :: MonadIO m => Handle -> PackerT m r -> m ()-packToHandle h m = do-  sb <- packToString m-  liftIO $ BS.hPut h sb-  liftIO $ hFlush h---- | Execute given serializer and write byte sequence to file.-packToFile :: MonadIO m => FilePath -> PackerT m r -> m ()-packToFile p m = do-  sb <- packToString m-  liftIO $ BS.writeFile p sb---- | Deserializer type-newtype UnpackerT m r = UnpackerT { runUnpackerT :: Base.Unpacker -> Feeder -> m r }--instance Monad m => Monad (UnpackerT m) where-  a >>= b =-    UnpackerT $ \up feed -> do-      r <- runUnpackerT a up feed-      runUnpackerT (b r) up feed-  -  return r =-    UnpackerT $ \_ _ -> return r--instance MonadTrans UnpackerT where-  lift m = UnpackerT $ \_ _ -> m--instance MonadIO m => MonadIO (UnpackerT m) where-  liftIO = lift . liftIO--instance MonadIO m => MonadUnpacker (UnpackerT m) where-  get = UnpackerT $ \up feed -> liftIO $ do-    executeOne up feed-    obj <- unpackerData up-    freeZone =<< unpackerReleaseZone up-    unpackerReset up-    let Right r = fromObject obj-    return r-    -    where-      executeOne up feed = do-        resp <- unpackerExecute up-        guard $ resp>=0-        when (resp==0) $ do-          Just bs <- feed-          unpackerFeed up bs-          executeOne up feed---- | Execute deserializer using given feeder.-unpackFrom :: MonadIO m => Feeder -> UnpackerT m r -> m r-unpackFrom f m = do-  up <- liftIO $ newUnpacker defaultInitialBufferSize-  runUnpackerT m up f---- | Execute deserializer using given handle.-unpackFromHandle :: MonadIO m => Handle -> UnpackerT m r -> m r-unpackFromHandle h m =-  flip unpackFrom m =<< liftIO (feederFromHandle h)---- | Execute deserializer using given file content.-unpackFromFile :: MonadIO m => FilePath -> UnpackerT m r -> m r-unpackFromFile p m = do-  h <- liftIO $ openFile p ReadMode-  r <- flip unpackFrom m =<< liftIO (feederFromHandle h)-  liftIO $ hClose h-  return r---- | Execute deserializer from given byte sequence.-unpackFromString :: MonadIO m => ByteString -> UnpackerT m r -> m r-unpackFromString bs m = do-  flip unpackFrom m =<< liftIO (feederFromString bs)

@@ -0,0 +1,109 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}++--------------------------------------------------------------------+-- |+-- 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.Monad+import Control.Monad.Trans.Error ()+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as C8++-- | Object Representation of MessagePack data.+data Object =+  ObjectNil+  | ObjectBool Bool+  | ObjectInteger Int+  | ObjectDouble Double+  | ObjectRAW B.ByteString+  | ObjectArray [Object]+  | ObjectMap [(Object, Object)]+  deriving (Show)++-- | The class of types serializable to and from MessagePack object+class OBJECT a where+  -- | Encode a value to MessagePack object+  toObject :: a -> Object+  -- | Decode a value from MessagePack object+  fromObject :: Object -> Result a++-- | A type for parser results+type Result a = Either String a++instance OBJECT Object where+  toObject = id+  fromObject = Right++fromObjectError :: String+fromObjectError = "fromObject: cannot cast"++instance OBJECT () where+  toObject = const ObjectNil+  fromObject ObjectNil = Right ()+  fromObject _ = Left fromObjectError++instance OBJECT Int where+  toObject = ObjectInteger+  fromObject (ObjectInteger n) = Right n+  fromObject _ = Left fromObjectError++instance OBJECT Bool where+  toObject = ObjectBool+  fromObject (ObjectBool b) = Right b+  fromObject _ = Left fromObjectError++instance OBJECT Double where+  toObject = ObjectDouble+  fromObject (ObjectDouble d) = Right d+  fromObject _ = Left fromObjectError++instance OBJECT B.ByteString where+  toObject = ObjectRAW+  fromObject (ObjectRAW bs) = Right bs+  fromObject _ = Left fromObjectError++instance OBJECT String where+  toObject = toObject . C8.pack+  fromObject obj = liftM C8.unpack $ fromObject obj++instance OBJECT a => OBJECT [a] where+  toObject = ObjectArray . map toObject+  fromObject (ObjectArray arr) =+    mapM fromObject arr+  fromObject _ =+    Left fromObjectError++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++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

@@ -0,0 +1,259 @@+{-# Language FlexibleInstances #-}+{-# Language IncoherentInstances #-}+{-# Language OverlappingInstances #-}++--------------------------------------------------------------------+-- |+-- 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.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 Int where+  get = parseInt++instance ObjectGet () where+  get = parseNil++instance ObjectGet Bool where+  get = parseBool++instance ObjectGet Double where+  get = parseDouble++instance ObjectGet B.ByteString where+  get = parseRAW++instance ObjectGet a => ObjectGet [a] where+  get = parseArray++instance ObjectGet a => ObjectGet (V.Vector a) where+  get = parseArrayVector++instance (ObjectGet k, ObjectGet v) => ObjectGet [(k, v)] where+  get = parseMap++instance (ObjectGet k, ObjectGet v) => ObjectGet (V.Vector (k, v)) where+  get = parseMapVector++instance ObjectGet Object where+  get = parseObject++parseInt :: A.Parser Int+parseInt = 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++parseNil :: A.Parser ()+parseNil = do+  _ <- A.word8 0xC0+  return ()++parseBool :: A.Parser Bool+parseBool = do+  c <- A.anyWord8+  case c of+    0xC3 ->+      return True+    0xC2 ->+      return False+    _ ->+      fail $ printf "invlid bool tag: 0x%02X" c++parseDouble :: A.Parser Double+parseDouble = 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++parseRAW :: A.Parser B.ByteString+parseRAW = do+  c <- A.anyWord8+  case c of+    _ | c .&. 0xE0 == 0xA0 ->+      A.take . fromIntegral $ c .&. 0x1F+    0xDA ->+      A.take . fromIntegral =<< parseUint16+    0xDB ->+      A.take . fromIntegral =<< parseUint32+    _ ->+      fail $ printf "invlid raw tag: 0x%02X" c+  +parseArray :: ObjectGet a => A.Parser [a]+parseArray = do+  c <- A.anyWord8+  case c of+    _ | c .&. 0xF0 == 0x90 ->+      flip replicateM get . fromIntegral $ c .&. 0x0F+    0xDC ->+      flip replicateM get . fromIntegral =<< parseUint16+    0xDD ->+      flip replicateM get . fromIntegral =<< parseUint32+    _ ->+      fail $ printf "invlid array tag: 0x%02X" c++parseArrayVector :: ObjectGet a => A.Parser (V.Vector a)+parseArrayVector = do+  c <- A.anyWord8+  case c of+    _ | c .&. 0xF0 == 0x90 ->+      flip V.replicateM get . fromIntegral $ c .&. 0x0F+    0xDC ->+      flip V.replicateM get . fromIntegral =<< parseUint16+    0xDD ->+      flip V.replicateM get . fromIntegral =<< parseUint32+    _ ->+      fail $ printf "invlid array tag: 0x%02X" c++parseMap :: (ObjectGet k, ObjectGet v) => A.Parser [(k, v)]+parseMap = do+  c <- A.anyWord8+  case c of+    _ | c .&. 0xF0 == 0x80 ->+      flip replicateM parsePair . fromIntegral $ c .&. 0x0F+    0xDE ->+      flip replicateM parsePair . fromIntegral =<< parseUint16+    0xDF ->+      flip replicateM parsePair . fromIntegral =<< parseUint32+    _ ->+      fail $ printf "invlid map tag: 0x%02X" c++parseMapVector :: (ObjectGet k, ObjectGet v) => A.Parser (V.Vector (k, v))+parseMapVector = do+  c <- A.anyWord8+  case c of+    _ | c .&. 0xF0 == 0x80 ->+      flip V.replicateM parsePair . fromIntegral $ c .&. 0x0F+    0xDE ->+      flip V.replicateM parsePair . fromIntegral =<< parseUint16+    0xDF ->+      flip V.replicateM parsePair . fromIntegral =<< parseUint32+    _ ->+      fail $ printf "invlid map tag: 0x%02X" c++parseObject :: A.Parser Object+parseObject =+  A.choice+  [ liftM ObjectInteger parseInt+  , liftM (const ObjectNil) parseNil+  , liftM ObjectBool parseBool+  , liftM ObjectDouble parseDouble+  , liftM ObjectRAW parseRAW+  , liftM ObjectArray parseArray+  , liftM ObjectMap parseMap+  ]++parsePair :: (ObjectGet k, ObjectGet v) => A.Parser (k, v)+parsePair = do+  a <- get+  b <- get+  return (a, b)++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]

@@ -0,0 +1,202 @@+{-# Language FlexibleInstances #-}+{-# Language IncoherentInstances #-}+{-# Language OverlappingInstances #-}++--------------------------------------------------------------------+-- |+-- 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.Vector as V++import Data.MessagePack.Object++-- | Serializable class+class ObjectPut a where+  -- | Serialize a value+  put :: a -> Put++instance ObjectPut Object where+  put = putObject++instance ObjectPut Int where+  put = putInteger++instance ObjectPut () where+  put _ = putNil++instance ObjectPut Bool where+  put = putBool++instance ObjectPut Double where+  put = putDouble++instance ObjectPut B.ByteString where+  put = putRAW++instance ObjectPut a => ObjectPut [a] where+  put = putArray++instance ObjectPut a => ObjectPut (V.Vector a) where+  put = putArrayVector++instance (ObjectPut k, ObjectPut v) => ObjectPut [(k, v)] where+  put = putMap++instance (ObjectPut k, ObjectPut v) => ObjectPut (V.Vector (k, v)) where+  put = putMapVector++putObject :: Object -> Put+putObject obj =+  case obj of+    ObjectInteger n ->+      putInteger n+    ObjectNil ->+      putNil+    ObjectBool b ->+      putBool b+    ObjectDouble d ->+      putDouble d+    ObjectRAW raw ->+      putRAW raw+    ObjectArray arr ->+      putArray arr+    ObjectMap m ->+      putMap m++putInteger :: Int -> Put      +putInteger 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++putNil :: Put+putNil = putWord8 0xC0++putBool :: Bool -> Put+putBool True = putWord8 0xC3+putBool False = putWord8 0xC2++putDouble :: Double -> Put+putDouble d = do+  putWord8 0xCB+  putFloat64be d++putRAW :: B.ByteString -> Put+putRAW bs = do+  case len of+    _ | len <= 31 -> do+      putWord8 $ 0xA0 .|. fromIntegral len+    _ | len < 0x10000 -> do+      putWord8 0xDA+      putWord16be $ fromIntegral len+    _ -> do+      putWord8 0xDB+      putWord32be $ fromIntegral len+  putByteString bs+  where+    len = B.length bs++putArray :: ObjectPut a => [a] -> Put+putArray arr = do+  case len of+    _ | len <= 15 ->+      putWord8 $ 0x90 .|. fromIntegral len+    _ | len < 0x10000 -> do+      putWord8 0xDC+      putWord16be $ fromIntegral len+    _ -> do+      putWord8 0xDD+      putWord32be $ fromIntegral len+  mapM_ put arr+  where+    len = length arr++putArrayVector :: ObjectPut a => V.Vector a -> Put+putArrayVector arr = do+  case len of+    _ | len <= 15 ->+      putWord8 $ 0x90 .|. fromIntegral len+    _ | len < 0x10000 -> do+      putWord8 0xDC+      putWord16be $ fromIntegral len+    _ -> do+      putWord8 0xDD+      putWord32be $ fromIntegral len+  V.mapM_ put arr+  where+    len = V.length arr++putMap :: (ObjectPut k, ObjectPut v) => [(k, v)] -> Put+putMap m = do+  case len of+    _ | len <= 15 ->+      putWord8 $ 0x80 .|. fromIntegral len+    _ | len < 0x10000 -> do+      putWord8 0xDE+      putWord16be $ fromIntegral len+    _ -> do+      putWord8 0xDF+      putWord32be $ fromIntegral len+  mapM_ (\(k, v) -> put k >> put v) m+  where+    len = length m++putMapVector :: (ObjectPut k, ObjectPut v) => V.Vector (k, v) -> Put+putMapVector m = do+  case len of+    _ | len <= 15 ->+      putWord8 $ 0x80 .|. fromIntegral len+    _ | len < 0x10000 -> do+      putWord8 0xDE+      putWord16be $ fromIntegral len+    _ -> do+      putWord8 0xDF+      putWord32be $ fromIntegral len+  V.mapM_ (\(k, v) -> put k >> put v) m+  where+    len = V.length m

@@ -1,82 +0,0 @@------------------------------------------------------------------------ |--- Module    : Data.MessagePack.Stream--- Copyright : (c) Hideyuki Tanaka, 2009--- License   : BSD3------ Maintainer:  tanaka.hideyuki@gmail.com--- Stability :  experimental--- Portability: portable------ Lazy Stream Serializers and Deserializers--------------------------------------------------------------------------module Data.MessagePack.Stream(-  unpackObjects,-  unpackObjectsFromFile,-  unpackObjectsFromHandle,-  unpackObjectsFromString,-  ) where--import Data.ByteString (ByteString)-import System.IO-import System.IO.Unsafe--import Data.MessagePack.Base-import Data.MessagePack.Feed---- | Unpack objects using given feeder.-unpackObjects :: Feeder -> IO [Object]-unpackObjects feeder = do-  up <- newUnpacker defaultInitialBufferSize-  f up-  where-  f up = unsafeInterleaveIO $ do-    mbo <- unpackOnce up-    case mbo of-      Just o -> do-        os <- f up-        return $ o:os-      Nothing ->-        return []--  unpackOnce up = do-    resp <- unpackerExecute up-    case resp of-      0 -> do-        r <- feedOnce up-        if r-          then unpackOnce up-          else return Nothing-      1 -> do-        obj <- unpackerData up-        freeZone =<< unpackerReleaseZone up-        unpackerReset up-        return $ Just obj-      _ ->-        error $ "unpackerExecute fails: " ++ show resp--  feedOnce up = do-    dat <- feeder-    case dat of-      Nothing ->-        return False-      Just bs -> do-        unpackerFeed up bs-        return True---- | Unpack objects from file.-unpackObjectsFromFile :: FilePath -> IO [Object]-unpackObjectsFromFile fname =-  unpackObjects =<< feederFromFile fname---- | Unpack objects from handle.-unpackObjectsFromHandle :: Handle -> IO [Object]-unpackObjectsFromHandle h =-  unpackObjects =<< feederFromHandle h-  --- | Unpack oobjects from given byte sequence.-unpackObjectsFromString :: ByteString -> IO [Object]-unpackObjectsFromString bs =-  unpackObjects =<< feederFromString bs