diff --git a/haskell/msgpack.cabal b/haskell/msgpack.cabal index 98133a9e..ef56edc6 100644 --- a/haskell/msgpack.cabal +++ b/haskell/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 @@ -37,6 +37,7 @@ Library Exposed-modules: Data.MessagePack + Data.MessagePack.Assoc Data.MessagePack.Pack Data.MessagePack.Unpack Data.MessagePack.Object diff --git a/haskell/src/Data/MessagePack.hs b/haskell/src/Data/MessagePack.hs index b71190d6..1c77ca91 100644 --- a/haskell/src/Data/MessagePack.hs +++ b/haskell/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.ByteString.Lazy as L 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/haskell/src/Data/MessagePack/Assoc.hs b/haskell/src/Data/MessagePack/Assoc.hs new file mode 100644 index 00000000..525cb77f --- /dev/null +++ b/haskell/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/haskell/src/Data/MessagePack/Object.hs b/haskell/src/Data/MessagePack/Object.hs index 5111ebb6..421b05e2 100644 --- a/haskell/src/Data/MessagePack/Object.hs +++ b/haskell/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 as B 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 @@ instance NFData Object where 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 @@ instance Packable Object where put () ObjectBool b -> put b + ObjectFloat f -> + put f ObjectDouble d -> put d ObjectRAW raw -> @@ -137,6 +144,11 @@ instance OBJECT Double where 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 @@ instance (OBJECT a1, OBJECT a2, OBJECT a3, OBJECT a4, OBJECT a5, OBJECT a6, OBJE 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 @@ instance OBJECT a => OBJECT (Maybe a) where tryFromObject ObjectNil = return Nothing tryFromObject obj = liftM Just $ tryFromObject obj + diff --git a/haskell/src/Data/MessagePack/Pack.hs b/haskell/src/Data/MessagePack/Pack.hs index 16243ad9..e943765a 100644 --- a/haskell/src/Data/MessagePack/Pack.hs +++ b/haskell/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.Char8 as B8 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 @@ instance Packable Bool where 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 @@ putArray lf pf arr = do 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 @@ putMap lf pf m = do instance Packable a => Packable (Maybe a) where put Nothing = put () put (Just a) = put a + diff --git a/haskell/src/Data/MessagePack/Unpack.hs b/haskell/src/Data/MessagePack/Unpack.hs index a0d618ec..20deafad 100644 --- a/haskell/src/Data/MessagePack/Unpack.hs +++ b/haskell/src/Data/MessagePack/Unpack.hs @@ -1,6 +1,5 @@ {-# Language FlexibleInstances #-} {-# Language IncoherentInstances #-} -{-# Language OverlappingInstances #-} {-# Language TypeSynonymInstances #-} {-# Language DeriveDataTypeable #-} @@ -45,6 +44,8 @@ import qualified Data.Vector as V import Data.Word import Text.Printf +import Data.MessagePack.Assoc + -- | Deserializable class class Unpackable a where -- | Deserialize a value @@ -133,12 +134,19 @@ instance Unpackable Bool where _ -> 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 @@ parseArray aget = do _ -> 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/haskell/test/Test.hs b/haskell/test/Test.hs index 43af2efc..d3089634 100644 --- a/haskell/test/Test.hs +++ b/haskell/test/Test.hs @@ -7,6 +7,9 @@ import qualified Data.ByteString.Char8 as B 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 @@ prop_mid_pair4 a = a == mid a 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 @@ tests = , 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 ] ]