diff --git a/haskell/msgpack.cabal b/haskell/msgpack.cabal index ccdb2f7f..9c67bdce 100644 --- a/haskell/msgpack.cabal +++ b/haskell/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 @@ -25,17 +25,19 @@ Library 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/haskell/src/Data/MessagePack.hs b/haskell/src/Data/MessagePack.hs index 7137589f..b71190d6 100644 --- a/haskell/src/Data/MessagePack.hs +++ b/haskell/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,38 +41,18 @@ import qualified Data.Attoparsec as A 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 packToString = runPut diff --git a/haskell/src/Data/MessagePack/Derive.hs b/haskell/src/Data/MessagePack/Derive.hs new file mode 100644 index 00000000..cfdb6588 --- /dev/null +++ b/haskell/src/Data/MessagePack/Derive.hs @@ -0,0 +1,74 @@ +{-# 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 + +deriveUnpack :: Name -> Q [Dec] +deriveUnpack typName = do + TyConI (DataD cxt name tyVarBndrs cons names) <- reify typName + + return + [ InstanceD [] (AppT (ConT ''Unpackable) (ConT name)) + [ FunD 'get [Clause [] (NormalB $ ch $ map body cons) []] + ]] + + where + body (NormalC conName elms) = + DoE + [ BindS (tupOrList $ 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 + + tupOrList ls + | length ls <= 1 = ListP ls + | otherwise = TupP ls + + ch = foldl1 (\e f -> AppE (AppE (VarE '(<|>)) e) f) + +derivePack :: Name -> Q [Dec] +derivePack typName = do + TyConI (DataD cxt name tyVarBndrs cons names) <- 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) $ tupOrList $ map VarE names) [] + where + names = zipWith (\ix _ -> mkName $ "a" ++ show (ix :: Int)) [1..] elms + + tupOrList ls + | length ls <= 1 = ListE ls + | otherwise = TupE ls + +deriveObject :: Name -> Q [Dec] +deriveObject typName = do + g <- derivePack typName + p <- deriveUnpack typName + {- + TyConI (DataD cxt name tyVarBndrs cons names) <- reify typName + let o = InstanceD [] (AppT (ConT ''OBJECT) (ConT name)) + [ FunD 'toObject (map toObjectBody cons) ] + -} + return $ g ++ p -- ++ [o] +{- + where + toObjectBody (NormalC conName elms) = + Clause + [ ConP conP +-} diff --git a/haskell/src/Data/MessagePack/Iteratee.hs b/haskell/src/Data/MessagePack/Iteratee.hs index 4258cf68..6bc08980 100644 --- a/haskell/src/Data/MessagePack/Iteratee.hs +++ b/haskell/src/Data/MessagePack/Iteratee.hs @@ -28,10 +28,10 @@ import qualified Data.ByteString as B 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/haskell/src/Data/MessagePack/Object.hs b/haskell/src/Data/MessagePack/Object.hs index 87f24bd9..5111ebb6 100644 --- a/haskell/src/Data/MessagePack/Object.hs +++ b/haskell/src/Data/MessagePack/Object.hs @@ -1,6 +1,7 @@ {-# Language TypeSynonymInstances #-} {-# Language FlexibleInstances #-} {-# Language OverlappingInstances #-} +{-# Language IncoherentInstances #-} {-# Language DeriveDataTypeable #-} -------------------------------------------------------------------- @@ -23,16 +24,21 @@ module Data.MessagePack.Object( -- * 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 @@ instance NFData Object where 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/haskell/src/Data/MessagePack/Put.hs b/haskell/src/Data/MessagePack/Pack.hs similarity index 66% rename from haskell/src/Data/MessagePack/Put.hs rename to haskell/src/Data/MessagePack/Pack.hs index 24ec3059..16243ad9 100644 --- a/haskell/src/Data/MessagePack/Put.hs +++ b/haskell/src/Data/MessagePack/Pack.hs @@ -5,7 +5,7 @@ -------------------------------------------------------------------- -- | --- Module : Data.MessagePack.Put +-- Module : Data.MessagePack.Pack -- Copyright : (c) Hideyuki Tanaka, 2009-2010 -- License : BSD3 -- @@ -13,13 +13,15 @@ -- Stability : experimental -- Portability: portable -- --- MessagePack Serializer using @Data.Binary.Put@ +-- MessagePack Serializer using @Data.Binary.Pack@ -- -------------------------------------------------------------------- -module Data.MessagePack.Put( +module Data.MessagePack.Pack ( -- * Serializable class - ObjectPut(..), + Packable(..), + -- * Simple function to pack a Haskell value + pack, ) where import Data.Binary.Put @@ -30,32 +32,16 @@ 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 +class Packable 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 +-- | Pack Haskell data to MessagePack string. +pack :: Packable a => a -> L.ByteString +pack = runPut . put -instance ObjectPut Int where +instance Packable Int where put n = case n of _ | n >= 0 && n <= 127 -> @@ -87,26 +73,26 @@ instance ObjectPut Int where putWord8 0xD3 putWord64be $ fromIntegral n -instance ObjectPut () where +instance Packable () where put _ = putWord8 0xC0 -instance ObjectPut Bool where +instance Packable Bool where put True = putWord8 0xC3 put False = putWord8 0xC2 -instance ObjectPut Double where +instance Packable Double where put d = do putWord8 0xCB putFloat64be d -instance ObjectPut String where +instance Packable String where put = putString length (putByteString . B8.pack) -instance ObjectPut B.ByteString where +instance Packable B.ByteString where put = putString B.length putByteString -instance ObjectPut L.ByteString where +instance Packable L.ByteString where put = putString (fromIntegral . L.length) putLazyByteString putString :: (s -> Int) -> (s -> Put) -> s -> Put @@ -122,41 +108,41 @@ putString lf pf str = do putWord32be $ fromIntegral len pf str -instance ObjectPut a => ObjectPut [a] where +instance Packable a => Packable [a] where put = putArray length (mapM_ put) -instance ObjectPut a => ObjectPut (V.Vector a) where +instance Packable a => Packable (V.Vector a) where put = putArray V.length (V.mapM_ put) -instance (ObjectPut a1, ObjectPut a2) => ObjectPut (a1, a2) where +instance (Packable a1, Packable a2) => Packable (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 +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 (ObjectPut a1, ObjectPut a2, ObjectPut a3, ObjectPut a4) => ObjectPut (a1, a2, a3, a4) where +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 (ObjectPut a1, ObjectPut a2, ObjectPut a3, ObjectPut a4, ObjectPut a5) => ObjectPut (a1, a2, a3, a4, a5) where +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 (ObjectPut a1, ObjectPut a2, ObjectPut a3, ObjectPut a4, ObjectPut a5, ObjectPut a6) => ObjectPut (a1, a2, a3, a4, a5, a6) where +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 (ObjectPut a1, ObjectPut a2, ObjectPut a3, ObjectPut a4, ObjectPut a5, ObjectPut a6, ObjectPut a7) => ObjectPut (a1, a2, a3, a4, a5, a6, a7) where +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 (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 +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 (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 +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 @@ -173,13 +159,13 @@ putArray lf pf arr = do putWord32be $ fromIntegral len pf arr -instance (ObjectPut k, ObjectPut v) => ObjectPut [(k, v)] where +instance (Packable k, Packable v) => Packable [(k, v)] where put = putMap length (mapM_ putPair) -instance (ObjectPut k, ObjectPut v) => ObjectPut (V.Vector (k, v)) where +instance (Packable k, Packable v) => Packable (V.Vector (k, v)) where put = putMap V.length (V.mapM_ putPair) -putPair :: (ObjectPut a, ObjectPut b) => (a, b) -> Put +putPair :: (Packable a, Packable b) => (a, b) -> Put putPair (a, b) = put a >> put b putMap :: (a -> Int) -> (a -> Put) -> a -> Put @@ -194,3 +180,7 @@ putMap lf pf m = 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/haskell/src/Data/MessagePack/Parser.hs b/haskell/src/Data/MessagePack/Unpack.hs similarity index 70% rename from haskell/src/Data/MessagePack/Parser.hs rename to haskell/src/Data/MessagePack/Unpack.hs index 200ad962..a0d618ec 100644 --- a/haskell/src/Data/MessagePack/Parser.hs +++ b/haskell/src/Data/MessagePack/Unpack.hs @@ -2,10 +2,11 @@ {-# Language IncoherentInstances #-} {-# Language OverlappingInstances #-} {-# Language TypeSynonymInstances #-} +{-# Language DeriveDataTypeable #-} -------------------------------------------------------------------- -- | --- Module : Data.MessagePack.Parser +-- Module : Data.MessagePack.Unpack -- Copyright : (c) Hideyuki Tanaka, 2009-2010 -- License : BSD3 -- @@ -17,11 +18,19 @@ -- -------------------------------------------------------------------- -module Data.MessagePack.Parser( +module Data.MessagePack.Unpack( -- * MessagePack deserializer - ObjectGet(..), + 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 @@ -31,30 +40,53 @@ 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 -import Data.MessagePack.Object - -- | Deserializable class -class ObjectGet a where +class Unpackable 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 - ] +class IsByteString s where + toBS :: s -> B.ByteString -instance ObjectGet Int where +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 @@ -81,7 +113,7 @@ instance ObjectGet Int where _ -> fail $ printf "invlid integer tag: 0x%02X" c -instance ObjectGet () where +instance Unpackable () where get = do c <- A.anyWord8 case c of @@ -90,7 +122,7 @@ instance ObjectGet () where _ -> fail $ printf "invlid nil tag: 0x%02X" c -instance ObjectGet Bool where +instance Unpackable Bool where get = do c <- A.anyWord8 case c of @@ -101,7 +133,7 @@ instance ObjectGet Bool where _ -> fail $ printf "invlid bool tag: 0x%02X" c -instance ObjectGet Double where +instance Unpackable Double where get = do c <- A.anyWord8 case c of @@ -112,13 +144,13 @@ instance ObjectGet Double where _ -> fail $ printf "invlid double tag: 0x%02X" c -instance ObjectGet String where +instance Unpackable String where get = parseString (\n -> return . B8.unpack =<< A.take n) -instance ObjectGet B.ByteString where +instance Unpackable B.ByteString where get = parseString A.take -instance ObjectGet L.ByteString where +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 @@ -134,48 +166,48 @@ parseString aget = do _ -> fail $ printf "invlid raw tag: 0x%02X" c -instance ObjectGet a => ObjectGet [a] where +instance Unpackable a => Unpackable [a] where get = parseArray (flip replicateM get) -instance ObjectGet a => ObjectGet (V.Vector a) where +instance Unpackable a => Unpackable (V.Vector a) where get = parseArray (flip V.replicateM get) -instance (ObjectGet a1, ObjectGet a2) => ObjectGet (a1, a2) where +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 (ObjectGet a1, ObjectGet a2, ObjectGet a3) => ObjectGet (a1, a2, a3) where +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 (ObjectGet a1, ObjectGet a2, ObjectGet a3, ObjectGet a4) => ObjectGet (a1, a2, a3, a4) where +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 (ObjectGet a1, ObjectGet a2, ObjectGet a3, ObjectGet a4, ObjectGet a5) => ObjectGet (a1, a2, a3, a4, a5) where +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 (ObjectGet a1, ObjectGet a2, ObjectGet a3, ObjectGet a4, ObjectGet a5, ObjectGet a6) => ObjectGet (a1, a2, a3, a4, a5, a6) where +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 (ObjectGet a1, ObjectGet a2, ObjectGet a3, ObjectGet a4, ObjectGet a5, ObjectGet a6, ObjectGet a7) => ObjectGet (a1, a2, a3, a4, a5, a6, a7) where +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 (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 +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 (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 +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 @@ -193,13 +225,13 @@ parseArray aget = do _ -> fail $ printf "invlid array tag: 0x%02X" c -instance (ObjectGet k, ObjectGet v) => ObjectGet [(k, v)] where +instance (Unpackable k, Unpackable v) => Unpackable [(k, v)] where get = parseMap (flip replicateM parsePair) -instance (ObjectGet k, ObjectGet v) => ObjectGet (V.Vector (k, v)) where +instance (Unpackable k, Unpackable v) => Unpackable (V.Vector (k, v)) where get = parseMap (flip V.replicateM parsePair) -parsePair :: (ObjectGet k, ObjectGet v) => A.Parser (k, v) +parsePair :: (Unpackable k, Unpackable v) => A.Parser (k, v) parsePair = do a <- get b <- get @@ -218,6 +250,12 @@ parseMap aget = do _ -> 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 diff --git a/haskell/test/UserData.hs b/haskell/test/UserData.hs new file mode 100644 index 00000000..8aced13f --- /dev/null +++ b/haskell/test/UserData.hs @@ -0,0 +1,19 @@ +{-# Language TemplateHaskell #-} + +import Data.MessagePack +import Data.MessagePack.Derive + +data T + = A Int String + | B Double + deriving (Show) + +$(deriveObject ''T) + +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)