haskell: instance tupples and String and lazy ByteString

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
+  get = parseString A.take
-    c <- A.anyWord8
+
-    case c of
+instance ObjectGet L.ByteString where
-      _ | c .&. 0xE0 == 0xA0 ->
+  get = parseString (\n -> do bs <- A.take n; return $ L.fromChunks [bs])
-        A.take . fromIntegral $ c .&. 0x1F
+
-      0xDA ->
+parseString :: (Int -> A.Parser a) -> A.Parser a
-        A.take . fromIntegral =<< parseUint16
+parseString aget = do
-      0xDB ->
+  c <- A.anyWord8
-        A.take . fromIntegral =<< parseUint32
+  case c of
-      _ ->
+    _ | c .&. 0xE0 == 0xA0 ->
-        fail $ printf "invlid raw tag: 0x%02X" c
+      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

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
+  put = putString B.length putByteString
-    case len of
+
-      _ | len <= 31 -> do
+instance ObjectPut L.ByteString where
-        putWord8 $ 0xA0 .|. fromIntegral len
+  put = putString (fromIntegral . L.length) putLazyByteString
-      _ | len < 0x10000 -> do
+
-        putWord8 0xDA
+putString :: (s -> Int) -> (s -> Put) -> s -> Put
-        putWord16be $ fromIntegral len
+putString lf pf str = do
-      _ -> do
+  case lf str of
-        putWord8 0xDB
+    len | len <= 31 -> do
-        putWord32be $ fromIntegral len
+      putWord8 $ 0xA0 .|. fromIntegral len
-    putByteString bs
+    len | len < 0x10000 -> do
-    where
+      putWord8 0xDA
-      len = B.length bs
+      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

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
     ]