msgpack 0.4.0.1 → 0.5.0.0
raw patch · 8 files changed
+98/−33 lines, 8 filesdep ~attoparsecdep ~iterateedep ~template-haskell
Dependency ranges changed: attoparsec, iteratee, template-haskell, transformers, vector
Files
- msgpack.cabal +7/−6
- src/Data/MessagePack.hs +2/−0
- src/Data/MessagePack/Assoc.hs +28/−0
- src/Data/MessagePack/Iteratee.hs +5/−5
- src/Data/MessagePack/Object.hs +19/−6
- src/Data/MessagePack/Pack.hs +12/−5
- src/Data/MessagePack/Unpack.hs +15/−7
- test/Test.hs +10/−4
msgpack.cabal view
@@ -1,5 +1,5 @@ Name: msgpack-Version: 0.4.0.1+Version: 0.5.0.0 Synopsis: A Haskell binding to MessagePack Description: A Haskell binding to MessagePack <http://msgpack.org/>@@ -21,22 +21,23 @@ Library Build-depends: base >=4 && <5,- transformers >= 0.2.1 && < 0.2.2,+ transformers >= 0.2 && < 0.3, 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,+ vector >= 0.7 && < 0.8,+ iteratee >= 0.8 && < 0.9,+ attoparsec >= 0.8 && < 0.9, binary >= 0.5.0 && < 0.5.1, data-binary-ieee754 >= 0.4 && < 0.5, deepseq >= 1.1 && <1.2,- template-haskell >= 2.4 && < 2.5+ template-haskell >= 2.5 && < 2.6 Ghc-options: -Wall Hs-source-dirs: src Exposed-modules: Data.MessagePack+ Data.MessagePack.Assoc Data.MessagePack.Pack Data.MessagePack.Unpack Data.MessagePack.Object
src/Data/MessagePack.hs view
@@ -13,6 +13,7 @@ -------------------------------------------------------------------- module Data.MessagePack(+ module Data.MessagePack.Assoc, module Data.MessagePack.Pack, module Data.MessagePack.Unpack, module Data.MessagePack.Object,@@ -44,6 +45,7 @@ import qualified Data.Iteratee as I import System.IO +import Data.MessagePack.Assoc import Data.MessagePack.Pack import Data.MessagePack.Unpack import Data.MessagePack.Object
+ src/Data/MessagePack/Assoc.hs view
@@ -0,0 +1,28 @@+{-# Language DeriveDataTypeable #-}+{-# Language GeneralizedNewtypeDeriving #-}++--------------------------------------------------------------------+-- |+-- Module : Data.MessagePack.Assoc+-- Copyright : (c) Daiki Handa, 2010+-- License : BSD3+--+-- Maintainer: tanaka.hideyuki@gmail.com+-- Stability : experimental+-- Portability: portable+--+-- MessagePack map labeling type+--+--------------------------------------------------------------------++module Data.MessagePack.Assoc (+ Assoc(..)+ ) where++import Control.DeepSeq+import Data.Typeable++-- not defined for general Functor for performance reason.+-- (ie. you would want to write custom instances for each type using specialized mapM-like functions)+newtype Assoc a=Assoc{unAssoc :: a} deriving(Show,Eq,Ord,Typeable,NFData)+
src/Data/MessagePack/Iteratee.hs view
@@ -37,18 +37,18 @@ -- | Enumerator enumHandleNonBlocking :: MonadIO m => Int -> Handle -> I.Enumerator B.ByteString m a enumHandleNonBlocking bufSize h =- I.enumFromCallback $ readSome bufSize h+ I.enumFromCallback (readSome bufSize h) () -readSome :: MonadIO m => Int -> Handle -> m (Either SomeException (Bool, B.ByteString))-readSome bufSize h = liftIO $ do+readSome :: MonadIO m => Int -> Handle -> st -> m (Either SomeException ((Bool, st), B.ByteString))+readSome bufSize h st = 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)+ return $ Right ((False, st), B.empty) Right bs ->- return $ Right (True, bs)+ return $ Right ((True, st), bs) hGetSome :: Int -> Handle -> IO B.ByteString hGetSome bufSize h = do
src/Data/MessagePack/Object.hs view
@@ -1,6 +1,5 @@ {-# Language TypeSynonymInstances #-} {-# Language FlexibleInstances #-}-{-# Language OverlappingInstances #-} {-# Language IncoherentInstances #-} {-# Language DeriveDataTypeable #-} @@ -36,19 +35,22 @@ import qualified Data.ByteString.Char8 as C8 import Data.Typeable +import Data.MessagePack.Assoc import Data.MessagePack.Pack import Data.MessagePack.Unpack -- | Object Representation of MessagePack data.-data Object =- ObjectNil+data Object+ = ObjectNil | ObjectBool Bool | ObjectInteger Int+ | ObjectFloat Float | ObjectDouble Double | ObjectRAW B.ByteString | ObjectArray [Object] | ObjectMap [(Object, Object)] deriving (Show, Eq, Ord, Typeable)+ instance NFData Object where rnf obj =@@ -56,17 +58,20 @@ ObjectNil -> () ObjectBool b -> rnf b ObjectInteger n -> rnf n+ ObjectFloat f -> rnf f ObjectDouble d -> rnf d ObjectRAW bs -> bs `seq` () ObjectArray a -> rnf a ObjectMap m -> rnf m + instance Unpackable Object where get = A.choice [ liftM ObjectInteger get , liftM (\() -> ObjectNil) get , liftM ObjectBool get+ , liftM ObjectFloat get , liftM ObjectDouble get , liftM ObjectRAW get , liftM ObjectArray get@@ -82,6 +87,8 @@ put () ObjectBool b -> put b+ ObjectFloat f ->+ put f ObjectDouble d -> put d ObjectRAW raw ->@@ -137,6 +144,11 @@ tryFromObject (ObjectDouble d) = Right d tryFromObject _ = tryFromObjectError +instance OBJECT Float where+ toObject = ObjectFloat+ tryFromObject (ObjectFloat f) = Right f+ tryFromObject _ = tryFromObjectError+ instance OBJECT B.ByteString where toObject = ObjectRAW tryFromObject (ObjectRAW bs) = Right bs@@ -285,11 +297,11 @@ tryFromObject _ = tryFromObjectError -instance (OBJECT a, OBJECT b) => OBJECT [(a, b)] where+instance (OBJECT a, OBJECT b) => OBJECT (Assoc [(a,b)]) where toObject =- ObjectMap . map (\(a, b) -> (toObject a, toObject b))+ ObjectMap . map (\(a, b) -> (toObject a, toObject b)) . unAssoc tryFromObject (ObjectMap mem) = do- mapM (\(a, b) -> liftM2 (,) (tryFromObject a) (tryFromObject b)) mem+ liftM Assoc $ mapM (\(a, b) -> liftM2 (,) (tryFromObject a) (tryFromObject b)) mem tryFromObject _ = tryFromObjectError @@ -299,3 +311,4 @@ tryFromObject ObjectNil = return Nothing tryFromObject obj = liftM Just $ tryFromObject obj+
src/Data/MessagePack/Pack.hs view
@@ -1,6 +1,5 @@ {-# Language FlexibleInstances #-} {-# Language IncoherentInstances #-}-{-# Language OverlappingInstances #-} {-# Language TypeSynonymInstances #-} --------------------------------------------------------------------@@ -32,6 +31,8 @@ import qualified Data.ByteString.Lazy as L import qualified Data.Vector as V +import Data.MessagePack.Assoc+ -- | Serializable class class Packable a where -- | Serialize a value@@ -81,6 +82,11 @@ put True = putWord8 0xC3 put False = putWord8 0xC2 +instance Packable Float where+ put f = do+ putWord8 0xCA+ putFloat32be f+ instance Packable Double where put d = do putWord8 0xCB@@ -159,11 +165,11 @@ putWord32be $ fromIntegral len pf arr -instance (Packable k, Packable v) => Packable [(k, v)] where- put = putMap length (mapM_ putPair)+instance (Packable k, Packable v) => Packable (Assoc [(k,v)]) where+ put = putMap length (mapM_ putPair) . unAssoc -instance (Packable k, Packable v) => Packable (V.Vector (k, v)) where- put = putMap V.length (V.mapM_ putPair)+instance (Packable k, Packable v) => Packable (Assoc (V.Vector (k,v))) where+ put = putMap V.length (V.mapM_ putPair) . unAssoc putPair :: (Packable a, Packable b) => (a, b) -> Put putPair (a, b) = put a >> put b@@ -184,3 +190,4 @@ instance Packable a => Packable (Maybe a) where put Nothing = put () put (Just a) = put a+
src/Data/MessagePack/Unpack.hs view
@@ -1,6 +1,5 @@ {-# Language FlexibleInstances #-} {-# Language IncoherentInstances #-}-{-# Language OverlappingInstances #-} {-# Language TypeSynonymInstances #-} {-# Language DeriveDataTypeable #-} @@ -45,6 +44,8 @@ import Data.Word import Text.Printf +import Data.MessagePack.Assoc+ -- | Deserializable class class Unpackable a where -- | Deserialize a value@@ -133,12 +134,19 @@ _ -> fail $ printf "invlid bool tag: 0x%02X" c -instance Unpackable Double where+instance Unpackable Float where get = do c <- A.anyWord8 case c of 0xCA ->- return . realToFrac . runGet getFloat32be . toLBS =<< A.take 4+ return . runGet getFloat32be . toLBS =<< A.take 4+ _ ->+ fail $ printf "invlid float tag: 0x%02X" c++instance Unpackable Double where+ get = do+ c <- A.anyWord8+ case c of 0xCB -> return . runGet getFloat64be . toLBS =<< A.take 8 _ ->@@ -225,11 +233,11 @@ _ -> fail $ printf "invlid array tag: 0x%02X" c -instance (Unpackable k, Unpackable v) => Unpackable [(k, v)] where- get = parseMap (flip replicateM parsePair)+instance (Unpackable k, Unpackable v) => Unpackable (Assoc [(k,v)]) where+ get = liftM Assoc $ parseMap (flip replicateM parsePair) -instance (Unpackable k, Unpackable v) => Unpackable (V.Vector (k, v)) where- get = parseMap (flip V.replicateM parsePair)+instance (Unpackable k, Unpackable v) => Unpackable (Assoc (V.Vector (k, v))) where+ get = liftM Assoc $ parseMap (flip V.replicateM parsePair) parsePair :: (Unpackable k, Unpackable v) => A.Parser (k, v) parsePair = do
test/Test.hs view
@@ -7,6 +7,9 @@ import qualified Data.ByteString.Lazy.Char8 as L import Data.MessagePack +instance Arbitrary a => Arbitrary (Assoc a) where+ arbitrary = liftM Assoc arbitrary+ mid :: (Packable a, Unpackable a) => a -> a mid = unpack . pack @@ -36,10 +39,12 @@ where types = a :: (Int, Int, Int, Int) prop_mid_pair5 a = a == mid a where types = a :: (Int, Int, Int, Int, Int)-prop_mid_map_int_double a = a == mid a+prop_mid_list_int_double a = a == mid a where types = a :: [(Int, Double)]-prop_mid_map_string_string a = a == mid a+prop_mid_list_string_string a = a == mid a where types = a :: [(String, String)]+prop_mid_map_string_int a = a == mid a+ where types = a :: Assoc [(String,Int)] tests = [ testGroup "simple"@@ -56,8 +61,9 @@ , testProperty "(int, int, int)" prop_mid_pair3 , testProperty "(int, int, int, int)" prop_mid_pair4 , testProperty "(int, int, int, int, int)" prop_mid_pair5- , testProperty "[(int, double)]" prop_mid_map_int_double- , testProperty "[(string, string)]" prop_mid_map_string_string+ , testProperty "[(int, double)]" prop_mid_list_int_double+ , testProperty "[(string, string)]" prop_mid_list_string_string+ , testProperty "Assoc [(string, int)]" prop_mid_map_string_int ] ]