msgpack 0.3.0 → 0.3.1

raw patch · 6 files changed

+399/−285 lines, 6 filesdep +deepseqPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: deepseq

API changes (from Hackage documentation)

Files

• msgpack.cabal +7/−4
• src/Data/MessagePack.hs +30/−21
• src/Data/MessagePack/Iteratee.hs +82/−0
• src/Data/MessagePack/Object.hs +18/−3
• src/Data/MessagePack/Parser.hs +139/−128
• src/Data/MessagePack/Put.hs +123/−129

@@ -1,15 +1,15 @@ Name:               msgpack-Version:            0.3.0+Version:            0.3.1 Synopsis:           A Haskell binding to MessagePack Description:-  A Haskell binding to MessagePack <http://msgpack.sourceforge.jp/>+  A Haskell binding to MessagePack <http://msgpack.org/>  License:            BSD3 License-File:       LICENSE Category:           Data Author:             Hideyuki Tanaka Maintainer:         Hideyuki Tanaka <tanaka.hideyuki@gmail.com>-Homepage:           http://github.com/tanakh/hsmsgpack+Homepage:           http://github.com/msgpack/msgpack Stability:          Experimental Tested-with:        GHC == 6.12.3 Cabal-Version:      >= 1.2@@ -24,7 +24,9 @@                     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+                    data-binary-ieee754 >= 0.4 && < 0.5,+                    deepseq >= 1.1 && <1.2+   Ghc-options:      -Wall -O2   Hs-source-dirs:   src @@ -33,3 +35,4 @@     Data.MessagePack.Object     Data.MessagePack.Put     Data.MessagePack.Parser+    Data.MessagePack.Iteratee

@@ -16,6 +16,7 @@   module Data.MessagePack.Object,   module Data.MessagePack.Put,   module Data.MessagePack.Parser,+  module Data.MessagePack.Iteratee,      -- * Simple functions of Pack and Unpack   pack,@@ -24,12 +25,16 @@   -- * Pack functions   packToString,   packToHandle,+  packToHandle',   packToFile,      -- * Unpack functions   unpackFromString,   unpackFromHandle,   unpackFromFile,+  unpackFromStringI,+  unpackFromHandleI,+  unpackFromFileI,      ) where @@ -41,12 +46,12 @@ 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.Object import Data.MessagePack.Put import Data.MessagePack.Parser+import Data.MessagePack.Iteratee  bufferSize :: Int bufferSize = 4 * 1024@@ -67,7 +72,7 @@ -- | Unpack MessagePack string to Haskell data. unpack :: (ObjectGet a, IsByteString s) => s -> a unpack bs =-  runIdentity $ I.run $ I.joinIM $ I.enumPure1Chunk (toBS bs) (parserToIteratee get)+  runIdentity $ I.run $ I.joinIM $ I.enumPure1Chunk (toBS bs) getI  -- TODO: tryUnpack @@ -79,6 +84,10 @@ packToHandle :: Handle -> Put -> IO () packToHandle h = L.hPutStr h . packToString +-- | Pack to Handle and Flush Handle+packToHandle' :: Handle -> Put -> IO ()+packToHandle' h p = packToHandle h p >> hFlush h+ -- | Pack to File packToFile :: FilePath -> Put -> IO () packToFile path = L.writeFile path . packToString@@ -86,32 +95,32 @@ -- | 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+  unpackFromStringI 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+  unpackFromHandleI h .parserToIteratee  -- | Unpack from File unpackFromFile :: CIO.MonadCatchIO m => FilePath -> A.Parser a -> m a-unpackFromFile path p =+unpackFromFile path =+  unpackFromFileI path . parserToIteratee++-- | Iteratee interface to unpack from ByteString+unpackFromStringI :: (Monad m, IsByteString s) => s -> I.Iteratee B.ByteString m a -> m a+unpackFromStringI bs =+  I.run . I.joinIM . I.enumPure1Chunk (toBS bs)++-- | Iteratee interface to unpack from Handle+unpackFromHandleI :: CIO.MonadCatchIO m => Handle -> I.Iteratee B.ByteString m a -> m a+unpackFromHandleI h =+  I.run . I.joinIM . enumHandleNonBlocking bufferSize h++-- | Iteratee interface to unpack from File+unpackFromFileI :: CIO.MonadCatchIO m => FilePath -> I.Iteratee B.ByteString m a -> m a+unpackFromFileI 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)+  (flip unpackFromHandleI p)

