diff --git a/msgpack.cabal b/msgpack.cabal --- a/msgpack.cabal +++ b/msgpack.cabal @@ -1,5 +1,5 @@ Name: msgpack -Version: 0.3.1.1 +Version: 0.4.0 Synopsis: A Haskell binding to MessagePack Description: A Haskell binding to MessagePack @@ -15,6 +15,10 @@ Cabal-Version: >= 1.6 Build-Type: Simple +Extra-source-files: + test/Test.hs + test/UserData.hs + Library Build-depends: base >=4 && <5, transformers >= 0.2.1 && < 0.2.2, @@ -25,17 +29,19 @@ attoparsec >= 0.8.1 && < 0.8.2, binary >= 0.5.0 && < 0.5.1, data-binary-ieee754 >= 0.4 && < 0.5, - deepseq >= 1.1 && <1.2 + deepseq >= 1.1 && <1.2, + template-haskell >= 2.4 && < 2.5 Ghc-options: -Wall Hs-source-dirs: src Exposed-modules: Data.MessagePack + Data.MessagePack.Pack + Data.MessagePack.Unpack Data.MessagePack.Object - Data.MessagePack.Put - Data.MessagePack.Parser Data.MessagePack.Iteratee + Data.MessagePack.Derive Source-repository head Type: git diff --git a/src/Data/MessagePack.hs b/src/Data/MessagePack.hs --- a/src/Data/MessagePack.hs +++ b/src/Data/MessagePack.hs @@ -13,14 +13,11 @@ -------------------------------------------------------------------- module Data.MessagePack( + module Data.MessagePack.Pack, + module Data.MessagePack.Unpack, module Data.MessagePack.Object, - module Data.MessagePack.Put, - module Data.MessagePack.Parser, module Data.MessagePack.Iteratee, - - -- * Simple functions of Pack and Unpack - pack, - unpack, + module Data.MessagePack.Derive, -- * Pack functions packToString, @@ -44,37 +41,17 @@ import Data.Binary.Put import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L -import Data.Functor.Identity import qualified Data.Iteratee as I import System.IO +import Data.MessagePack.Pack +import Data.MessagePack.Unpack import Data.MessagePack.Object -import Data.MessagePack.Put -import Data.MessagePack.Parser import Data.MessagePack.Iteratee +import Data.MessagePack.Derive bufferSize :: Int bufferSize = 4 * 1024 - -class IsByteString s where - toBS :: s -> B.ByteString - -instance IsByteString B.ByteString where - toBS = id - -instance IsByteString L.ByteString where - toBS = B.concat . L.toChunks - --- | Pack Haskell data to MessagePack string. -pack :: ObjectPut a => a -> L.ByteString -pack = packToString . put - --- | Unpack MessagePack string to Haskell data. -unpack :: (ObjectGet a, IsByteString s) => s -> a -unpack bs = - runIdentity $ I.run $ I.joinIM $ I.enumPure1Chunk (toBS bs) getI - --- TODO: tryUnpack -- | Pack to ByteString. packToString :: Put -> L.ByteString diff --git a/src/Data/MessagePack/Derive.hs b/src/Data/MessagePack/Derive.hs new file mode 100644 --- /dev/null +++ b/src/Data/MessagePack/Derive.hs @@ -0,0 +1,100 @@ +{-# Language TemplateHaskell #-} + +module Data.MessagePack.Derive ( + derivePack, + deriveUnpack, + deriveObject, + ) where + +import Control.Applicative +import Language.Haskell.TH + +import Data.MessagePack.Pack +import Data.MessagePack.Unpack +import Data.MessagePack.Object + +deriveUnpack :: Name -> Q [Dec] +deriveUnpack typName = do + TyConI (DataD _ name _ cons _) <- reify typName + + return + [ InstanceD [] (AppT (ConT ''Unpackable) (ConT name)) + [ FunD 'get [Clause [] (NormalB $ ch $ map body cons) []] + ]] + + where + body (NormalC conName elms) = + DoE + [ BindS (tupOrListP $ map VarP names) (VarE 'get) + , NoBindS $ AppE (VarE 'return) $ foldl AppE (ConE conName) $ map VarE names ] + where + names = zipWith (\ix _ -> mkName $ "a" ++ show (ix :: Int)) [1..] elms + + body (RecC conName elms) = + body (NormalC conName $ map (\(_, b, c) -> (b, c)) elms) + + ch = foldl1 (\e f -> AppE (AppE (VarE '(<|>)) e) f) + +derivePack :: Name -> Q [Dec] +derivePack typName = do + TyConI (DataD _ name _ cons _) <- reify typName + + return + [ InstanceD [] (AppT (ConT ''Packable) (ConT name)) + [ FunD 'put (map body cons) + ]] + + where + body (NormalC conName elms) = + Clause + [ ConP conName $ map VarP names ] + (NormalB $ AppE (VarE 'put) $ tupOrListE $ map VarE names) [] + where + names = zipWith (\ix _ -> mkName $ "a" ++ show (ix :: Int)) [1..] elms + + body (RecC conName elms) = + body (NormalC conName $ map (\(_, b, c) -> (b, c)) elms) + +deriveObject :: Name -> Q [Dec] +deriveObject typName = do + g <- derivePack typName + p <- deriveUnpack typName + + TyConI (DataD _ name _ cons _) <- reify typName + let o = InstanceD [] (AppT (ConT ''OBJECT) (ConT name)) + [ FunD 'toObject (map toObjectBody cons), + FunD 'tryFromObject [Clause [ VarP oname ] + (NormalB $ ch $ map tryFromObjectBody cons) []]] + + return $ g ++ p ++ [o] + where + toObjectBody (NormalC conName elms) = + Clause + [ ConP conName $ map VarP names ] + (NormalB $ AppE (VarE 'toObject) $ tupOrListE $ map VarE names) [] + where + names = zipWith (\ix _ -> mkName $ "a" ++ show (ix :: Int)) [1..] elms + toObjectBody (RecC conName elms) = + toObjectBody (NormalC conName $ map (\(_, b, c) -> (b, c)) elms) + + tryFromObjectBody (NormalC conName elms) = + DoE + [ BindS (tupOrListP $ map VarP names) (AppE (VarE 'tryFromObject) (VarE oname)) + , NoBindS $ AppE (VarE 'return) $ foldl AppE (ConE conName) $ map VarE names ] + where + names = zipWith (\ix _ -> mkName $ "a" ++ show (ix :: Int)) [1..] elms + tryFromObjectBody (RecC conName elms) = + tryFromObjectBody (NormalC conName $ map (\(_, b, c) -> (b, c)) elms) + + oname = mkName "o" + ch = foldl1 (\e f -> AppE (AppE (VarE '(<|>)) e) f) + +tupOrListP :: [Pat] -> Pat +tupOrListP ls + | length ls <= 1 = ListP ls + | otherwise = TupP ls + +tupOrListE :: [Exp] -> Exp +tupOrListE ls + | length ls <= 1 = ListE ls + | otherwise = TupE ls diff --git a/src/Data/MessagePack/Iteratee.hs b/src/Data/MessagePack/Iteratee.hs --- a/src/Data/MessagePack/Iteratee.hs +++ b/src/Data/MessagePack/Iteratee.hs @@ -28,10 +28,10 @@ import qualified Data.Iteratee as I import System.IO -import Data.MessagePack.Parser +import Data.MessagePack.Unpack -- | Deserialize a value -getI :: (Monad m, ObjectGet a) => I.Iteratee B.ByteString m a +getI :: (Monad m, Unpackable a) => I.Iteratee B.ByteString m a getI = parserToIteratee get -- | Enumerator diff --git a/src/Data/MessagePack/Object.hs b/src/Data/MessagePack/Object.hs --- a/src/Data/MessagePack/Object.hs +++ b/src/Data/MessagePack/Object.hs @@ -1,6 +1,7 @@ {-# Language TypeSynonymInstances #-} {-# Language FlexibleInstances #-} {-# Language OverlappingInstances #-} +{-# Language IncoherentInstances #-} {-# Language DeriveDataTypeable #-} -------------------------------------------------------------------- @@ -23,16 +24,21 @@ -- * Serialization to and from Object OBJECT(..), - Result, + -- Result, ) where import Control.DeepSeq +import Control.Exception import Control.Monad import Control.Monad.Trans.Error () +import qualified Data.Attoparsec as A import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as C8 import Data.Typeable +import Data.MessagePack.Pack +import Data.MessagePack.Unpack + -- | Object Representation of MessagePack data. data Object = ObjectNil @@ -55,70 +61,241 @@ 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 ObjectDouble get + , liftM ObjectRAW get + , liftM ObjectArray get + , liftM ObjectMap get + ] + +instance Packable Object where + put obj = + case obj of + ObjectInteger n -> + put n + ObjectNil -> + put () + ObjectBool b -> + put b + ObjectDouble d -> + put d + ObjectRAW raw -> + put raw + ObjectArray arr -> + put arr + ObjectMap m -> + put m + -- | The class of types serializable to and from MessagePack object -class OBJECT a where +class (Unpackable a, Packable a) => OBJECT a where -- | Encode a value to MessagePack object toObject :: a -> Object + toObject = unpack . pack + -- | Decode a value from MessagePack object - fromObject :: Object -> Result a + fromObject :: Object -> a + fromObject a = + case tryFromObject a of + Left err -> + throw $ UnpackError err + Right ret -> + ret --- | A type for parser results -type Result a = Either String a + -- | Decode a value from MessagePack object + tryFromObject :: Object -> Either String a + tryFromObject = tryUnpack . pack instance OBJECT Object where toObject = id - fromObject = Right + tryFromObject = Right -fromObjectError :: String -fromObjectError = "fromObject: cannot cast" +tryFromObjectError :: Either String a +tryFromObjectError = Left "tryFromObject: cannot cast" instance OBJECT () where toObject = const ObjectNil - fromObject ObjectNil = Right () - fromObject _ = Left fromObjectError + tryFromObject ObjectNil = Right () + tryFromObject _ = tryFromObjectError instance OBJECT Int where toObject = ObjectInteger - fromObject (ObjectInteger n) = Right n - fromObject _ = Left fromObjectError + tryFromObject (ObjectInteger n) = Right n + tryFromObject _ = tryFromObjectError instance OBJECT Bool where toObject = ObjectBool - fromObject (ObjectBool b) = Right b - fromObject _ = Left fromObjectError + tryFromObject (ObjectBool b) = Right b + tryFromObject _ = tryFromObjectError instance OBJECT Double where toObject = ObjectDouble - fromObject (ObjectDouble d) = Right d - fromObject _ = Left fromObjectError + tryFromObject (ObjectDouble d) = Right d + tryFromObject _ = tryFromObjectError instance OBJECT B.ByteString where toObject = ObjectRAW - fromObject (ObjectRAW bs) = Right bs - fromObject _ = Left fromObjectError + tryFromObject (ObjectRAW bs) = Right bs + tryFromObject _ = tryFromObjectError instance OBJECT String where toObject = toObject . C8.pack - fromObject obj = liftM C8.unpack $ fromObject obj + tryFromObject obj = liftM C8.unpack $ tryFromObject obj instance OBJECT a => OBJECT [a] where toObject = ObjectArray . map toObject - fromObject (ObjectArray arr) = - mapM fromObject arr - fromObject _ = - Left fromObjectError + tryFromObject (ObjectArray arr) = + mapM tryFromObject arr + tryFromObject _ = + tryFromObjectError +instance (OBJECT a1, OBJECT a2) => OBJECT (a1, a2) where + toObject (a1, a2) = ObjectArray [toObject a1, toObject a2] + tryFromObject (ObjectArray arr) = + case arr of + [o1, o2] -> do + v1 <- tryFromObject o1 + v2 <- tryFromObject o2 + return (v1, v2) + _ -> + tryFromObjectError + tryFromObject _ = + tryFromObjectError + +instance (OBJECT a1, OBJECT a2, OBJECT a3) => OBJECT (a1, a2, a3) where + toObject (a1, a2, a3) = ObjectArray [toObject a1, toObject a2, toObject a3] + tryFromObject (ObjectArray arr) = + case arr of + [o1, o2, o3] -> do + v1 <- tryFromObject o1 + v2 <- tryFromObject o2 + v3 <- tryFromObject o3 + return (v1, v2, v3) + _ -> + tryFromObjectError + tryFromObject _ = + tryFromObjectError + +instance (OBJECT a1, OBJECT a2, OBJECT a3, OBJECT a4) => OBJECT (a1, a2, a3, a4) where + toObject (a1, a2, a3, a4) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4] + tryFromObject (ObjectArray arr) = + case arr of + [o1, o2, o3, o4] -> do + v1 <- tryFromObject o1 + v2 <- tryFromObject o2 + v3 <- tryFromObject o3 + v4 <- tryFromObject o4 + return (v1, v2, v3, v4) + _ -> + tryFromObjectError + tryFromObject _ = + tryFromObjectError + +instance (OBJECT a1, OBJECT a2, OBJECT a3, OBJECT a4, OBJECT a5) => OBJECT (a1, a2, a3, a4, a5) where + toObject (a1, a2, a3, a4, a5) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5] + tryFromObject (ObjectArray arr) = + case arr of + [o1, o2, o3, o4, o5] -> do + v1 <- tryFromObject o1 + v2 <- tryFromObject o2 + v3 <- tryFromObject o3 + v4 <- tryFromObject o4 + v5 <- tryFromObject o5 + return (v1, v2, v3, v4, v5) + _ -> + tryFromObjectError + tryFromObject _ = + tryFromObjectError + +instance (OBJECT a1, OBJECT a2, OBJECT a3, OBJECT a4, OBJECT a5, OBJECT a6) => OBJECT (a1, a2, a3, a4, a5, a6) where + toObject (a1, a2, a3, a4, a5, a6) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5, toObject a6] + tryFromObject (ObjectArray arr) = + case arr of + [o1, o2, o3, o4, o5, o6] -> do + v1 <- tryFromObject o1 + v2 <- tryFromObject o2 + v3 <- tryFromObject o3 + v4 <- tryFromObject o4 + v5 <- tryFromObject o5 + v6 <- tryFromObject o6 + return (v1, v2, v3, v4, v5, v6) + _ -> + tryFromObjectError + tryFromObject _ = + tryFromObjectError + +instance (OBJECT a1, OBJECT a2, OBJECT a3, OBJECT a4, OBJECT a5, OBJECT a6, OBJECT a7) => OBJECT (a1, a2, a3, a4, a5, a6, a7) where + toObject (a1, a2, a3, a4, a5, a6, a7) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5, toObject a6, toObject a7] + tryFromObject (ObjectArray arr) = + case arr of + [o1, o2, o3, o4, o5, o6, o7] -> do + v1 <- tryFromObject o1 + v2 <- tryFromObject o2 + v3 <- tryFromObject o3 + v4 <- tryFromObject o4 + v5 <- tryFromObject o5 + v6 <- tryFromObject o6 + v7 <- tryFromObject o7 + return (v1, v2, v3, v4, v5, v6, v7) + _ -> + tryFromObjectError + tryFromObject _ = + tryFromObjectError + +instance (OBJECT a1, OBJECT a2, OBJECT a3, OBJECT a4, OBJECT a5, OBJECT a6, OBJECT a7, OBJECT a8) => OBJECT (a1, a2, a3, a4, a5, a6, a7, a8) where + toObject (a1, a2, a3, a4, a5, a6, a7, a8) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5, toObject a6, toObject a7, toObject a8] + tryFromObject (ObjectArray arr) = + case arr of + [o1, o2, o3, o4, o5, o6, o7, o8] -> do + v1 <- tryFromObject o1 + v2 <- tryFromObject o2 + v3 <- tryFromObject o3 + v4 <- tryFromObject o4 + v5 <- tryFromObject o5 + v6 <- tryFromObject o6 + v7 <- tryFromObject o7 + v8 <- tryFromObject o8 + return (v1, v2, v3, v4, v5, v6, v7, v8) + _ -> + tryFromObjectError + tryFromObject _ = + tryFromObjectError + +instance (OBJECT a1, OBJECT a2, OBJECT a3, OBJECT a4, OBJECT a5, OBJECT a6, OBJECT a7, OBJECT a8, OBJECT a9) => OBJECT (a1, a2, a3, a4, a5, a6, a7, a8, a9) where + toObject (a1, a2, a3, a4, a5, a6, a7, a8, a9) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5, toObject a6, toObject a7, toObject a8, toObject a9] + tryFromObject (ObjectArray arr) = + case arr of + [o1, o2, o3, o4, o5, o6, o7, o8, o9] -> do + v1 <- tryFromObject o1 + v2 <- tryFromObject o2 + v3 <- tryFromObject o3 + v4 <- tryFromObject o4 + v5 <- tryFromObject o5 + v6 <- tryFromObject o6 + v7 <- tryFromObject o7 + v8 <- tryFromObject o8 + v9 <- tryFromObject o9 + return (v1, v2, v3, v4, v5, v6, v7, v8, v9) + _ -> + tryFromObjectError + tryFromObject _ = + tryFromObjectError + instance (OBJECT a, OBJECT b) => OBJECT [(a, b)] where toObject = ObjectMap . map (\(a, b) -> (toObject a, toObject b)) - fromObject (ObjectMap mem) = do - mapM (\(a, b) -> liftM2 (,) (fromObject a) (fromObject b)) mem - fromObject _ = - Left fromObjectError + tryFromObject (ObjectMap mem) = do + mapM (\(a, b) -> liftM2 (,) (tryFromObject a) (tryFromObject b)) mem + tryFromObject _ = + tryFromObjectError instance OBJECT a => OBJECT (Maybe a) where toObject (Just a) = toObject a toObject Nothing = ObjectNil - fromObject ObjectNil = return Nothing - fromObject obj = liftM Just $ fromObject obj + tryFromObject ObjectNil = return Nothing + tryFromObject obj = liftM Just $ tryFromObject obj diff --git a/src/Data/MessagePack/Pack.hs b/src/Data/MessagePack/Pack.hs new file mode 100644 --- /dev/null +++ b/src/Data/MessagePack/Pack.hs @@ -0,0 +1,186 @@ +{-# Language FlexibleInstances #-} +{-# Language IncoherentInstances #-} +{-# Language OverlappingInstances #-} +{-# Language TypeSynonymInstances #-} + +-------------------------------------------------------------------- +-- | +-- Module : Data.MessagePack.Pack +-- Copyright : (c) Hideyuki Tanaka, 2009-2010 +-- License : BSD3 +-- +-- Maintainer: tanaka.hideyuki@gmail.com +-- Stability : experimental +-- Portability: portable +-- +-- MessagePack Serializer using @Data.Binary.Pack@ +-- +-------------------------------------------------------------------- + +module Data.MessagePack.Pack ( + -- * Serializable class + Packable(..), + -- * Simple function to pack a Haskell value + pack, + ) where + +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 + +-- | Serializable class +class Packable a where + -- | Serialize a value + put :: a -> Put + +-- | Pack Haskell data to MessagePack string. +pack :: Packable a => a -> L.ByteString +pack = runPut . put + +instance Packable Int where + put n = + case n of + _ | n >= 0 && n <= 127 -> + putWord8 $ fromIntegral n + _ | n >= -32 && n <= -1 -> + putWord8 $ fromIntegral n + _ | n >= 0 && n < 0x100 -> do + putWord8 0xCC + putWord8 $ fromIntegral n + _ | n >= 0 && n < 0x10000 -> do + putWord8 0xCD + putWord16be $ fromIntegral n + _ | n >= 0 && n < 0x100000000 -> do + putWord8 0xCE + putWord32be $ fromIntegral n + _ | n >= 0 -> do + putWord8 0xCF + putWord64be $ fromIntegral n + _ | n >= -0x80 -> do + putWord8 0xD0 + putWord8 $ fromIntegral n + _ | n >= -0x8000 -> do + putWord8 0xD1 + putWord16be $ fromIntegral n + _ | n >= -0x80000000 -> do + putWord8 0xD2 + putWord32be $ fromIntegral n + _ -> do + putWord8 0xD3 + putWord64be $ fromIntegral n + +instance Packable () where + put _ = + putWord8 0xC0 + +instance Packable Bool where + put True = putWord8 0xC3 + put False = putWord8 0xC2 + +instance Packable Double where + put d = do + putWord8 0xCB + putFloat64be d + +instance Packable String where + put = putString length (putByteString . B8.pack) + +instance Packable B.ByteString where + put = putString B.length putByteString + +instance Packable 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 Packable a => Packable [a] where + put = putArray length (mapM_ put) + +instance Packable a => Packable (V.Vector a) where + put = putArray V.length (V.mapM_ put) + +instance (Packable a1, Packable a2) => Packable (a1, a2) where + put = putArray (const 2) f where + f (a1, a2) = put a1 >> put a2 + +instance (Packable a1, Packable a2, Packable a3) => Packable (a1, a2, a3) where + put = putArray (const 3) f where + f (a1, a2, a3) = put a1 >> put a2 >> put a3 + +instance (Packable a1, Packable a2, Packable a3, Packable a4) => Packable (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 (Packable a1, Packable a2, Packable a3, Packable a4, Packable a5) => Packable (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 (Packable a1, Packable a2, Packable a3, Packable a4, Packable a5, Packable a6) => Packable (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 (Packable a1, Packable a2, Packable a3, Packable a4, Packable a5, Packable a6, Packable a7) => Packable (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 (Packable a1, Packable a2, Packable a3, Packable a4, Packable a5, Packable a6, Packable a7, Packable a8) => Packable (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 (Packable a1, Packable a2, Packable a3, Packable a4, Packable a5, Packable a6, Packable a7, Packable a8, Packable a9) => Packable (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 + len | len <= 15 -> + putWord8 $ 0x90 .|. fromIntegral len + len | len < 0x10000 -> do + putWord8 0xDC + putWord16be $ fromIntegral len + len -> do + putWord8 0xDD + 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 (V.Vector (k, v)) where + put = putMap V.length (V.mapM_ putPair) + +putPair :: (Packable a, Packable b) => (a, b) -> Put +putPair (a, b) = put a >> put b + +putMap :: (a -> Int) -> (a -> Put) -> a -> Put +putMap lf pf m = do + case lf m of + len | len <= 15 -> + putWord8 $ 0x80 .|. fromIntegral len + len | len < 0x10000 -> do + putWord8 0xDE + putWord16be $ fromIntegral len + len -> do + putWord8 0xDF + putWord32be $ fromIntegral len + pf m + +instance Packable a => Packable (Maybe a) where + put Nothing = put () + put (Just a) = put a diff --git a/src/Data/MessagePack/Parser.hs b/src/Data/MessagePack/Parser.hs deleted file mode 100644 --- a/src/Data/MessagePack/Parser.hs +++ /dev/null @@ -1,270 +0,0 @@ -{-# Language FlexibleInstances #-} -{-# Language IncoherentInstances #-} -{-# Language OverlappingInstances #-} -{-# Language TypeSynonymInstances #-} - --------------------------------------------------------------------- --- | --- Module : Data.MessagePack.Parser --- Copyright : (c) Hideyuki Tanaka, 2009-2010 --- License : BSD3 --- --- Maintainer: tanaka.hideyuki@gmail.com --- Stability : experimental --- Portability: portable --- --- MessagePack Deserializer using @Data.Attoparsec@ --- --------------------------------------------------------------------- - -module Data.MessagePack.Parser( - -- * MessagePack deserializer - ObjectGet(..), - ) where - -import Control.Monad -import qualified Data.Attoparsec as A -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 -import Data.Word -import Text.Printf - -import Data.MessagePack.Object - --- | Deserializable class -class ObjectGet a where - -- | Deserialize a value - get :: A.Parser a - -instance ObjectGet Object where - get = - A.choice - [ liftM ObjectInteger get - , liftM (\() -> ObjectNil) get - , liftM ObjectBool get - , liftM ObjectDouble get - , liftM ObjectRAW get - , liftM ObjectArray get - , liftM ObjectMap get - ] - -instance ObjectGet Int where - get = do - c <- A.anyWord8 - case c of - _ | c .&. 0x80 == 0x00 -> - return $ fromIntegral c - _ | c .&. 0xE0 == 0xE0 -> - return $ fromIntegral (fromIntegral c :: Int8) - 0xCC -> - return . fromIntegral =<< A.anyWord8 - 0xCD -> - return . fromIntegral =<< parseUint16 - 0xCE -> - return . fromIntegral =<< parseUint32 - 0xCF -> - return . fromIntegral =<< parseUint64 - 0xD0 -> - return . fromIntegral =<< parseInt8 - 0xD1 -> - return . fromIntegral =<< parseInt16 - 0xD2 -> - return . fromIntegral =<< parseInt32 - 0xD3 -> - return . fromIntegral =<< parseInt64 - _ -> - fail $ printf "invlid integer tag: 0x%02X" c - -instance ObjectGet () where - get = do - c <- A.anyWord8 - case c of - 0xC0 -> - return () - _ -> - fail $ printf "invlid nil tag: 0x%02X" c - -instance ObjectGet Bool where - get = do - c <- A.anyWord8 - case c of - 0xC3 -> - return True - 0xC2 -> - return False - _ -> - fail $ printf "invlid bool tag: 0x%02X" c - -instance ObjectGet Double where - get = do - c <- A.anyWord8 - case c of - 0xCA -> - return . realToFrac . runGet getFloat32be . toLBS =<< A.take 4 - 0xCB -> - return . runGet getFloat64be . toLBS =<< A.take 8 - _ -> - 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 = 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) - -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 - case c of - _ | c .&. 0xF0 == 0x90 -> - aget . fromIntegral $ c .&. 0x0F - 0xDC -> - aget . fromIntegral =<< parseUint16 - 0xDD -> - aget . fromIntegral =<< parseUint32 - _ -> - fail $ printf "invlid array tag: 0x%02X" c - -instance (ObjectGet k, ObjectGet v) => ObjectGet [(k, v)] where - get = parseMap (flip replicateM parsePair) - -instance (ObjectGet k, ObjectGet v) => ObjectGet (V.Vector (k, v)) where - get = parseMap (flip V.replicateM parsePair) - -parsePair :: (ObjectGet k, ObjectGet v) => A.Parser (k, v) -parsePair = do - a <- get - b <- get - return (a, b) - -parseMap :: (Int -> A.Parser a) -> A.Parser a -parseMap aget = do - c <- A.anyWord8 - case c of - _ | c .&. 0xF0 == 0x80 -> - aget . fromIntegral $ c .&. 0x0F - 0xDE -> - aget . fromIntegral =<< parseUint16 - 0xDF -> - aget . fromIntegral =<< parseUint32 - _ -> - fail $ printf "invlid map tag: 0x%02X" c - -parseUint16 :: A.Parser Word16 -parseUint16 = do - b0 <- A.anyWord8 - b1 <- A.anyWord8 - return $ (fromIntegral b0 `shiftL` 8) .|. fromIntegral b1 - -parseUint32 :: A.Parser Word32 -parseUint32 = do - b0 <- A.anyWord8 - b1 <- A.anyWord8 - b2 <- A.anyWord8 - b3 <- A.anyWord8 - return $ (fromIntegral b0 `shiftL` 24) .|. - (fromIntegral b1 `shiftL` 16) .|. - (fromIntegral b2 `shiftL` 8) .|. - fromIntegral b3 - -parseUint64 :: A.Parser Word64 -parseUint64 = do - b0 <- A.anyWord8 - b1 <- A.anyWord8 - b2 <- A.anyWord8 - b3 <- A.anyWord8 - b4 <- A.anyWord8 - b5 <- A.anyWord8 - b6 <- A.anyWord8 - b7 <- A.anyWord8 - return $ (fromIntegral b0 `shiftL` 56) .|. - (fromIntegral b1 `shiftL` 48) .|. - (fromIntegral b2 `shiftL` 40) .|. - (fromIntegral b3 `shiftL` 32) .|. - (fromIntegral b4 `shiftL` 24) .|. - (fromIntegral b5 `shiftL` 16) .|. - (fromIntegral b6 `shiftL` 8) .|. - fromIntegral b7 - -parseInt8 :: A.Parser Int8 -parseInt8 = return . fromIntegral =<< A.anyWord8 - -parseInt16 :: A.Parser Int16 -parseInt16 = return . fromIntegral =<< parseUint16 - -parseInt32 :: A.Parser Int32 -parseInt32 = return . fromIntegral =<< parseUint32 - -parseInt64 :: A.Parser Int64 -parseInt64 = return . fromIntegral =<< parseUint64 - -toLBS :: B.ByteString -> L.ByteString -toLBS bs = L.fromChunks [bs] diff --git a/src/Data/MessagePack/Put.hs b/src/Data/MessagePack/Put.hs deleted file mode 100644 --- a/src/Data/MessagePack/Put.hs +++ /dev/null @@ -1,196 +0,0 @@ -{-# Language FlexibleInstances #-} -{-# Language IncoherentInstances #-} -{-# Language OverlappingInstances #-} -{-# Language TypeSynonymInstances #-} - --------------------------------------------------------------------- --- | --- Module : Data.MessagePack.Put --- Copyright : (c) Hideyuki Tanaka, 2009-2010 --- License : BSD3 --- --- Maintainer: tanaka.hideyuki@gmail.com --- Stability : experimental --- Portability: portable --- --- MessagePack Serializer using @Data.Binary.Put@ --- --------------------------------------------------------------------- - -module Data.MessagePack.Put( - -- * Serializable class - ObjectPut(..), - ) where - -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 - --- | Serializable class -class ObjectPut a where - -- | Serialize a value - put :: a -> Put - -instance ObjectPut Object where - put obj = - case obj of - ObjectInteger n -> - put n - ObjectNil -> - put () - ObjectBool b -> - put b - ObjectDouble d -> - put d - ObjectRAW raw -> - put raw - ObjectArray arr -> - put arr - ObjectMap m -> - put m - -instance ObjectPut Int where - put n = - case n of - _ | n >= 0 && n <= 127 -> - putWord8 $ fromIntegral n - _ | n >= -32 && n <= -1 -> - putWord8 $ fromIntegral n - _ | n >= 0 && n < 0x100 -> do - putWord8 0xCC - putWord8 $ fromIntegral n - _ | n >= 0 && n < 0x10000 -> do - putWord8 0xCD - putWord16be $ fromIntegral n - _ | n >= 0 && n < 0x100000000 -> do - putWord8 0xCE - putWord32be $ fromIntegral n - _ | n >= 0 -> do - putWord8 0xCF - putWord64be $ fromIntegral n - _ | n >= -0x80 -> do - putWord8 0xD0 - putWord8 $ fromIntegral n - _ | n >= -0x8000 -> do - putWord8 0xD1 - putWord16be $ fromIntegral n - _ | n >= -0x80000000 -> do - putWord8 0xD2 - putWord32be $ fromIntegral n - _ -> do - putWord8 0xD3 - putWord64be $ fromIntegral n - -instance ObjectPut () where - put _ = - putWord8 0xC0 - -instance ObjectPut Bool where - put True = putWord8 0xC3 - put False = putWord8 0xC2 - -instance ObjectPut Double where - put d = do - putWord8 0xCB - putFloat64be d - -instance ObjectPut String where - put = putString length (putByteString . B8.pack) - -instance ObjectPut B.ByteString where - 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) - -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 - len | len <= 15 -> - putWord8 $ 0x90 .|. fromIntegral len - len | len < 0x10000 -> do - putWord8 0xDC - putWord16be $ fromIntegral len - len -> do - putWord8 0xDD - putWord32be $ fromIntegral len - pf arr - -instance (ObjectPut k, ObjectPut v) => ObjectPut [(k, v)] where - put = putMap length (mapM_ putPair) - -instance (ObjectPut k, ObjectPut v) => ObjectPut (V.Vector (k, v)) where - put = putMap V.length (V.mapM_ putPair) - -putPair :: (ObjectPut a, ObjectPut b) => (a, b) -> Put -putPair (a, b) = put a >> put b - -putMap :: (a -> Int) -> (a -> Put) -> a -> Put -putMap lf pf m = do - case lf m of - len | len <= 15 -> - putWord8 $ 0x80 .|. fromIntegral len - len | len < 0x10000 -> do - putWord8 0xDE - putWord16be $ fromIntegral len - len -> do - putWord8 0xDF - putWord32be $ fromIntegral len - pf m diff --git a/src/Data/MessagePack/Unpack.hs b/src/Data/MessagePack/Unpack.hs new file mode 100644 --- /dev/null +++ b/src/Data/MessagePack/Unpack.hs @@ -0,0 +1,308 @@ +{-# Language FlexibleInstances #-} +{-# Language IncoherentInstances #-} +{-# Language OverlappingInstances #-} +{-# Language TypeSynonymInstances #-} +{-# Language DeriveDataTypeable #-} + +-------------------------------------------------------------------- +-- | +-- Module : Data.MessagePack.Unpack +-- Copyright : (c) Hideyuki Tanaka, 2009-2010 +-- License : BSD3 +-- +-- Maintainer: tanaka.hideyuki@gmail.com +-- Stability : experimental +-- Portability: portable +-- +-- MessagePack Deserializer using @Data.Attoparsec@ +-- +-------------------------------------------------------------------- + +module Data.MessagePack.Unpack( + -- * MessagePack deserializer + Unpackable(..), + -- * Simple function to unpack a Haskell value + unpack, + tryUnpack, + -- * Unpack exception + UnpackError(..), + -- * ByteString utils + IsByteString(..), + ) where + +import Control.Exception +import Control.Monad +import qualified Data.Attoparsec as A +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 Data.Typeable +import qualified Data.Vector as V +import Data.Word +import Text.Printf + +-- | Deserializable class +class Unpackable a where + -- | Deserialize a value + get :: A.Parser a + +class IsByteString s where + toBS :: s -> B.ByteString + +instance IsByteString B.ByteString where + toBS = id + +instance IsByteString L.ByteString where + toBS = B.concat . L.toChunks + +-- | The exception of unpack +data UnpackError = + UnpackError String + deriving (Show, Typeable) + +instance Exception UnpackError + +-- | Unpack MessagePack string to Haskell data. +unpack :: (Unpackable a, IsByteString s) => s -> a +unpack bs = + case tryUnpack bs of + Left err -> + throw $ UnpackError err + Right ret -> + ret + +-- | Unpack MessagePack string to Haskell data. +tryUnpack :: (Unpackable a, IsByteString s) => s -> Either String a +tryUnpack bs = + case A.parse get (toBS bs) of + A.Fail _ _ err -> + Left err + A.Partial _ -> + Left "not enough input" + A.Done _ ret -> + Right ret + +instance Unpackable Int where + get = do + c <- A.anyWord8 + case c of + _ | c .&. 0x80 == 0x00 -> + return $ fromIntegral c + _ | c .&. 0xE0 == 0xE0 -> + return $ fromIntegral (fromIntegral c :: Int8) + 0xCC -> + return . fromIntegral =<< A.anyWord8 + 0xCD -> + return . fromIntegral =<< parseUint16 + 0xCE -> + return . fromIntegral =<< parseUint32 + 0xCF -> + return . fromIntegral =<< parseUint64 + 0xD0 -> + return . fromIntegral =<< parseInt8 + 0xD1 -> + return . fromIntegral =<< parseInt16 + 0xD2 -> + return . fromIntegral =<< parseInt32 + 0xD3 -> + return . fromIntegral =<< parseInt64 + _ -> + fail $ printf "invlid integer tag: 0x%02X" c + +instance Unpackable () where + get = do + c <- A.anyWord8 + case c of + 0xC0 -> + return () + _ -> + fail $ printf "invlid nil tag: 0x%02X" c + +instance Unpackable Bool where + get = do + c <- A.anyWord8 + case c of + 0xC3 -> + return True + 0xC2 -> + return False + _ -> + fail $ printf "invlid bool tag: 0x%02X" c + +instance Unpackable Double where + get = do + c <- A.anyWord8 + case c of + 0xCA -> + return . realToFrac . runGet getFloat32be . toLBS =<< A.take 4 + 0xCB -> + return . runGet getFloat64be . toLBS =<< A.take 8 + _ -> + fail $ printf "invlid double tag: 0x%02X" c + +instance Unpackable String where + get = parseString (\n -> return . B8.unpack =<< A.take n) + +instance Unpackable B.ByteString where + get = parseString A.take + +instance Unpackable 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 Unpackable a => Unpackable [a] where + get = parseArray (flip replicateM get) + +instance Unpackable a => Unpackable (V.Vector a) where + get = parseArray (flip V.replicateM get) + +instance (Unpackable a1, Unpackable a2) => Unpackable (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 (Unpackable a1, Unpackable a2, Unpackable a3) => Unpackable (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 (Unpackable a1, Unpackable a2, Unpackable a3, Unpackable a4) => Unpackable (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 (Unpackable a1, Unpackable a2, Unpackable a3, Unpackable a4, Unpackable a5) => Unpackable (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 (Unpackable a1, Unpackable a2, Unpackable a3, Unpackable a4, Unpackable a5, Unpackable a6) => Unpackable (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 (Unpackable a1, Unpackable a2, Unpackable a3, Unpackable a4, Unpackable a5, Unpackable a6, Unpackable a7) => Unpackable (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 (Unpackable a1, Unpackable a2, Unpackable a3, Unpackable a4, Unpackable a5, Unpackable a6, Unpackable a7, Unpackable a8) => Unpackable (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 (Unpackable a1, Unpackable a2, Unpackable a3, Unpackable a4, Unpackable a5, Unpackable a6, Unpackable a7, Unpackable a8, Unpackable a9) => Unpackable (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 + case c of + _ | c .&. 0xF0 == 0x90 -> + aget . fromIntegral $ c .&. 0x0F + 0xDC -> + aget . fromIntegral =<< parseUint16 + 0xDD -> + aget . fromIntegral =<< parseUint32 + _ -> + 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 (V.Vector (k, v)) where + get = parseMap (flip V.replicateM parsePair) + +parsePair :: (Unpackable k, Unpackable v) => A.Parser (k, v) +parsePair = do + a <- get + b <- get + return (a, b) + +parseMap :: (Int -> A.Parser a) -> A.Parser a +parseMap aget = do + c <- A.anyWord8 + case c of + _ | c .&. 0xF0 == 0x80 -> + aget . fromIntegral $ c .&. 0x0F + 0xDE -> + aget . fromIntegral =<< parseUint16 + 0xDF -> + aget . fromIntegral =<< parseUint32 + _ -> + fail $ printf "invlid map tag: 0x%02X" c + +instance Unpackable a => Unpackable (Maybe a) where + get = + A.choice + [ liftM Just get + , liftM (\() -> Nothing) get ] + +parseUint16 :: A.Parser Word16 +parseUint16 = do + b0 <- A.anyWord8 + b1 <- A.anyWord8 + return $ (fromIntegral b0 `shiftL` 8) .|. fromIntegral b1 + +parseUint32 :: A.Parser Word32 +parseUint32 = do + b0 <- A.anyWord8 + b1 <- A.anyWord8 + b2 <- A.anyWord8 + b3 <- A.anyWord8 + return $ (fromIntegral b0 `shiftL` 24) .|. + (fromIntegral b1 `shiftL` 16) .|. + (fromIntegral b2 `shiftL` 8) .|. + fromIntegral b3 + +parseUint64 :: A.Parser Word64 +parseUint64 = do + b0 <- A.anyWord8 + b1 <- A.anyWord8 + b2 <- A.anyWord8 + b3 <- A.anyWord8 + b4 <- A.anyWord8 + b5 <- A.anyWord8 + b6 <- A.anyWord8 + b7 <- A.anyWord8 + return $ (fromIntegral b0 `shiftL` 56) .|. + (fromIntegral b1 `shiftL` 48) .|. + (fromIntegral b2 `shiftL` 40) .|. + (fromIntegral b3 `shiftL` 32) .|. + (fromIntegral b4 `shiftL` 24) .|. + (fromIntegral b5 `shiftL` 16) .|. + (fromIntegral b6 `shiftL` 8) .|. + fromIntegral b7 + +parseInt8 :: A.Parser Int8 +parseInt8 = return . fromIntegral =<< A.anyWord8 + +parseInt16 :: A.Parser Int16 +parseInt16 = return . fromIntegral =<< parseUint16 + +parseInt32 :: A.Parser Int32 +parseInt32 = return . fromIntegral =<< parseUint32 + +parseInt64 :: A.Parser Int64 +parseInt64 = return . fromIntegral =<< parseUint64 + +toLBS :: B.ByteString -> L.ByteString +toLBS bs = L.fromChunks [bs] diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,64 @@ +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +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 :: (Packable a, Unpackable a) => a -> a +mid = unpack . pack + +prop_mid_int a = a == mid a + where types = a :: Int +prop_mid_nil a = a == mid a + where types = a :: () +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 == 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 == 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 == mid a + where types = a :: [(String, String)] + +tests = + [ testGroup "simple" + [ testProperty "int" prop_mid_int + , testProperty "nil" prop_mid_nil + , 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 + ] + ] + +main = defaultMain tests diff --git a/test/UserData.hs b/test/UserData.hs new file mode 100644 --- /dev/null +++ b/test/UserData.hs @@ -0,0 +1,45 @@ +{-# Language TemplateHaskell #-} + +import Data.MessagePack +import Data.MessagePack.Derive + +data T + = A Int String + | B Double + deriving (Show) + +$(deriveObject ''T) + +data U + = C { c1 :: Int, c2 :: String } + | D { d1 :: Double } + deriving (Show) + +$(deriveObject ''U) + +main = do + let bs = pack $ A 123 "hoge" + print bs + print (unpack bs :: T) + let cs = pack $ B 3.14 + print cs + print (unpack cs :: T) + let oa = toObject $ A 123 "hoge" + print oa + print (fromObject oa :: T) + let ob = toObject $ B 3.14 + print ob + print (fromObject ob :: T) + + let ds = pack $ C 123 "hoge" + print ds + print (unpack ds :: U) + let es = pack $ D 3.14 + print es + print (unpack es :: U) + let oc = toObject $ C 123 "hoge" + print oc + print (fromObject oc :: U) + let od = toObject $ D 3.14 + print od + print (fromObject od :: U)