haskell: add ObjectFloat to send floats, and Assoc to make map (un)packing explicit

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 <http://msgpack.org/>
@@ -37,6 +37,7 @@ Library
 
   Exposed-modules:
     Data.MessagePack
+    Data.MessagePack.Assoc
     Data.MessagePack.Pack
     Data.MessagePack.Unpack
     Data.MessagePack.Object

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

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

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 =
+data Object
-  ObjectNil
+  = 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
+

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
+instance (Packable k, Packable v) => Packable (Assoc [(k,v)]) where
-  put = putMap length (mapM_ putPair)
+  put = putMap length (mapM_ putPair) . unAssoc
 
-instance (Packable k, Packable v) => Packable (V.Vector (k, v)) where
+instance (Packable k, Packable v) => Packable (Assoc (V.Vector (k,v))) where
-  put = putMap V.length (V.mapM_ putPair)
+  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
+

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
+instance (Unpackable k, Unpackable v) => Unpackable (Assoc [(k,v)]) where
-  get = parseMap (flip replicateM parsePair)
+  get = liftM Assoc $ parseMap (flip replicateM parsePair)
 
-instance (Unpackable k, Unpackable v) => Unpackable (V.Vector (k, v)) where
+instance (Unpackable k, Unpackable v) => Unpackable (Assoc (V.Vector (k, v))) where
-  get = parseMap (flip V.replicateM parsePair)
+  get = liftM Assoc $ parseMap (flip V.replicateM parsePair)
 
 parsePair :: (Unpackable k, Unpackable v) => A.Parser (k, v)
 parsePair = do

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 "[(int, double)]" prop_mid_list_int_double
-    , testProperty "[(string, string)]" prop_mid_map_string_string
+    , testProperty "[(string, string)]" prop_mid_list_string_string
+    , testProperty "Assoc [(string, int)]" prop_mid_map_string_int
     ]
   ]