@@ -0,0 +1,82 @@+--------------------------------------------------------------------+-- |+-- Module    : Data.MessagePack.Iteratee+-- Copyright : (c) Hideyuki Tanaka, 2009-2010+-- License   : BSD3+--+-- Maintainer:  tanaka.hideyuki@gmail.com+-- Stability :  experimental+-- Portability: portable+--+-- MessagePack Deserializer interface to @Data.Iteratee@+--+--------------------------------------------------------------------++module Data.MessagePack.Iteratee(+  -- * Iteratee version of deserializer+  getI,+  -- * Non Blocking Enumerator+  enumHandleNonBlocking,+  -- * Convert Parser to Iteratee+  parserToIteratee,+  ) where++import Control.Exception+import Control.Monad.IO.Class+import qualified Data.Attoparsec as A+import qualified Data.ByteString as B+import qualified Data.Iteratee as I+import System.IO++import Data.MessagePack.Parser++-- | Deserialize a value+getI :: (Monad m, ObjectGet a) => I.Iteratee B.ByteString m a+getI = parserToIteratee get++-- | Enumerator+enumHandleNonBlocking :: MonadIO m => Int -> Handle -> I.Enumerator B.ByteString m a+enumHandleNonBlocking bufSize h =+  I.enumFromCallback $ readSome bufSize h++readSome :: MonadIO m => Int -> Handle -> m (Either SomeException (Bool, B.ByteString))+readSome bufSize h = liftIO $ do+  ebs <- try $ hGetSome bufSize h+  case ebs of+    Left exc ->+      return $ Left (exc :: SomeException)+    Right bs | B.null bs ->+      return $ Right (False, B.empty)+    Right bs ->+      return $ Right (True, bs)++hGetSome :: Int -> Handle -> IO B.ByteString+hGetSome bufSize h = do+  bs <- B.hGetNonBlocking h bufSize+  if B.null bs+    then do+    hd <- B.hGet h 1+    if B.null hd+      then do+      return B.empty+      else do+      rest <- B.hGetNonBlocking h (bufSize - 1)+      return $ B.cons (B.head hd) rest+    else do+    return bs++-- | Convert Parser to Iteratee+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,5 +1,7 @@-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}+{-# Language TypeSynonymInstances #-}+{-# Language FlexibleInstances #-}+{-# Language OverlappingInstances #-}+{-# Language DeriveDataTypeable #-}  -------------------------------------------------------------------- -- |@@ -24,10 +26,12 @@   Result,   ) where +import Control.DeepSeq import Control.Monad import Control.Monad.Trans.Error () import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as C8+import Data.Typeable  -- | Object Representation of MessagePack data. data Object =@@ -38,7 +42,18 @@   | ObjectRAW B.ByteString   | ObjectArray [Object]   | ObjectMap [(Object, Object)]-  deriving (Show)+  deriving (Show, Eq, Ord, Typeable)++instance NFData Object where+  rnf obj =+    case obj of+      ObjectNil -> ()+      ObjectBool b -> rnf b+      ObjectInteger n -> rnf n+      ObjectDouble d -> rnf d+      ObjectRAW bs -> bs `seq` ()+      ObjectArray a -> rnf a+      ObjectMap m -> rnf m  -- | The class of types serializable to and from MessagePack object class OBJECT a where

@@ -1,6 +1,7 @@ {-# Language FlexibleInstances #-} {-# Language IncoherentInstances #-} {-# Language OverlappingInstances #-}+{-# Language TypeSynonymInstances #-}  -------------------------------------------------------------------- -- |@@ -27,6 +28,7 @@ import Data.Binary.IEEE754 import Data.Bits import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as L import Data.Int import qualified Data.Vector as V@@ -40,172 +42,181 @@   -- | Deserialize a value   get :: A.Parser a +instance ObjectGet Object where+  get =+    A.choice+    [ liftM ObjectInteger get+    , liftM (\() -> ObjectNil) get+    , liftM ObjectBool get+    , liftM ObjectDouble get+    , liftM ObjectRAW get+    , liftM ObjectArray get+    , liftM ObjectMap get+    ]+ instance ObjectGet Int where-  get = parseInt+  get = do+    c <- A.anyWord8+    case c of+      _ | c .&. 0x80 == 0x00 ->+        return $ fromIntegral c+      _ | c .&. 0xE0 == 0xE0 ->+        return $ fromIntegral (fromIntegral c :: Int8)+      0xCC ->+        return . fromIntegral =<< A.anyWord8+      0xCD ->+        return . fromIntegral =<< parseUint16+      0xCE ->+        return . fromIntegral =<< parseUint32+      0xCF ->+        return . fromIntegral =<< parseUint64+      0xD0 ->+        return . fromIntegral =<< parseInt8+      0xD1 ->+        return . fromIntegral =<< parseInt16+      0xD2 ->+        return . fromIntegral =<< parseInt32+      0xD3 ->+        return . fromIntegral =<< parseInt64+      _ ->+        fail $ printf "invlid integer tag: 0x%02X" c  instance ObjectGet () where-  get = parseNil+  get = do+    c <- A.anyWord8+    case c of+      0xC0 ->+        return ()+      _ ->+        fail $ printf "invlid nil tag: 0x%02X" c  instance ObjectGet Bool where-  get = parseBool+  get = do+    c <- A.anyWord8+    case c of+      0xC3 ->+        return True+      0xC2 ->+        return False+      _ ->+        fail $ printf "invlid bool tag: 0x%02X" c  instance ObjectGet Double where-  get = parseDouble+  get = do+    c <- A.anyWord8+    case c of+      0xCA ->+        return . realToFrac . runGet getFloat32be . toLBS =<< A.take 4+      0xCB ->+        return . runGet getFloat64be . toLBS =<< A.take 8+      _ ->+        fail $ printf "invlid double tag: 0x%02X" c +instance ObjectGet String where+  get = parseString (\n -> return . B8.unpack =<< A.take n)+ instance ObjectGet B.ByteString where-  get = parseRAW+  get = parseString A.take +instance ObjectGet L.ByteString where+  get = parseString (\n -> do bs <- A.take n; return $ L.fromChunks [bs])++parseString :: (Int -> A.Parser a) -> A.Parser a+parseString aget = do+  c <- A.anyWord8+  case c of+    _ | c .&. 0xE0 == 0xA0 ->+      aget . fromIntegral $ c .&. 0x1F+    0xDA ->+      aget . fromIntegral =<< parseUint16+    0xDB ->+      aget . fromIntegral =<< parseUint32+    _ ->+      fail $ printf "invlid raw tag: 0x%02X" c+ instance ObjectGet a => ObjectGet [a] where-  get = parseArray+  get = parseArray (flip replicateM get)  instance ObjectGet a => ObjectGet (V.Vector a) where-  get = parseArrayVector+  get = parseArray (flip V.replicateM get) -instance (ObjectGet k, ObjectGet v) => ObjectGet [(k, v)] where-  get = parseMap+instance (ObjectGet a1, ObjectGet a2) => ObjectGet (a1, a2) where+  get = parseArray f where+    f 2 = get >>= \a1 -> get >>= \a2 -> return (a1, a2)+    f n = fail $ printf "wrong tupple size: expected 2 but got " n -instance (ObjectGet k, ObjectGet v) => ObjectGet (V.Vector (k, v)) where-  get = parseMapVector+instance (ObjectGet a1, ObjectGet a2, ObjectGet a3) => ObjectGet (a1, a2, a3) where+  get = parseArray f where+    f 3 = get >>= \a1 -> get >>= \a2 -> get >>= \a3 -> return (a1, a2, a3)+    f n = fail $ printf "wrong tupple size: expected 3 but got " n -instance ObjectGet Object where-  get = parseObject+instance (ObjectGet a1, ObjectGet a2, ObjectGet a3, ObjectGet a4) => ObjectGet (a1, a2, a3, a4) where+  get = parseArray f where+    f 4 = get >>= \a1 -> get >>= \a2 -> get >>= \a3 -> get >>= \a4 -> return (a1, a2, a3, a4)+    f n = fail $ printf "wrong tupple size: expected 4 but got " n -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+instance (ObjectGet a1, ObjectGet a2, ObjectGet a3, ObjectGet a4, ObjectGet a5) => ObjectGet (a1, a2, a3, a4, a5) where+  get = parseArray f where+    f 5 = get >>= \a1 -> get >>= \a2 -> get >>= \a3 -> get >>= \a4 -> get >>= \a5 -> return (a1, a2, a3, a4, a5)+    f n = fail $ printf "wrong tupple size: expected 5 but got " n -parseNil :: A.Parser ()-parseNil = do-  _ <- A.word8 0xC0-  return ()+instance (ObjectGet a1, ObjectGet a2, ObjectGet a3, ObjectGet a4, ObjectGet a5, ObjectGet a6) => ObjectGet (a1, a2, a3, a4, a5, a6) where+  get = parseArray f where+    f 6 = get >>= \a1 -> get >>= \a2 -> get >>= \a3 -> get >>= \a4 -> get >>= \a5 -> get >>= \a6 -> return (a1, a2, a3, a4, a5, a6)+    f n = fail $ printf "wrong tupple size: expected 6 but got " n -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+instance (ObjectGet a1, ObjectGet a2, ObjectGet a3, ObjectGet a4, ObjectGet a5, ObjectGet a6, ObjectGet a7) => ObjectGet (a1, a2, a3, a4, a5, a6, a7) where+  get = parseArray f where+    f 7 = get >>= \a1 -> get >>= \a2 -> get >>= \a3 -> get >>= \a4 -> get >>= \a5 -> get >>= \a6 -> get >>= \a7 -> return (a1, a2, a3, a4, a5, a6, a7)+    f n = fail $ printf "wrong tupple size: expected 7 but got " n -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+instance (ObjectGet a1, ObjectGet a2, ObjectGet a3, ObjectGet a4, ObjectGet a5, ObjectGet a6, ObjectGet a7, ObjectGet a8) => ObjectGet (a1, a2, a3, a4, a5, a6, a7, a8) where+  get = parseArray f where+    f 8 = get >>= \a1 -> get >>= \a2 -> get >>= \a3 -> get >>= \a4 -> get >>= \a5 -> get >>= \a6 -> get >>= \a7 -> get >>= \a8 -> return (a1, a2, a3, a4, a5, a6, a7, a8)+    f n = fail $ printf "wrong tupple size: expected 8 but got " n -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+instance (ObjectGet a1, ObjectGet a2, ObjectGet a3, ObjectGet a4, ObjectGet a5, ObjectGet a6, ObjectGet a7, ObjectGet a8, ObjectGet a9) => ObjectGet (a1, a2, a3, a4, a5, a6, a7, a8, a9) where+  get = parseArray f where+    f 9 = get >>= \a1 -> get >>= \a2 -> get >>= \a3 -> get >>= \a4 -> get >>= \a5 -> get >>= \a6 -> get >>= \a7 -> get >>= \a8 -> get >>= \a9 -> return (a1, a2, a3, a4, a5, a6, a7, a8, a9)+    f n = fail $ printf "wrong tupple size: expected 9 but got " n -parseArrayVector :: ObjectGet a => A.Parser (V.Vector a)-parseArrayVector = do+parseArray :: (Int -> A.Parser a) -> A.Parser a+parseArray aget = do   c <- A.anyWord8   case c of     _ | c .&. 0xF0 == 0x90 ->-      flip V.replicateM get . fromIntegral $ c .&. 0x0F+      aget . fromIntegral $ c .&. 0x0F     0xDC ->-      flip V.replicateM get . fromIntegral =<< parseUint16+      aget . fromIntegral =<< parseUint16     0xDD ->-      flip V.replicateM get . fromIntegral =<< parseUint32+      aget . 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+instance (ObjectGet k, ObjectGet v) => ObjectGet [(k, v)] where+  get = parseMap (flip replicateM parsePair) -parseMapVector :: (ObjectGet k, ObjectGet v) => A.Parser (V.Vector (k, v))-parseMapVector = do+instance (ObjectGet k, ObjectGet v) => ObjectGet (V.Vector (k, v)) where+  get = parseMap (flip V.replicateM parsePair)++parsePair :: (ObjectGet k, ObjectGet v) => A.Parser (k, v)+parsePair = do+  a <- get+  b <- get+  return (a, b)++parseMap :: (Int -> A.Parser a) -> A.Parser a+parseMap aget = do   c <- A.anyWord8   case c of     _ | c .&. 0xF0 == 0x80 ->-      flip V.replicateM parsePair . fromIntegral $ c .&. 0x0F+      aget . fromIntegral $ c .&. 0x0F     0xDE ->-      flip V.replicateM parsePair . fromIntegral =<< parseUint16+      aget . fromIntegral =<< parseUint16     0xDF ->-      flip V.replicateM parsePair . fromIntegral =<< parseUint32+      aget . 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

@@ -1,6 +1,7 @@ {-# Language FlexibleInstances #-} {-# Language IncoherentInstances #-} {-# Language OverlappingInstances #-}+{-# Language TypeSynonymInstances #-}  -------------------------------------------------------------------- -- |@@ -25,6 +26,8 @@ import Data.Binary.IEEE754 import Data.Bits import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy as L import qualified Data.Vector as V  import Data.MessagePack.Object@@ -35,168 +38,159 @@   put :: a -> Put  instance ObjectPut Object where-  put = putObject+  put obj =+    case obj of+      ObjectInteger n ->+        put n+      ObjectNil ->+        put ()+      ObjectBool b ->+        put b+      ObjectDouble d ->+        put d+      ObjectRAW raw ->+        put raw+      ObjectArray arr ->+        put arr+      ObjectMap m ->+        put m  instance ObjectPut Int where-  put = putInteger+  put n =+    case n of+      _ | n >= 0 && n <= 127 ->+        putWord8 $ fromIntegral n+      _ | n >= -32 && n <= -1 ->+        putWord8 $ fromIntegral n+      _ | n >= 0 && n < 0x100 -> do+        putWord8 0xCC+        putWord8 $ fromIntegral n+      _ | n >= 0 && n < 0x10000 -> do+        putWord8 0xCD+        putWord16be $ fromIntegral n+      _ | n >= 0 && n < 0x100000000 -> do+        putWord8 0xCE+        putWord32be $ fromIntegral n+      _ | n >= 0 -> do+        putWord8 0xCF+        putWord64be $ fromIntegral n+      _ | n >= -0x80 -> do+        putWord8 0xD0+        putWord8 $ fromIntegral n+      _ | n >= -0x8000 -> do+        putWord8 0xD1+        putWord16be $ fromIntegral n+      _ | n >= -0x80000000 -> do+        putWord8 0xD2+        putWord32be $ fromIntegral n+      _ -> do+        putWord8 0xD3+        putWord64be $ fromIntegral n  instance ObjectPut () where-  put _ = putNil+  put _ = +    putWord8 0xC0  instance ObjectPut Bool where-  put = putBool+  put True = putWord8 0xC3+  put False = putWord8 0xC2  instance ObjectPut Double where-  put = putDouble+  put d = do+    putWord8 0xCB+    putFloat64be d +instance ObjectPut String where+  put = putString length (putByteString . B8.pack)+ instance ObjectPut B.ByteString where-  put = putRAW+  put = putString B.length putByteString +instance ObjectPut L.ByteString where+  put = putString (fromIntegral . L.length) putLazyByteString++putString :: (s -> Int) -> (s -> Put) -> s -> Put+putString lf pf str = do+  case lf str of+    len | len <= 31 -> do+      putWord8 $ 0xA0 .|. fromIntegral len+    len | len < 0x10000 -> do+      putWord8 0xDA+      putWord16be $ fromIntegral len+    len -> do+      putWord8 0xDB+      putWord32be $ fromIntegral len+  pf str+ instance ObjectPut a => ObjectPut [a] where-  put = putArray+  put = putArray length (mapM_ put)  instance ObjectPut a => ObjectPut (V.Vector a) where-  put = putArrayVector+  put = putArray V.length (V.mapM_ put) -instance (ObjectPut k, ObjectPut v) => ObjectPut [(k, v)] where-  put = putMap+instance (ObjectPut a1, ObjectPut a2) => ObjectPut (a1, a2) where+  put = putArray (const 2) f where+    f (a1, a2) = put a1 >> put a2 -instance (ObjectPut k, ObjectPut v) => ObjectPut (V.Vector (k, v)) where-  put = putMapVector+instance (ObjectPut a1, ObjectPut a2, ObjectPut a3) => ObjectPut (a1, a2, a3) where+  put = putArray (const 3) f where+    f (a1, a2, a3) = put a1 >> put a2 >> put a3 -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+instance (ObjectPut a1, ObjectPut a2, ObjectPut a3, ObjectPut a4) => ObjectPut (a1, a2, a3, a4) where+  put = putArray (const 4) f where+    f (a1, a2, a3, a4) = put a1 >> put a2 >> put a3 >> put a4 -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+instance (ObjectPut a1, ObjectPut a2, ObjectPut a3, ObjectPut a4, ObjectPut a5) => ObjectPut (a1, a2, a3, a4, a5) where+  put = putArray (const 5) f where+    f (a1, a2, a3, a4, a5) = put a1 >> put a2 >> put a3 >> put a4 >> put a5 -putNil :: Put-putNil = putWord8 0xC0+instance (ObjectPut a1, ObjectPut a2, ObjectPut a3, ObjectPut a4, ObjectPut a5, ObjectPut a6) => ObjectPut (a1, a2, a3, a4, a5, a6) where+  put = putArray (const 6) f where+    f (a1, a2, a3, a4, a5, a6) = put a1 >> put a2 >> put a3 >> put a4 >> put a5 >> put a6 -putBool :: Bool -> Put-putBool True = putWord8 0xC3-putBool False = putWord8 0xC2+instance (ObjectPut a1, ObjectPut a2, ObjectPut a3, ObjectPut a4, ObjectPut a5, ObjectPut a6, ObjectPut a7) => ObjectPut (a1, a2, a3, a4, a5, a6, a7) where+  put = putArray (const 7) f where+    f (a1, a2, a3, a4, a5, a6, a7) = put a1 >> put a2 >> put a3 >> put a4 >> put a5 >> put a6 >> put a7 -putDouble :: Double -> Put-putDouble d = do-  putWord8 0xCB-  putFloat64be d+instance (ObjectPut a1, ObjectPut a2, ObjectPut a3, ObjectPut a4, ObjectPut a5, ObjectPut a6, ObjectPut a7, ObjectPut a8) => ObjectPut (a1, a2, a3, a4, a5, a6, a7, a8) where+  put = putArray (const 8) f where+    f (a1, a2, a3, a4, a5, a6, a7, a8) = put a1 >> put a2 >> put a3 >> put a4 >> put a5 >> put a6 >> put a7 >> put a8 -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+instance (ObjectPut a1, ObjectPut a2, ObjectPut a3, ObjectPut a4, ObjectPut a5, ObjectPut a6, ObjectPut a7, ObjectPut a8, ObjectPut a9) => ObjectPut (a1, a2, a3, a4, a5, a6, a7, a8, a9) where+  put = putArray (const 9) f where+    f (a1, a2, a3, a4, a5, a6, a7, a8, a9) = put a1 >> put a2 >> put a3 >> put a4 >> put a5 >> put a6 >> put a7 >> put a8 >> put a9 -putArray :: ObjectPut a => [a] -> Put-putArray arr = do-  case len of-    _ | len <= 15 ->+putArray :: (a -> Int) -> (a -> Put) -> a -> Put+putArray lf pf arr = do+  case lf arr of+    len | len <= 15 ->       putWord8 $ 0x90 .|. fromIntegral len-    _ | len < 0x10000 -> do+    len | len < 0x10000 -> do       putWord8 0xDC       putWord16be $ fromIntegral len-    _ -> do+    len -> do       putWord8 0xDD       putWord32be $ fromIntegral len-  mapM_ put arr-  where-    len = length arr+  pf 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+instance (ObjectPut k, ObjectPut v) => ObjectPut [(k, v)] where+  put = putMap length (mapM_ putPair) -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+instance (ObjectPut k, ObjectPut v) => ObjectPut (V.Vector (k, v)) where+  put = putMap V.length (V.mapM_ putPair) -putMapVector :: (ObjectPut k, ObjectPut v) => V.Vector (k, v) -> Put-putMapVector m = do-  case len of-    _ | len <= 15 ->+putPair :: (ObjectPut a, ObjectPut b) => (a, b) -> Put+putPair (a, b) = put a >> put b++putMap :: (a -> Int) -> (a -> Put) -> a -> Put+putMap lf pf m = do+  case lf m of+    len | len <= 15 ->       putWord8 $ 0x80 .|. fromIntegral len-    _ | len < 0x10000 -> do+    len | len < 0x10000 -> do       putWord8 0xDE       putWord16be $ fromIntegral len-    _ -> do+    len -> do       putWord8 0xDF       putWord32be $ fromIntegral len-  V.mapM_ (\(k, v) -> put k >> put v) m-  where-    len = V.length m+  pf m