diff --git a/msgpack.cabal b/msgpack.cabal --- a/msgpack.cabal +++ b/msgpack.cabal @@ -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 @@ -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 diff --git a/src/Data/MessagePack.hs b/src/Data/MessagePack.hs --- a/src/Data/MessagePack.hs +++ b/src/Data/MessagePack.hs @@ -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 diff --git a/src/Data/MessagePack/Assoc.hs b/src/Data/MessagePack/Assoc.hs new file mode 100644 --- /dev/null +++ b/src/Data/MessagePack/Assoc.hs @@ -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) + diff --git a/src/Data/MessagePack/Iteratee.hs b/src/Data/MessagePack/Iteratee.hs --- a/src/Data/MessagePack/Iteratee.hs +++ b/src/Data/MessagePack/Iteratee.hs @@ -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 diff --git a/src/Data/MessagePack/Object.hs b/src/Data/MessagePack/Object.hs --- a/src/Data/MessagePack/Object.hs +++ b/src/Data/MessagePack/Object.hs @@ -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 + diff --git a/src/Data/MessagePack/Pack.hs b/src/Data/MessagePack/Pack.hs --- a/src/Data/MessagePack/Pack.hs +++ b/src/Data/MessagePack/Pack.hs @@ -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 + diff --git a/src/Data/MessagePack/Unpack.hs b/src/Data/MessagePack/Unpack.hs --- a/src/Data/MessagePack/Unpack.hs +++ b/src/Data/MessagePack/Unpack.hs @@ -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 diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -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 ] ]