mirror of
https://github.com/msgpack/msgpack-c.git
synced 2025-03-19 04:52:59 +01:00
haskell: instance tupples and String and lazy ByteString
This commit is contained in:
tanakh
parent
aca2ba13c2
commit
9e50ba6ec6
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
]
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user