pure haskell implementation.

haskell/LICENSE

@@ -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

haskell/cbits/msgpack.c

@@ -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);
-}
-

haskell/msgpack.cabal

@@ -1,32 +1,35 @@
 Name:               msgpack
-Version:             0.2.2
+Version:            0.3.0
-License:             BSD3
-License-File:        LICENSE
-Author:              Hideyuki Tanaka
-Maintainer:          Hideyuki Tanaka <tanaka.hideyuki@gmail.com>
-Category:            Data
 Synopsis:           A Haskell binding to MessagePack
 Description:
   A Haskell binding to MessagePack <http://msgpack.sourceforge.jp/>
+
+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.10.4
+Tested-with:        GHC == 6.12.3
 Cabal-Version:      >= 1.2
 Build-Type:         Simple
 
-library
+Library
-  build-depends:	base>=4 && <5, mtl, bytestring
+  Build-depends:    base >=4 && <5,
-  ghc-options:		-O2 -Wall
+                    transformers >= 0.2.1 && < 0.2.2,
-  hs-source-dirs:	src
+                    MonadCatchIO-transformers >= 0.2.2 && < 0.2.3,
-  extra-libraries:	msgpackc
+                    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.Object
-    Data.MessagePack.Class
+    Data.MessagePack.Put
-    Data.MessagePack.Feed
+    Data.MessagePack.Parser
-    Data.MessagePack.Monad
-    Data.MessagePack.Stream
-
-  C-Sources:
-    cbits/msgpack.c

haskell/src/Data/MessagePack.hs

@@ -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.Object,
-  module Data.MessagePack.Class,
+  module Data.MessagePack.Put,
-  module Data.MessagePack.Feed,
+  module Data.MessagePack.Parser,
-  module Data.MessagePack.Monad,
-  module Data.MessagePack.Stream,
   
-  -- * Pack and Unpack
+  -- * Simple functions of Pack and Unpack
-  packb,
+  pack,
-  unpackb,
+  unpack,
+  
+  -- * Pack functions
+  packToString,
+  packToHandle,
+  packToFile,
+  
+  -- * Unpack functions
+  unpackFromString,
+  unpackFromHandle,
+  unpackFromFile,
   
-  -- * Pure version of Pack and Unpack
-  packb',
-  unpackb',
   ) where
 
-import Data.ByteString (ByteString)
+import qualified Control.Monad.CatchIO as CIO
-import System.IO.Unsafe
+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.Object
-import Data.MessagePack.Class
+import Data.MessagePack.Put
-import Data.MessagePack.Feed
+import Data.MessagePack.Parser
-import Data.MessagePack.Monad
+
-import Data.MessagePack.Stream
+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
+pack :: ObjectPut a => a -> L.ByteString
-packb dat = do
+pack = packToString . put
-  sb <- newSimpleBuffer
-  pc <- newPacker sb
-  pack pc dat
-  simpleBufferData sb
 
 -- | Unpack MessagePack string to Haskell data.
-unpackb :: OBJECT a => ByteString -> IO (Result a)
+unpack :: (ObjectGet a, IsByteString s) => s -> a
-unpackb bs = do
+unpack bs =
-  withZone $ \z -> do
+  runIdentity $ I.run $ I.joinIM $ I.enumPure1Chunk (toBS bs) (parserToIteratee get)
-    r <- unpackObject z bs
-    return $ case r of
-      Left err -> Left (show err)
-      Right (_, dat) -> fromObject dat
 
--- | Pure version of 'packb'.
+-- TODO: tryUnpack
-packb' :: OBJECT a => a -> ByteString
-packb' dat = unsafePerformIO $ packb dat
 
--- | Pure version of 'unpackb'.
+-- | Pack to ByteString.
-unpackb' :: OBJECT a => ByteString -> Result a
+packToString :: Put -> L.ByteString
-unpackb' bs = unsafePerformIO $ unpackb bs
+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)

haskell/src/Data/MessagePack/Base.hsc

@@ -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

haskell/src/Data/MessagePack/Feed.hs

@@ -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

haskell/src/Data/MessagePack/Monad.hs

@@ -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)

haskell/src/Data/MessagePack/Object.hs

