From 9e50ba6ec6f48071a5cc31b44864194446b9aa6f Mon Sep 17 00:00:00 2001 From: tanakh Date: Mon, 6 Sep 2010 16:33:36 +0900 Subject: [PATCH] haskell: instance tupples and String and lazy ByteString --- haskell/src/Data/MessagePack/Parser.hs | 73 ++++++++++++++++++++++---- haskell/src/Data/MessagePack/Put.hs | 68 +++++++++++++++++++----- haskell/test/Test.hs | 25 +++++++-- 3 files changed, 139 insertions(+), 27 deletions(-) diff --git a/haskell/src/Data/MessagePack/Parser.hs b/haskell/src/Data/MessagePack/Parser.hs index 312e95f3..200ad962 100644 --- a/haskell/src/Data/MessagePack/Parser.hs +++ b/haskell/src/Data/MessagePack/Parser.hs @@ -1,6 +1,7 @@ {-# Language FlexibleInstances #-} {-# Language IncoherentInstances #-} {-# Language OverlappingInstances #-} +{-# Language TypeSynonymInstances #-} -------------------------------------------------------------------- -- | @@ -27,6 +28,7 @@ import Data.Binary.Get 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 @@ -110,18 +112,27 @@ instance ObjectGet Double where _ -> 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 = 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 + 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 (flip replicateM get) @@ -129,6 +140,46 @@ instance ObjectGet a => ObjectGet [a] where instance ObjectGet a => ObjectGet (V.Vector a) where get = parseArray (flip V.replicateM get) +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 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 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 + +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 + +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 + +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 + +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 + +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 + parseArray :: (Int -> A.Parser a) -> A.Parser a parseArray aget = do c <- A.anyWord8 diff --git a/haskell/src/Data/MessagePack/Put.hs b/haskell/src/Data/MessagePack/Put.hs index 95582dd8..24ec3059 100644 --- a/haskell/src/Data/MessagePack/Put.hs +++ b/haskell/src/Data/MessagePack/Put.hs @@ -1,6 +1,7 @@ {-# Language FlexibleInstances #-} {-# Language IncoherentInstances #-} {-# Language OverlappingInstances #-} +{-# Language TypeSynonymInstances #-} -------------------------------------------------------------------- -- | @@ -25,6 +26,8 @@ import Data.Binary.Put 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 @@ -97,20 +100,27 @@ instance ObjectPut Double where putWord8 0xCB putFloat64be d +instance ObjectPut String where + put = putString length (putByteString . B8.pack) + instance ObjectPut B.ByteString where - put 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 + 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 length (mapM_ put) @@ -118,6 +128,38 @@ instance ObjectPut a => ObjectPut [a] where instance ObjectPut a => ObjectPut (V.Vector a) where put = putArray V.length (V.mapM_ put) +instance (ObjectPut a1, ObjectPut a2) => ObjectPut (a1, a2) where + put = putArray (const 2) f where + f (a1, a2) = put a1 >> put a2 + +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 + +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 + +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 + +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 + +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 + +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 + +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 :: (a -> Int) -> (a -> Put) -> a -> Put putArray lf pf arr = do case lf arr of diff --git a/haskell/test/Test.hs b/haskell/test/Test.hs index 1bb551c1..a73ac9ab 100644 --- a/haskell/test/Test.hs +++ b/haskell/test/Test.hs @@ -4,6 +4,7 @@ import Test.QuickCheck import Control.Monad import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as L import Data.MessagePack mid :: (ObjectGet a, ObjectPut a) => a -> a @@ -17,15 +18,27 @@ prop_mid_bool a = a == mid a where types = a :: Bool prop_mid_double a = a == mid a where types = a :: Double -prop_mid_string a = a == B.unpack (mid (B.pack a)) +prop_mid_string a = a == mid a + where types = a :: String +prop_mid_bytestring a = B.pack a == mid (B.pack a) + where types = a :: String +prop_mid_lazy_bytestring a = (L.pack a) == mid (L.pack a) where types = a :: String prop_mid_array_int a = a == mid a where types = a :: [Int] -prop_mid_array_string a = a == map B.unpack (mid (map B.pack a)) +prop_mid_array_string a = a == mid a where types = a :: [String] +prop_mid_pair2 a = a == mid a + where types = a :: (Int, Int) +prop_mid_pair3 a = a == mid a + where types = a :: (Int, Int, Int) +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 where types = a :: [(Int, Double)] -prop_mid_map_string_string a = a == map (\(x, y) -> (B.unpack x, B.unpack y)) (mid (map (\(x, y) -> (B.pack x, B.pack y)) a)) +prop_mid_map_string_string a = a == mid a where types = a :: [(String, String)] tests = @@ -35,8 +48,14 @@ tests = , testProperty "bool" prop_mid_bool , testProperty "double" prop_mid_double , testProperty "string" prop_mid_string + , testProperty "bytestring" prop_mid_bytestring + , testProperty "lazy-bytestring" prop_mid_lazy_bytestring , testProperty "[int]" prop_mid_array_int , testProperty "[string]" prop_mid_array_string + , testProperty "(int, int)" prop_mid_pair2 + , 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 ]