mirror of
https://github.com/msgpack/msgpack-c.git
synced 2025-10-21 23:56:55 +02:00
haskell: TH support and refactoring
This commit is contained in:
tanakh
@@ -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
|
||||
|
||||
74
haskell/src/Data/MessagePack/Derive.hs
Normal file
74
haskell/src/Data/MessagePack/Derive.hs
Normal file
@@ -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
|
||||
-}
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
@@ -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
|
||||
Reference in New Issue
Block a user