@@ -1,38 +1,50 @@
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverlappingInstances #-}
-{-# LANGUAGE IncoherentInstances #-}
 
 --------------------------------------------------------------------
 -- |
--- Module    : Data.MessagePack.Class
+-- Module    : Data.MessagePack.Object
--- Copyright : (c) Hideyuki Tanaka, 2009
+-- Copyright : (c) Hideyuki Tanaka, 2009-2010
 -- License   : BSD3
 --
 -- Maintainer:  tanaka.hideyuki@gmail.com
 -- Stability :  experimental
 -- Portability: portable
 --
--- Serializing Haskell values to and from MessagePack Objects.
+-- MessagePack object definition
 --
 --------------------------------------------------------------------
 
-module Data.MessagePack.Class(
+module Data.MessagePack.Object(
+  -- * MessagePack Object
+  Object(..),
+  
   -- * Serialization to and from Object
   OBJECT(..),
   Result,
-  pack,
   ) where
 
-import Control.Monad.Error
+import Control.Monad
-import Data.ByteString.Char8 (ByteString)
+import Control.Monad.Trans.Error ()
+import qualified Data.ByteString as B
 import qualified Data.ByteString.Char8 as C8
 
-import Data.MessagePack.Base
+-- | 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
@@ -65,7 +77,7 @@ instance OBJECT Double where
   fromObject (ObjectDouble d) = Right d
   fromObject _ = Left fromObjectError
 
-instance OBJECT ByteString where
+instance OBJECT B.ByteString where
   toObject = ObjectRAW
   fromObject (ObjectRAW bs) = Right bs
   fromObject _ = Left fromObjectError
@@ -95,7 +107,3 @@ instance OBJECT a => OBJECT (Maybe a) where
   
   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

haskell/src/Data/MessagePack/Packer.hs

@@ -0,0 +1,147 @@
+{-# Language FlexibleInstances #-}
+{-# Language OverlappingInstances #-}
+
+module Data.MessagePack.Packer(
+  ObjectPut(..),
+  ) where
+
+import Data.Binary.Put
+import Data.Binary.IEEE754
+import Data.Bits
+import qualified Data.ByteString as B
+
+import Data.MessagePack.Object
+
+class ObjectPut a where
+  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 k, ObjectPut v) => ObjectPut [(k, v)] where
+  put = putMap
+
+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 >= -0x100 -> do
+      putWord8 0xD0
+      putWord8 $ fromIntegral n
+    _ | n >= -0x10000 -> do
+      putWord8 0xD1
+      putWord16be $ fromIntegral n
+    _ | n >= -0x100000000 -> 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
+
+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
+      putWord16be $ fromIntegral len
+  mapM_ (\(k, v) -> put k >> put v) m
+  where
+    len = length m

haskell/src/Data/MessagePack/Put.hs

@@ -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

haskell/src/Data/MessagePack/Stream.hs

@@ -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

haskell/test/Monad.hs

@@ -1,16 +1,21 @@
-import Control.Monad.Trans
+{-# Language OverloadedStrings #-}
+
+import Control.Monad.IO.Class
+import qualified Data.ByteString as B
 import Data.MessagePack
 
 main = do
-  sb <- packToString $ do
+  sb <- return $ packToString $ do
     put [1,2,3::Int]
     put (3.14 :: Double)
-    put "Hoge"
+    put ("Hoge" :: B.ByteString)
   
   print sb
   
-  unpackFromString sb $ do
+  r <- unpackFromString sb $ do
     arr <- get
     dbl <- get
     str <- get
-    liftIO $ print (arr :: [Int], dbl :: Double, str :: String)
+    return (arr :: [Int], dbl :: Double, str :: B.ByteString)
+  
+  print r

haskell/test/Stream.hs

@@ -1,14 +0,0 @@
-import Control.Applicative
-import qualified Data.ByteString as BS
-import Data.MessagePack
-
-main = do
-  sb <- newSimpleBuffer
-  pc <- newPacker sb
-  pack pc [1,2,3::Int]
-  pack pc True
-  pack pc "hoge"
-  bs <- simpleBufferData sb
-  
-  os <- unpackObjectsFromString bs
-  mapM_ print os

haskell/test/Test.hs

@@ -1,36 +1,45 @@
+import Test.Framework
+import Test.Framework.Providers.QuickCheck2
+import Test.QuickCheck
+
 import Control.Monad
+import qualified Data.ByteString.Char8 as B
 import Data.MessagePack
 
-{-
+mid :: (ObjectGet a, ObjectPut a) => a -> a
-main = do
+mid = unpack . pack
-  sb <- newSimpleBuffer
-  pc <- newPacker sb
 
-  pack pc [(1,2),(2,3),(3::Int,4::Int)]
+prop_mid_int a = a == mid a
-  pack pc [4,5,6::Int]
+  where types = a :: Int
-  pack pc "hoge"
+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 == B.unpack (mid (B.pack a))
+  where types = a :: String
+prop_mid_array_int a = a == mid a
+  where types = a :: [Int]
+prop_mid_array_string a = a == map B.unpack (mid (map B.pack a))
+  where types = a :: [String]
+prop_mid_map_int_double a = a == mid a
+  where types = a :: [(Int, Double)]
+prop_mid_map_string_string a = a == map (\(x, y) -> (B.unpack x, B.unpack y)) (mid (map (\(x, y) -> (B.pack x, B.pack y)) a))
+  where types = a :: [(String, String)]
 
-  bs <- simpleBufferData sb
+tests =
-  print bs
+  [ 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 "[int]" prop_mid_array_int
+    , testProperty "[string]" prop_mid_array_string
+    , testProperty "[(int, double)]" prop_mid_map_int_double
+    , testProperty "[(string, string)]" prop_mid_map_string_string
+    ]
+  ]
 
-  up <- newUnpacker defaultInitialBufferSize
+main = defaultMain tests
-  
-  unpackerFeed up bs
-
-  let f = do
-        res <- unpackerExecute up
-        when (res==1) $ do
-          obj <- unpackerData up
-          print obj
-          f
-  
-  f
-
-  return ()
--}
-
-main = do
-  bs <- packb [(1,2),(2,3),(3::Int,4::Int)]
-  print bs
-  dat <- unpackb bs
-  print (dat :: Result [(Int, Int)])