msgpack 0.7.1.4 → 0.7.1.5
raw patch · 11 files changed
+1295/−1294 lines, 11 filesdep +ghc-primdep ~containersdep ~mtldep ~test-frameworksetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies added: ghc-prim
Dependency ranges changed: containers, mtl, test-framework, test-framework-quickcheck2
API changes (from Hackage documentation)
Files
- Data/MessagePack.hs +27/−27
- Data/MessagePack/Assoc.hs +28/−28
- Data/MessagePack/Derive.hs +136/−136
- Data/MessagePack/Internal/Utf8.hs +28/−28
- Data/MessagePack/Object.hs +366/−366
- Data/MessagePack/Pack.hs +221/−221
- Data/MessagePack/Unpack.hs +337/−337
- LICENSE +24/−24
- Setup.lhs +3/−3
- msgpack.cabal +55/−54
- test/Test.hs +70/−70
Data/MessagePack.hs view
@@ -1,27 +1,27 @@------------------------------------------------------------------------ |--- Module : Data.MessagePack--- Copyright : (c) Hideyuki Tanaka, 2009-2011--- License : BSD3------ Maintainer: tanaka.hideyuki@gmail.com--- Stability : experimental--- Portability: portable------ Simple interface to pack and unpack MessagePack data.--------------------------------------------------------------------------module Data.MessagePack(- module Data.MessagePack.Assoc,- module Data.MessagePack.Pack,- module Data.MessagePack.Unpack,- module Data.MessagePack.Object,- module Data.MessagePack.Derive,- ) where--import Data.MessagePack.Assoc-import Data.MessagePack.Pack-import Data.MessagePack.Unpack-import Data.MessagePack.Object-import Data.MessagePack.Derive+-------------------------------------------------------------------- +-- | +-- Module : Data.MessagePack +-- Copyright : (c) Hideyuki Tanaka, 2009-2011 +-- License : BSD3 +-- +-- Maintainer: tanaka.hideyuki@gmail.com +-- Stability : experimental +-- Portability: portable +-- +-- Simple interface to pack and unpack MessagePack data. +-- +-------------------------------------------------------------------- + +module Data.MessagePack( + module Data.MessagePack.Assoc, + module Data.MessagePack.Pack, + module Data.MessagePack.Unpack, + module Data.MessagePack.Object, + module Data.MessagePack.Derive, + ) where + +import Data.MessagePack.Assoc +import Data.MessagePack.Pack +import Data.MessagePack.Unpack +import Data.MessagePack.Object +import Data.MessagePack.Derive
Data/MessagePack/Assoc.hs view
@@ -1,28 +1,28 @@-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}------------------------------------------------------------------------- |--- Module : Data.MessagePack.Assoc--- Copyright : (c) Daiki Handa, 2010-2011--- License : BSD3------ Maintainer: tanaka.hideyuki@gmail.com--- Stability : experimental--- Portability: portable------ MessagePack map labeling type--------------------------------------------------------------------------module Data.MessagePack.Assoc (- Assoc(..)- ) where--import Control.DeepSeq-import Data.Typeable---- not defined for general Functor for performance reason.--- (ie. you would want to write custom instances for each type using specialized mapM-like functions)-newtype Assoc a- = Assoc { unAssoc :: a }- deriving (Show, Eq, Ord, Typeable, NFData)+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} + +-------------------------------------------------------------------- +-- | +-- Module : Data.MessagePack.Assoc +-- Copyright : (c) Daiki Handa, 2010-2011 +-- License : BSD3 +-- +-- Maintainer: tanaka.hideyuki@gmail.com +-- Stability : experimental +-- Portability: portable +-- +-- MessagePack map labeling type +-- +-------------------------------------------------------------------- + +module Data.MessagePack.Assoc ( + Assoc(..) + ) where + +import Control.DeepSeq +import Data.Typeable + +-- not defined for general Functor for performance reason. +-- (ie. you would want to write custom instances for each type using specialized mapM-like functions) +newtype Assoc a + = Assoc { unAssoc :: a } + deriving (Show, Eq, Ord, Typeable, NFData)
Data/MessagePack/Derive.hs view
@@ -1,136 +1,136 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances #-}--module Data.MessagePack.Derive (- -- | deriving OBJECT- derivePack,- deriveUnpack,- deriveObject,- ) where--import Control.Monad-import Control.Monad.Error () -- MonadPlus instance for Either e-import Data.Char-import Data.List-import qualified Data.Text as T-import Language.Haskell.TH--import Data.MessagePack.Assoc-import Data.MessagePack.Pack-import Data.MessagePack.Unpack-import Data.MessagePack.Object--derivePack :: Bool -> Name -> Q [Dec]-derivePack asObject tyName = do- info <- reify tyName- d <- case info of- TyConI (DataD _ {- cxt -} name tyVars cons _ {- derivings -}) ->- instanceD (cx tyVars) (ct ''Packable name tyVars) $- [ funD 'from [ clause [] (normalB [e| \v -> $(caseE [| v |] (map alt cons)) |]) []]- ]-- _ -> error $ "cant derive Packable: " ++ show tyName- return [d]-- where- alt (NormalC conName elms) = do- vars <- replicateM (length elms) (newName "v")- match (conP conName $ map varP vars)- (normalB [| from $(tupE $ map varE vars) |])- []-- alt (RecC conName elms) = do- vars <- replicateM (length elms) (newName "v")- if asObject- then- match (conP conName $ map varP vars)- (normalB- [| from $ Assoc- $(listE [ [| ( $(return $ LitE $ StringL $ key conName fname) :: T.Text- , toObject $(varE v)) |]- | (v, (fname, _, _)) <- zip vars elms])- |])- []- else- match (conP conName $ map varP vars)- (normalB [| from $(tupE $ map varE vars) |])- []-- alt c = error $ "unsupported constructor: " ++ pprint c--deriveUnpack :: Bool -> Name -> Q [Dec]-deriveUnpack asObject tyName = do- info <- reify tyName- d <- case info of- TyConI (DataD _ {- cxt -} name tyVars cons _ {- derivings -}) ->- instanceD (cx tyVars) (ct ''Unpackable name tyVars) $- [ funD 'get [ clause [] (normalB (foldl1 (\x y -> [| $x `mplus` $y |]) $ map alt cons)) []]- ]-- _ -> error $ "cant derive Unpackable: " ++ show tyName- return [d]-- where- alt (NormalC conName elms) = do- vars <- replicateM (length elms) (newName "v")- doE [ bindS (tupP $ map varP vars) [| get |]- , noBindS [| return $(foldl appE (conE conName) $ map varE vars) |]- ]-- alt (RecC conName elms) = do- var <- newName "v"- vars <- replicateM (length elms) (newName "w")- if asObject- then- doE $ [ bindS (conP 'Assoc [varP var]) [| get |] ]- ++ zipWith (binds conName var) vars elms ++- [ noBindS [| return $(foldl appE (conE conName) $ map varE vars) |] ]- else- doE [ bindS (tupP $ map varP vars) [| get |]- , noBindS [| return $(foldl appE (conE conName) $ map varE vars) |]- ]-- alt c = error $ "unsupported constructor: " ++ pprint c-- binds conName var res (fname, _, _) =- bindS (varP res)- [| failN $ lookup ($(return $ LitE $ StringL $ key conName fname) :: T.Text)- $(varE var) |]--deriveObject :: Bool -> Name -> Q [Dec]-deriveObject asObject tyName = do- g <- derivePack asObject tyName- p <- deriveUnpack asObject tyName- info <- reify tyName- o <- case info of- TyConI (DataD _ {- cxt -} name tyVars cons _ {- derivings -}) ->- -- use default implement- instanceD (cx tyVars) (ct ''OBJECT name tyVars) []- _ -> error $ "cant derive Object: " ++ show tyName- return $ g ++ p ++ [o]--failN Nothing = mzero-failN (Just a) =- case tryFromObject a of- Left _ -> mzero- Right v -> return v--cx tyVars =- cxt [ classP cl [varT tv]- | cl <- [''Packable, ''Unpackable, ''OBJECT]- , PlainTV tv <- tyVars ]--ct tc tyName tyVars =- appT (conT tc) $ foldl appT (conT tyName) $- map (\(PlainTV n) -> varT n) tyVars--key conName fname- | (prefix ++ "_") `isPrefixOf` sFname && length sFname > length prefix + 1 =- drop (length prefix + 1) sFname - | prefix `isPrefixOf` sFname && length sFname > length prefix =- uncapital $ drop (length prefix) sFname- | otherwise = sFname- where- prefix = map toLower $ nameBase conName- sFname = nameBase fname- uncapital (c:cs) | isUpper c = toLower c : cs- uncapital cs = cs+{-# LANGUAGE TemplateHaskell, FlexibleInstances #-} + +module Data.MessagePack.Derive ( + -- | deriving OBJECT + derivePack, + deriveUnpack, + deriveObject, + ) where + +import Control.Monad +import Control.Monad.Error () -- MonadPlus instance for Either e +import Data.Char +import Data.List +import qualified Data.Text as T +import Language.Haskell.TH + +import Data.MessagePack.Assoc +import Data.MessagePack.Pack +import Data.MessagePack.Unpack +import Data.MessagePack.Object + +derivePack :: Bool -> Name -> Q [Dec] +derivePack asObject tyName = do + info <- reify tyName + d <- case info of + TyConI (DataD _ {- cxt -} name tyVars cons _ {- derivings -}) -> + instanceD (cx tyVars) (ct ''Packable name tyVars) $ + [ funD 'from [ clause [] (normalB [e| \v -> $(caseE [| v |] (map alt cons)) |]) []] + ] + + _ -> error $ "cant derive Packable: " ++ show tyName + return [d] + + where + alt (NormalC conName elms) = do + vars <- replicateM (length elms) (newName "v") + match (conP conName $ map varP vars) + (normalB [| from $(tupE $ map varE vars) |]) + [] + + alt (RecC conName elms) = do + vars <- replicateM (length elms) (newName "v") + if asObject + then + match (conP conName $ map varP vars) + (normalB + [| from $ Assoc + $(listE [ [| ( $(return $ LitE $ StringL $ key conName fname) :: T.Text + , toObject $(varE v)) |] + | (v, (fname, _, _)) <- zip vars elms]) + |]) + [] + else + match (conP conName $ map varP vars) + (normalB [| from $(tupE $ map varE vars) |]) + [] + + alt c = error $ "unsupported constructor: " ++ pprint c + +deriveUnpack :: Bool -> Name -> Q [Dec] +deriveUnpack asObject tyName = do + info <- reify tyName + d <- case info of + TyConI (DataD _ {- cxt -} name tyVars cons _ {- derivings -}) -> + instanceD (cx tyVars) (ct ''Unpackable name tyVars) $ + [ funD 'get [ clause [] (normalB (foldl1 (\x y -> [| $x `mplus` $y |]) $ map alt cons)) []] + ] + + _ -> error $ "cant derive Unpackable: " ++ show tyName + return [d] + + where + alt (NormalC conName elms) = do + vars <- replicateM (length elms) (newName "v") + doE [ bindS (tupP $ map varP vars) [| get |] + , noBindS [| return $(foldl appE (conE conName) $ map varE vars) |] + ] + + alt (RecC conName elms) = do + var <- newName "v" + vars <- replicateM (length elms) (newName "w") + if asObject + then + doE $ [ bindS (conP 'Assoc [varP var]) [| get |] ] + ++ zipWith (binds conName var) vars elms ++ + [ noBindS [| return $(foldl appE (conE conName) $ map varE vars) |] ] + else + doE [ bindS (tupP $ map varP vars) [| get |] + , noBindS [| return $(foldl appE (conE conName) $ map varE vars) |] + ] + + alt c = error $ "unsupported constructor: " ++ pprint c + + binds conName var res (fname, _, _) = + bindS (varP res) + [| failN $ lookup ($(return $ LitE $ StringL $ key conName fname) :: T.Text) + $(varE var) |] + +deriveObject :: Bool -> Name -> Q [Dec] +deriveObject asObject tyName = do + g <- derivePack asObject tyName + p <- deriveUnpack asObject tyName + info <- reify tyName + o <- case info of + TyConI (DataD _ {- cxt -} name tyVars cons _ {- derivings -}) -> + -- use default implement + instanceD (cx tyVars) (ct ''OBJECT name tyVars) [] + _ -> error $ "cant derive Object: " ++ show tyName + return $ g ++ p ++ [o] + +failN Nothing = mzero +failN (Just a) = + case tryFromObject a of + Left _ -> mzero + Right v -> return v + +cx tyVars = + cxt [ classP cl [varT tv] + | cl <- [''Packable, ''Unpackable, ''OBJECT] + , PlainTV tv <- tyVars ] + +ct tc tyName tyVars = + appT (conT tc) $ foldl appT (conT tyName) $ + map (\(PlainTV n) -> varT n) tyVars + +key conName fname + | (prefix ++ "_") `isPrefixOf` sFname && length sFname > length prefix + 1 = + drop (length prefix + 1) sFname + | prefix `isPrefixOf` sFname && length sFname > length prefix = + uncapital $ drop (length prefix) sFname + | otherwise = sFname + where + prefix = map toLower $ nameBase conName + sFname = nameBase fname + uncapital (c:cs) | isUpper c = toLower c : cs + uncapital cs = cs
Data/MessagePack/Internal/Utf8.hs view
@@ -1,28 +1,28 @@-module Data.MessagePack.Internal.Utf8 (- encodeUtf8,- decodeUtf8,- skipChar,- toLBS,- fromLBS,- ) where--import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Text.Encoding.Error as T--encodeUtf8 :: String -> B.ByteString-encodeUtf8 = T.encodeUtf8 . T.pack--decodeUtf8 :: B.ByteString -> String-decodeUtf8 = T.unpack . T.decodeUtf8With skipChar--skipChar :: T.OnDecodeError-skipChar _ _ = Nothing--toLBS :: B.ByteString -> BL.ByteString-toLBS bs = BL.fromChunks [bs]--fromLBS :: BL.ByteString -> B.ByteString-fromLBS = B.concat . BL.toChunks+module Data.MessagePack.Internal.Utf8 ( + encodeUtf8, + decodeUtf8, + skipChar, + toLBS, + fromLBS, + ) where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T + +encodeUtf8 :: String -> B.ByteString +encodeUtf8 = T.encodeUtf8 . T.pack + +decodeUtf8 :: B.ByteString -> String +decodeUtf8 = T.unpack . T.decodeUtf8With skipChar + +skipChar :: T.OnDecodeError +skipChar _ _ = Nothing + +toLBS :: B.ByteString -> BL.ByteString +toLBS bs = BL.fromChunks [bs] + +fromLBS :: BL.ByteString -> B.ByteString +fromLBS = B.concat . BL.toChunks
Data/MessagePack/Object.hs view
@@ -1,366 +1,366 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, IncoherentInstances #-}-{-# LANGUAGE DeriveDataTypeable #-}------------------------------------------------------------------------- |--- Module : Data.MessagePack.Object--- Copyright : (c) Hideyuki Tanaka, 2009-2011--- License : BSD3------ Maintainer: tanaka.hideyuki@gmail.com--- Stability : experimental--- Portability: portable------ MessagePack object definition--------------------------------------------------------------------------module Data.MessagePack.Object(- -- * MessagePack Object- Object(..),- - -- * Serialization to and from Object- OBJECT(..),- -- Result,- ) where--import Control.Applicative-import Control.DeepSeq-import Control.Exception-import Control.Monad-import qualified Data.Attoparsec as A-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import Data.Hashable-import qualified Data.HashMap.Strict as HM-import qualified Data.Map as M-import qualified Data.IntMap as IM-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Encoding as TL-import qualified Data.Vector as V-import Data.Typeable--import Data.MessagePack.Assoc-import Data.MessagePack.Pack-import Data.MessagePack.Unpack-import Data.MessagePack.Internal.Utf8---- | Object Representation of MessagePack data.-data Object- = ObjectNil- | ObjectBool Bool- | ObjectInteger Int- | ObjectFloat Float- | ObjectDouble Double- | ObjectRAW B.ByteString- | ObjectArray [Object]- | ObjectMap [(Object, Object)]- deriving (Show, Eq, Ord, Typeable) --instance NFData Object where- rnf obj =- case obj of- ObjectNil -> ()- ObjectBool b -> rnf b- ObjectInteger n -> rnf n- ObjectFloat f -> rnf f- ObjectDouble d -> rnf d- ObjectRAW bs -> bs `seq` ()- 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 ObjectFloat get- , liftM ObjectDouble get- , liftM ObjectRAW get- , liftM ObjectArray get- , liftM (ObjectMap . unAssoc) get- ]--instance Packable Object where- from obj =- case obj of- ObjectInteger n ->- from n- ObjectNil ->- from ()- ObjectBool b ->- from b- ObjectFloat f ->- from f- ObjectDouble d ->- from d- ObjectRAW raw ->- from raw- ObjectArray arr ->- from arr- ObjectMap m ->- from $ Assoc m---- | The class of types serializable to and from MessagePack object-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 -> a- fromObject a =- case tryFromObject a of- Left err ->- throw $ UnpackError err- Right ret ->- ret-- -- | Decode a value from MessagePack object- tryFromObject :: Object -> Either String a- tryFromObject = tryUnpack . pack--instance OBJECT Object where- toObject = id- tryFromObject = Right--tryFromObjectError :: Either String a-tryFromObjectError = Left "tryFromObject: cannot cast"--instance OBJECT () where- toObject = const ObjectNil- tryFromObject ObjectNil = Right ()- tryFromObject _ = tryFromObjectError--instance OBJECT Int where- toObject = ObjectInteger- tryFromObject (ObjectInteger n) = Right n- tryFromObject _ = tryFromObjectError--instance OBJECT Bool where- toObject = ObjectBool- tryFromObject (ObjectBool b) = Right b- tryFromObject _ = tryFromObjectError--instance OBJECT Double where- toObject = ObjectDouble- tryFromObject (ObjectDouble d) = Right d- tryFromObject _ = tryFromObjectError--instance OBJECT Float where- toObject = ObjectFloat- tryFromObject (ObjectFloat f) = Right f- tryFromObject _ = tryFromObjectError--instance OBJECT String where- toObject = toObject . encodeUtf8- tryFromObject obj = liftM decodeUtf8 $ tryFromObject obj--instance OBJECT B.ByteString where- toObject = ObjectRAW- tryFromObject (ObjectRAW bs) = Right bs- tryFromObject _ = tryFromObjectError--instance OBJECT BL.ByteString where- toObject = ObjectRAW . fromLBS- tryFromObject (ObjectRAW bs) = Right $ toLBS bs- tryFromObject _ = tryFromObjectError--instance OBJECT T.Text where- toObject = ObjectRAW . T.encodeUtf8- tryFromObject (ObjectRAW bs) = Right $ T.decodeUtf8With skipChar bs- tryFromObject _ = tryFromObjectError--instance OBJECT TL.Text where- toObject = ObjectRAW . fromLBS . TL.encodeUtf8- tryFromObject (ObjectRAW bs) = Right $ TL.decodeUtf8With skipChar $ toLBS bs- tryFromObject _ = tryFromObjectError--instance OBJECT a => OBJECT [a] where- toObject = ObjectArray . map toObject- 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 (Assoc [(a,b)]) where- toObject =- ObjectMap . map (\(a, b) -> (toObject a, toObject b)) . unAssoc- tryFromObject (ObjectMap mem) = do- Assoc <$> mapM (\(a, b) -> liftM2 (,) (tryFromObject a) (tryFromObject b)) mem- tryFromObject _ =- tryFromObjectError--instance (OBJECT a, OBJECT b) => OBJECT (Assoc (V.Vector (a,b))) where- toObject =- ObjectMap . V.toList . V.map (\(a, b) -> (toObject a, toObject b)) . unAssoc- tryFromObject (ObjectMap mem) = do- Assoc <$> V.mapM (\(a, b) -> liftM2 (,) (tryFromObject a) (tryFromObject b)) (V.fromList mem)- tryFromObject _ =- tryFromObjectError--instance (Ord a, OBJECT a, OBJECT b) => OBJECT (M.Map a b) where- toObject =- ObjectMap . map (\(a, b) -> (toObject a, toObject b)) . M.toList- tryFromObject (ObjectMap mem) = do- M.fromList <$> mapM (\(a, b) -> liftM2 (,) (tryFromObject a) (tryFromObject b)) mem- tryFromObject _ =- tryFromObjectError--instance OBJECT b => OBJECT (IM.IntMap b) where- toObject =- ObjectMap . map (\(a, b) -> (toObject a, toObject b)) . IM.toList- tryFromObject (ObjectMap mem) = do- IM.fromList <$> mapM (\(a, b) -> liftM2 (,) (tryFromObject a) (tryFromObject b)) mem- tryFromObject _ =- tryFromObjectError--instance (Hashable a, Eq a, OBJECT a, OBJECT b) => OBJECT (HM.HashMap a b) where- toObject =- ObjectMap . map (\(a, b) -> (toObject a, toObject b)) . HM.toList- tryFromObject (ObjectMap mem) = do- HM.fromList <$> 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- - tryFromObject ObjectNil = return Nothing- tryFromObject obj = liftM Just $ tryFromObject obj+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, IncoherentInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-------------------------------------------------------------------- +-- | +-- Module : Data.MessagePack.Object +-- Copyright : (c) Hideyuki Tanaka, 2009-2011 +-- License : BSD3 +-- +-- Maintainer: tanaka.hideyuki@gmail.com +-- Stability : experimental +-- Portability: portable +-- +-- MessagePack object definition +-- +-------------------------------------------------------------------- + +module Data.MessagePack.Object( + -- * MessagePack Object + Object(..), + + -- * Serialization to and from Object + OBJECT(..), + -- Result, + ) where + +import Control.Applicative +import Control.DeepSeq +import Control.Exception +import Control.Monad +import qualified Data.Attoparsec as A +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.Hashable +import qualified Data.HashMap.Strict as HM +import qualified Data.Map as M +import qualified Data.IntMap as IM +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import qualified Data.Vector as V +import Data.Typeable + +import Data.MessagePack.Assoc +import Data.MessagePack.Pack +import Data.MessagePack.Unpack +import Data.MessagePack.Internal.Utf8 + +-- | Object Representation of MessagePack data. +data Object + = ObjectNil + | ObjectBool Bool + | ObjectInteger Int + | ObjectFloat Float + | ObjectDouble Double + | ObjectRAW B.ByteString + | ObjectArray [Object] + | ObjectMap [(Object, Object)] + deriving (Show, Eq, Ord, Typeable) + +instance NFData Object where + rnf obj = + case obj of + ObjectNil -> () + ObjectBool b -> rnf b + ObjectInteger n -> rnf n + ObjectFloat f -> rnf f + ObjectDouble d -> rnf d + ObjectRAW bs -> bs `seq` () + 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 ObjectFloat get + , liftM ObjectDouble get + , liftM ObjectRAW get + , liftM ObjectArray get + , liftM (ObjectMap . unAssoc) get + ] + +instance Packable Object where + from obj = + case obj of + ObjectInteger n -> + from n + ObjectNil -> + from () + ObjectBool b -> + from b + ObjectFloat f -> + from f + ObjectDouble d -> + from d + ObjectRAW raw -> + from raw + ObjectArray arr -> + from arr + ObjectMap m -> + from $ Assoc m + +-- | The class of types serializable to and from MessagePack object +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 -> a + fromObject a = + case tryFromObject a of + Left err -> + throw $ UnpackError err + Right ret -> + ret + + -- | Decode a value from MessagePack object + tryFromObject :: Object -> Either String a + tryFromObject = tryUnpack . pack + +instance OBJECT Object where + toObject = id + tryFromObject = Right + +tryFromObjectError :: Either String a +tryFromObjectError = Left "tryFromObject: cannot cast" + +instance OBJECT () where + toObject = const ObjectNil + tryFromObject ObjectNil = Right () + tryFromObject _ = tryFromObjectError + +instance OBJECT Int where + toObject = ObjectInteger + tryFromObject (ObjectInteger n) = Right n + tryFromObject _ = tryFromObjectError + +instance OBJECT Bool where + toObject = ObjectBool + tryFromObject (ObjectBool b) = Right b + tryFromObject _ = tryFromObjectError + +instance OBJECT Double where + toObject = ObjectDouble + tryFromObject (ObjectDouble d) = Right d + tryFromObject _ = tryFromObjectError + +instance OBJECT Float where + toObject = ObjectFloat + tryFromObject (ObjectFloat f) = Right f + tryFromObject _ = tryFromObjectError + +instance OBJECT String where + toObject = toObject . encodeUtf8 + tryFromObject obj = liftM decodeUtf8 $ tryFromObject obj + +instance OBJECT B.ByteString where + toObject = ObjectRAW + tryFromObject (ObjectRAW bs) = Right bs + tryFromObject _ = tryFromObjectError + +instance OBJECT BL.ByteString where + toObject = ObjectRAW . fromLBS + tryFromObject (ObjectRAW bs) = Right $ toLBS bs + tryFromObject _ = tryFromObjectError + +instance OBJECT T.Text where + toObject = ObjectRAW . T.encodeUtf8 + tryFromObject (ObjectRAW bs) = Right $ T.decodeUtf8With skipChar bs + tryFromObject _ = tryFromObjectError + +instance OBJECT TL.Text where + toObject = ObjectRAW . fromLBS . TL.encodeUtf8 + tryFromObject (ObjectRAW bs) = Right $ TL.decodeUtf8With skipChar $ toLBS bs + tryFromObject _ = tryFromObjectError + +instance OBJECT a => OBJECT [a] where + toObject = ObjectArray . map toObject + 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 (Assoc [(a,b)]) where + toObject = + ObjectMap . map (\(a, b) -> (toObject a, toObject b)) . unAssoc + tryFromObject (ObjectMap mem) = do + Assoc <$> mapM (\(a, b) -> liftM2 (,) (tryFromObject a) (tryFromObject b)) mem + tryFromObject _ = + tryFromObjectError + +instance (OBJECT a, OBJECT b) => OBJECT (Assoc (V.Vector (a,b))) where + toObject = + ObjectMap . V.toList . V.map (\(a, b) -> (toObject a, toObject b)) . unAssoc + tryFromObject (ObjectMap mem) = do + Assoc <$> V.mapM (\(a, b) -> liftM2 (,) (tryFromObject a) (tryFromObject b)) (V.fromList mem) + tryFromObject _ = + tryFromObjectError + +instance (Ord a, OBJECT a, OBJECT b) => OBJECT (M.Map a b) where + toObject = + ObjectMap . map (\(a, b) -> (toObject a, toObject b)) . M.toList + tryFromObject (ObjectMap mem) = do + M.fromList <$> mapM (\(a, b) -> liftM2 (,) (tryFromObject a) (tryFromObject b)) mem + tryFromObject _ = + tryFromObjectError + +instance OBJECT b => OBJECT (IM.IntMap b) where + toObject = + ObjectMap . map (\(a, b) -> (toObject a, toObject b)) . IM.toList + tryFromObject (ObjectMap mem) = do + IM.fromList <$> mapM (\(a, b) -> liftM2 (,) (tryFromObject a) (tryFromObject b)) mem + tryFromObject _ = + tryFromObjectError + +instance (Hashable a, Eq a, OBJECT a, OBJECT b) => OBJECT (HM.HashMap a b) where + toObject = + ObjectMap . map (\(a, b) -> (toObject a, toObject b)) . HM.toList + tryFromObject (ObjectMap mem) = do + HM.fromList <$> 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 + + tryFromObject ObjectNil = return Nothing + tryFromObject obj = liftM Just $ tryFromObject obj
Data/MessagePack/Pack.hs view
@@ -1,221 +1,221 @@-{-# LANGUAGE FlexibleInstances, IncoherentInstances, TypeSynonymInstances #-}------------------------------------------------------------------------- |--- Module : Data.MessagePack.Pack--- Copyright : (c) Hideyuki Tanaka, 2009-2011--- 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 Blaze.ByteString.Builder-import Data.Bits-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import qualified Data.HashMap.Strict as HM-import qualified Data.Map as M-import qualified Data.IntMap as IM-import qualified Data.Monoid as Monoid-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Encoding as TL-import qualified Data.Vector as V-import Foreign-import qualified System.IO.Unsafe as SIU--import Data.MessagePack.Assoc-import Data.MessagePack.Internal.Utf8--(<>) :: Monoid.Monoid m => m -> m -> m-(<>) = Monoid.mappend---- | Serializable class-class Packable a where- -- | Serialize a value- from :: a -> Builder---- | Pack Haskell data to MessagePack string.-pack :: Packable a => a -> BL.ByteString-pack = toLazyByteString . from--instance Packable Int where- from n =- case n of- _ | n >= 0 && n <= 127 ->- fromWord8 $ fromIntegral n- _ | n >= -32 && n <= -1 ->- fromWord8 $ fromIntegral n- _ | n >= 0 && n < 0x100 ->- fromWord8 0xCC <>- fromWord8 (fromIntegral n)- _ | n >= 0 && n < 0x10000 ->- fromWord8 0xCD <>- fromWord16be (fromIntegral n)- _ | n >= 0 && n < 0x100000000 ->- fromWord8 0xCE <>- fromWord32be (fromIntegral n)- _ | n >= 0 ->- fromWord8 0xCF <>- fromWord64be (fromIntegral n)- _ | n >= -0x80 ->- fromWord8 0xD0 <>- fromWord8 (fromIntegral n)- _ | n >= -0x8000 ->- fromWord8 0xD1 <>- fromWord16be (fromIntegral n)- _ | n >= -0x80000000 ->- fromWord8 0xD2 <>- fromWord32be (fromIntegral n)- _ ->- fromWord8 0xD3 <>- fromWord64be (fromIntegral n)- -instance Packable () where- from _ = - fromWord8 0xC0--instance Packable Bool where- from True = fromWord8 0xC3- from False = fromWord8 0xC2--instance Packable Float where- from f =- fromWord8 0xCB <>- fromWord32be (cast f)--instance Packable Double where- from d =- fromWord8 0xCB <>- fromWord64be (cast d)--cast :: (Storable a, Storable b) => a -> b-cast v = SIU.unsafePerformIO $ with v $ peek . castPtr--instance Packable String where- from = fromString encodeUtf8 B.length fromByteString--instance Packable B.ByteString where- from = fromString id B.length fromByteString--instance Packable BL.ByteString where- from = fromString id (fromIntegral . BL.length) fromLazyByteString--instance Packable T.Text where- from = fromString T.encodeUtf8 B.length fromByteString--instance Packable TL.Text where- from = fromString TL.encodeUtf8 (fromIntegral . BL.length) fromLazyByteString--fromString :: (s -> t) -> (t -> Int) -> (t -> Builder) -> s -> Builder-fromString cnv lf pf str =- let bs = cnv str in- case lf bs of- len | len <= 31 ->- fromWord8 $ 0xA0 .|. fromIntegral len- len | len < 0x10000 ->- fromWord8 0xDA <>- fromWord16be (fromIntegral len)- len ->- fromWord8 0xDB <>- fromWord32be (fromIntegral len)- <> pf bs--instance Packable a => Packable [a] where- from = fromArray length (Monoid.mconcat . map from)--instance Packable a => Packable (V.Vector a) where- from = fromArray V.length (V.foldl (\a b -> a <> from b) Monoid.mempty)--instance (Packable a1, Packable a2) => Packable (a1, a2) where- from = fromArray (const 2) f where- f (a1, a2) = from a1 <> from a2--instance (Packable a1, Packable a2, Packable a3) => Packable (a1, a2, a3) where- from = fromArray (const 3) f where- f (a1, a2, a3) = from a1 <> from a2 <> from a3--instance (Packable a1, Packable a2, Packable a3, Packable a4) => Packable (a1, a2, a3, a4) where- from = fromArray (const 4) f where- f (a1, a2, a3, a4) = from a1 <> from a2 <> from a3 <> from a4--instance (Packable a1, Packable a2, Packable a3, Packable a4, Packable a5) => Packable (a1, a2, a3, a4, a5) where- from = fromArray (const 5) f where- f (a1, a2, a3, a4, a5) = from a1 <> from a2 <> from a3 <> from a4 <> from a5--instance (Packable a1, Packable a2, Packable a3, Packable a4, Packable a5, Packable a6) => Packable (a1, a2, a3, a4, a5, a6) where- from = fromArray (const 6) f where- f (a1, a2, a3, a4, a5, a6) = from a1 <> from a2 <> from a3 <> from a4 <> from a5 <> from 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- from = fromArray (const 7) f where- f (a1, a2, a3, a4, a5, a6, a7) = from a1 <> from a2 <> from a3 <> from a4 <> from a5 <> from a6 <> from 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- from = fromArray (const 8) f where- f (a1, a2, a3, a4, a5, a6, a7, a8) = from a1 <> from a2 <> from a3 <> from a4 <> from a5 <> from a6 <> from a7 <> from 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- from = fromArray (const 9) f where- f (a1, a2, a3, a4, a5, a6, a7, a8, a9) = from a1 <> from a2 <> from a3 <> from a4 <> from a5 <> from a6 <> from a7 <> from a8 <> from a9--fromArray :: (a -> Int) -> (a -> Builder) -> a -> Builder-fromArray lf pf arr = do- case lf arr of- len | len <= 15 ->- fromWord8 $ 0x90 .|. fromIntegral len- len | len < 0x10000 ->- fromWord8 0xDC <>- fromWord16be (fromIntegral len)- len ->- fromWord8 0xDD <>- fromWord32be (fromIntegral len)- <> pf arr--instance (Packable k, Packable v) => Packable (Assoc [(k,v)]) where- from = fromMap length (Monoid.mconcat . map fromPair) . unAssoc--instance (Packable k, Packable v) => Packable (Assoc (V.Vector (k,v))) where- from = fromMap V.length (V.foldl (\a b -> a <> fromPair b) Monoid.mempty) . unAssoc--instance (Packable k, Packable v) => Packable (M.Map k v) where- from = fromMap M.size (Monoid.mconcat . map fromPair . M.toList)--instance Packable v => Packable (IM.IntMap v) where- from = fromMap IM.size (Monoid.mconcat . map fromPair . IM.toList)--instance (Packable k, Packable v) => Packable (HM.HashMap k v) where- from = fromMap HM.size (Monoid.mconcat . map fromPair . HM.toList)--fromPair :: (Packable a, Packable b) => (a, b) -> Builder-fromPair (a, b) = from a <> from b--fromMap :: (a -> Int) -> (a -> Builder) -> a -> Builder-fromMap lf pf m =- case lf m of- len | len <= 15 ->- fromWord8 $ 0x80 .|. fromIntegral len- len | len < 0x10000 ->- fromWord8 0xDE <>- fromWord16be (fromIntegral len)- len ->- fromWord8 0xDF <>- fromWord32be (fromIntegral len)- <> pf m--instance Packable a => Packable (Maybe a) where- from Nothing = from ()- from (Just a) = from a+{-# LANGUAGE FlexibleInstances, IncoherentInstances, TypeSynonymInstances #-} + +-------------------------------------------------------------------- +-- | +-- Module : Data.MessagePack.Pack +-- Copyright : (c) Hideyuki Tanaka, 2009-2011 +-- 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 Blaze.ByteString.Builder +import Data.Bits +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.HashMap.Strict as HM +import qualified Data.Map as M +import qualified Data.IntMap as IM +import qualified Data.Monoid as Monoid +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import qualified Data.Vector as V +import Foreign +import qualified System.IO.Unsafe as SIU + +import Data.MessagePack.Assoc +import Data.MessagePack.Internal.Utf8 + +(<>) :: Monoid.Monoid m => m -> m -> m +(<>) = Monoid.mappend + +-- | Serializable class +class Packable a where + -- | Serialize a value + from :: a -> Builder + +-- | Pack Haskell data to MessagePack string. +pack :: Packable a => a -> BL.ByteString +pack = toLazyByteString . from + +instance Packable Int where + from n = + case n of + _ | n >= 0 && n <= 127 -> + fromWord8 $ fromIntegral n + _ | n >= -32 && n <= -1 -> + fromWord8 $ fromIntegral n + _ | n >= 0 && n < 0x100 -> + fromWord8 0xCC <> + fromWord8 (fromIntegral n) + _ | n >= 0 && n < 0x10000 -> + fromWord8 0xCD <> + fromWord16be (fromIntegral n) + _ | n >= 0 && n < 0x100000000 -> + fromWord8 0xCE <> + fromWord32be (fromIntegral n) + _ | n >= 0 -> + fromWord8 0xCF <> + fromWord64be (fromIntegral n) + _ | n >= -0x80 -> + fromWord8 0xD0 <> + fromWord8 (fromIntegral n) + _ | n >= -0x8000 -> + fromWord8 0xD1 <> + fromWord16be (fromIntegral n) + _ | n >= -0x80000000 -> + fromWord8 0xD2 <> + fromWord32be (fromIntegral n) + _ -> + fromWord8 0xD3 <> + fromWord64be (fromIntegral n) + +instance Packable () where + from _ = + fromWord8 0xC0 + +instance Packable Bool where + from True = fromWord8 0xC3 + from False = fromWord8 0xC2 + +instance Packable Float where + from f = + fromWord8 0xCB <> + fromWord32be (cast f) + +instance Packable Double where + from d = + fromWord8 0xCB <> + fromWord64be (cast d) + +cast :: (Storable a, Storable b) => a -> b +cast v = SIU.unsafePerformIO $ with v $ peek . castPtr + +instance Packable String where + from = fromString encodeUtf8 B.length fromByteString + +instance Packable B.ByteString where + from = fromString id B.length fromByteString + +instance Packable BL.ByteString where + from = fromString id (fromIntegral . BL.length) fromLazyByteString + +instance Packable T.Text where + from = fromString T.encodeUtf8 B.length fromByteString + +instance Packable TL.Text where + from = fromString TL.encodeUtf8 (fromIntegral . BL.length) fromLazyByteString + +fromString :: (s -> t) -> (t -> Int) -> (t -> Builder) -> s -> Builder +fromString cnv lf pf str = + let bs = cnv str in + case lf bs of + len | len <= 31 -> + fromWord8 $ 0xA0 .|. fromIntegral len + len | len < 0x10000 -> + fromWord8 0xDA <> + fromWord16be (fromIntegral len) + len -> + fromWord8 0xDB <> + fromWord32be (fromIntegral len) + <> pf bs + +instance Packable a => Packable [a] where + from = fromArray length (Monoid.mconcat . map from) + +instance Packable a => Packable (V.Vector a) where + from = fromArray V.length (V.foldl (\a b -> a <> from b) Monoid.mempty) + +instance (Packable a1, Packable a2) => Packable (a1, a2) where + from = fromArray (const 2) f where + f (a1, a2) = from a1 <> from a2 + +instance (Packable a1, Packable a2, Packable a3) => Packable (a1, a2, a3) where + from = fromArray (const 3) f where + f (a1, a2, a3) = from a1 <> from a2 <> from a3 + +instance (Packable a1, Packable a2, Packable a3, Packable a4) => Packable (a1, a2, a3, a4) where + from = fromArray (const 4) f where + f (a1, a2, a3, a4) = from a1 <> from a2 <> from a3 <> from a4 + +instance (Packable a1, Packable a2, Packable a3, Packable a4, Packable a5) => Packable (a1, a2, a3, a4, a5) where + from = fromArray (const 5) f where + f (a1, a2, a3, a4, a5) = from a1 <> from a2 <> from a3 <> from a4 <> from a5 + +instance (Packable a1, Packable a2, Packable a3, Packable a4, Packable a5, Packable a6) => Packable (a1, a2, a3, a4, a5, a6) where + from = fromArray (const 6) f where + f (a1, a2, a3, a4, a5, a6) = from a1 <> from a2 <> from a3 <> from a4 <> from a5 <> from 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 + from = fromArray (const 7) f where + f (a1, a2, a3, a4, a5, a6, a7) = from a1 <> from a2 <> from a3 <> from a4 <> from a5 <> from a6 <> from 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 + from = fromArray (const 8) f where + f (a1, a2, a3, a4, a5, a6, a7, a8) = from a1 <> from a2 <> from a3 <> from a4 <> from a5 <> from a6 <> from a7 <> from 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 + from = fromArray (const 9) f where + f (a1, a2, a3, a4, a5, a6, a7, a8, a9) = from a1 <> from a2 <> from a3 <> from a4 <> from a5 <> from a6 <> from a7 <> from a8 <> from a9 + +fromArray :: (a -> Int) -> (a -> Builder) -> a -> Builder +fromArray lf pf arr = do + case lf arr of + len | len <= 15 -> + fromWord8 $ 0x90 .|. fromIntegral len + len | len < 0x10000 -> + fromWord8 0xDC <> + fromWord16be (fromIntegral len) + len -> + fromWord8 0xDD <> + fromWord32be (fromIntegral len) + <> pf arr + +instance (Packable k, Packable v) => Packable (Assoc [(k,v)]) where + from = fromMap length (Monoid.mconcat . map fromPair) . unAssoc + +instance (Packable k, Packable v) => Packable (Assoc (V.Vector (k,v))) where + from = fromMap V.length (V.foldl (\a b -> a <> fromPair b) Monoid.mempty) . unAssoc + +instance (Packable k, Packable v) => Packable (M.Map k v) where + from = fromMap M.size (Monoid.mconcat . map fromPair . M.toList) + +instance Packable v => Packable (IM.IntMap v) where + from = fromMap IM.size (Monoid.mconcat . map fromPair . IM.toList) + +instance (Packable k, Packable v) => Packable (HM.HashMap k v) where + from = fromMap HM.size (Monoid.mconcat . map fromPair . HM.toList) + +fromPair :: (Packable a, Packable b) => (a, b) -> Builder +fromPair (a, b) = from a <> from b + +fromMap :: (a -> Int) -> (a -> Builder) -> a -> Builder +fromMap lf pf m = + case lf m of + len | len <= 15 -> + fromWord8 $ 0x80 .|. fromIntegral len + len | len < 0x10000 -> + fromWord8 0xDE <> + fromWord16be (fromIntegral len) + len -> + fromWord8 0xDF <> + fromWord32be (fromIntegral len) + <> pf m + +instance Packable a => Packable (Maybe a) where + from Nothing = from () + from (Just a) = from a
Data/MessagePack/Unpack.hs view
@@ -1,337 +1,337 @@-{-# LANGUAGE FlexibleInstances, IncoherentInstances, TypeSynonymInstances #-}-{-# LANGUAGE DeriveDataTypeable #-}------------------------------------------------------------------------- |--- Module : Data.MessagePack.Unpack--- Copyright : (c) Hideyuki Tanaka, 2009-2011--- 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.Applicative-import Control.Exception-import Control.Monad-import qualified Data.Attoparsec as A-import Data.Bits-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import Data.Hashable-import qualified Data.HashMap.Strict as HM-import qualified Data.Map as M-import qualified Data.IntMap as IM-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Encoding as TL-import Data.Int-import Data.Typeable-import qualified Data.Vector as V-import Data.Word-import Foreign-import qualified System.IO.Unsafe as SIU-import Text.Printf--import Data.MessagePack.Assoc-import Data.MessagePack.Internal.Utf8---- | 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 BL.ByteString where- toBS = B.concat . BL.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 Float where- get = do- c <- A.anyWord8- case c of- 0xCA -> do- bs <- A.take 4- return $! SIU.unsafePerformIO $ B.useAsCString (B.reverse bs) $ peek . castPtr- _ ->- fail $ printf "invlid float tag: 0x%02X" c--instance Unpackable Double where- get = do- c <- A.anyWord8- case c of- 0xCB -> do- bs <- A.take 8- return $! SIU.unsafePerformIO $ B.useAsCString (B.reverse bs) $ peek . castPtr- _ ->- fail $ printf "invlid double tag: 0x%02X" c--instance Unpackable String where- get = parseString (\n -> return . decodeUtf8 =<< A.take n)--instance Unpackable B.ByteString where- get = parseString A.take--instance Unpackable BL.ByteString where- get = parseString (\n -> return . toLBS =<< A.take n)--instance Unpackable T.Text where- get = parseString (\n -> return . T.decodeUtf8With skipChar =<< A.take n)--instance Unpackable TL.Text where- get = parseString (\n -> return . TL.decodeUtf8With skipChar . toLBS =<< A.take n)--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 %d" 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 %d" 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 %d" 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 %d" 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 %d" 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 %d" 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 %d" 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 %d" 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 (Assoc [(k,v)]) where- get = liftM Assoc $ parseMap (flip replicateM parsePair)--instance (Unpackable k, Unpackable v) => Unpackable (Assoc (V.Vector (k, v))) where- get = liftM Assoc $ parseMap (flip V.replicateM parsePair)--instance (Ord k, Unpackable k, Unpackable v) => Unpackable (M.Map k v) where- get = parseMap (\n -> M.fromList <$> replicateM n parsePair)--instance Unpackable v => Unpackable (IM.IntMap v) where- get = parseMap (\n -> IM.fromList <$> replicateM n parsePair)--instance (Hashable k, Eq k, Unpackable k, Unpackable v) => Unpackable (HM.HashMap k v) where- get = parseMap (\n -> HM.fromList <$> replicateM n 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+{-# LANGUAGE FlexibleInstances, IncoherentInstances, TypeSynonymInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-------------------------------------------------------------------- +-- | +-- Module : Data.MessagePack.Unpack +-- Copyright : (c) Hideyuki Tanaka, 2009-2011 +-- 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.Applicative +import Control.Exception +import Control.Monad +import qualified Data.Attoparsec as A +import Data.Bits +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.Hashable +import qualified Data.HashMap.Strict as HM +import qualified Data.Map as M +import qualified Data.IntMap as IM +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import Data.Int +import Data.Typeable +import qualified Data.Vector as V +import Data.Word +import Foreign +import qualified System.IO.Unsafe as SIU +import Text.Printf + +import Data.MessagePack.Assoc +import Data.MessagePack.Internal.Utf8 + +-- | 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 BL.ByteString where + toBS = B.concat . BL.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 "invalid integer tag: 0x%02X" c + +instance Unpackable () where + get = do + c <- A.anyWord8 + case c of + 0xC0 -> + return () + _ -> + fail $ printf "invalid 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 "invalid bool tag: 0x%02X" c + +instance Unpackable Float where + get = do + c <- A.anyWord8 + case c of + 0xCA -> do + bs <- A.take 4 + return $! SIU.unsafePerformIO $ B.useAsCString (B.reverse bs) $ peek . castPtr + _ -> + fail $ printf "invalid float tag: 0x%02X" c + +instance Unpackable Double where + get = do + c <- A.anyWord8 + case c of + 0xCB -> do + bs <- A.take 8 + return $! SIU.unsafePerformIO $ B.useAsCString (B.reverse bs) $ peek . castPtr + _ -> + fail $ printf "invalid double tag: 0x%02X" c + +instance Unpackable String where + get = parseString (\n -> return . decodeUtf8 =<< A.take n) + +instance Unpackable B.ByteString where + get = parseString A.take + +instance Unpackable BL.ByteString where + get = parseString (\n -> return . toLBS =<< A.take n) + +instance Unpackable T.Text where + get = parseString (\n -> return . T.decodeUtf8With skipChar =<< A.take n) + +instance Unpackable TL.Text where + get = parseString (\n -> return . TL.decodeUtf8With skipChar . toLBS =<< A.take n) + +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 "invalid 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 tuple size: expected 2 but got %d" 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 tuple size: expected 3 but got %d" 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 tuple size: expected 4 but got %d" 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 tuple size: expected 5 but got %d" 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 tuple size: expected 6 but got %d" 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 tuple size: expected 7 but got %d" 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 tuple size: expected 8 but got %d" 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 tuple size: expected 9 but got %d" 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 "invalid array tag: 0x%02X" c + +instance (Unpackable k, Unpackable v) => Unpackable (Assoc [(k,v)]) where + get = liftM Assoc $ parseMap (flip replicateM parsePair) + +instance (Unpackable k, Unpackable v) => Unpackable (Assoc (V.Vector (k, v))) where + get = liftM Assoc $ parseMap (flip V.replicateM parsePair) + +instance (Ord k, Unpackable k, Unpackable v) => Unpackable (M.Map k v) where + get = parseMap (\n -> M.fromList <$> replicateM n parsePair) + +instance Unpackable v => Unpackable (IM.IntMap v) where + get = parseMap (\n -> IM.fromList <$> replicateM n parsePair) + +instance (Hashable k, Eq k, Unpackable k, Unpackable v) => Unpackable (HM.HashMap k v) where + get = parseMap (\n -> HM.fromList <$> replicateM n 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 "invalid 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
LICENSE view
@@ -1,24 +1,24 @@-Copyright (c) 2009-2010, Hideyuki Tanaka-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:- * Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.- * Redistributions in binary form must reproduce the above copyright- notice, this list of conditions and the following disclaimer in the- documentation and/or other materials provided with the distribution.- * Neither the name of the Hideyuki Tanaka nor the- names of its contributors may be used to endorse or promote products- derived from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY Hideyuki Tanaka ''AS IS'' AND ANY-EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED-WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE-DISCLAIMED. IN NO EVENT SHALL <copyright holder> BE LIABLE FOR ANY-DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES-(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;-LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND-ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS-SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+Copyright (c) 2009-2010, Hideyuki Tanaka +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of the Hideyuki Tanaka nor the + names of its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY Hideyuki Tanaka ''AS IS'' AND ANY +EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL <copyright holder> BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Setup.lhs view
@@ -1,3 +1,3 @@-#!/usr/bin/env runhaskell-> import Distribution.Simple-> main = defaultMain+#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain
msgpack.cabal view
@@ -1,54 +1,55 @@-Name: msgpack-Version: 0.7.1.4-Synopsis: A Haskell implementation of MessagePack-Description: A Haskell implementation of MessagePack <http://msgpack.org/>-Homepage: http://msgpack.org/-License: BSD3-License-File: LICENSE-Author: Hideyuki Tanaka-Maintainer: Hideyuki Tanaka <tanaka.hideyuki@gmail.com>-Copyright: Copyright (c) 2009-2011, Hideyuki Tanaka-Category: Data-Stability: Experimental-Cabal-Version: >= 1.8-Build-Type: Simple--Source-repository head- Type: git- Location: git://github.com/msgpack/msgpack-haskell.git--Library- Build-depends: base == 4.*- , mtl == 2.0.*- , bytestring == 0.9.*- , text == 0.11.*- , containers == 0.4.*- , unordered-containers >= 0.1 && < 0.3- , hashable- , vector >= 0.7 && < 0.10- , attoparsec >= 0.8 && < 0.11- , blaze-builder >= 0.3 && < 0.4- , deepseq >= 1.1 && <1.4- , template-haskell >= 2.4 && < 2.8-- Ghc-options: -Wall-- Exposed-modules: Data.MessagePack- Data.MessagePack.Assoc- Data.MessagePack.Pack- Data.MessagePack.Unpack- Data.MessagePack.Object- Data.MessagePack.Derive- Data.MessagePack.Internal.Utf8--Test-suite msgpack-tests- Type: exitcode-stdio-1.0- Hs-source-dirs: test- Main-is: Test.hs-- Build-depends: base == 4.*- , bytestring == 0.9.*- , QuickCheck == 2.4.*- , test-framework == 0.5.*- , test-framework-quickcheck2 == 0.2.*- , msgpack+Name: msgpack +Version: 0.7.1.5 +Synopsis: A Haskell implementation of MessagePack +Description: A Haskell implementation of MessagePack <http://msgpack.org/> +Homepage: http://msgpack.org/ +License: BSD3 +License-File: LICENSE +Author: Hideyuki Tanaka +Maintainer: Hideyuki Tanaka <tanaka.hideyuki@gmail.com> +Copyright: Copyright (c) 2009-2011, Hideyuki Tanaka +Category: Data +Stability: Experimental +Cabal-Version: >= 1.8 +Build-Type: Simple + +Source-repository head + Type: git + Location: git://github.com/msgpack/msgpack-haskell.git + +Library + Build-depends: base == 4.* + , ghc-prim >= 0.2 + , mtl >= 2.0 + , bytestring == 0.9.* + , text == 0.11.* + , containers >= 0.4 + , unordered-containers >= 0.1 && < 0.3 + , hashable + , vector >= 0.7 && < 0.10 + , attoparsec >= 0.8 && < 0.11 + , blaze-builder >= 0.3 && < 0.4 + , deepseq >= 1.1 && < 1.4 + , template-haskell >= 2.4 && < 2.8 + + Ghc-options: -Wall + + Exposed-modules: Data.MessagePack + Data.MessagePack.Assoc + Data.MessagePack.Pack + Data.MessagePack.Unpack + Data.MessagePack.Object + Data.MessagePack.Derive + Data.MessagePack.Internal.Utf8 + +Test-suite msgpack-tests + Type: exitcode-stdio-1.0 + Hs-source-dirs: test + Main-is: Test.hs + + Build-depends: base == 4.* + , bytestring == 0.9.* + , QuickCheck == 2.4.* + , test-framework >= 0.5 + , test-framework-quickcheck2 >= 0.2.12 + , msgpack
test/Test.hs view
@@ -1,70 +1,70 @@-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--instance Arbitrary a => Arbitrary (Assoc a) where- arbitrary = liftM Assoc arbitrary--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_list_int_double a = a == mid a- where types = a :: [(Int, Double)]-prop_mid_list_string_string a = a == mid a- where types = a :: [(String, String)]-prop_mid_map_string_int a = a == mid a- where types = a :: Assoc [(String,Int)]--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_list_int_double- , testProperty "[(string, string)]" prop_mid_list_string_string- , testProperty "Assoc [(string, int)]" prop_mid_map_string_int- ]- ]--main = defaultMain tests+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 + +instance Arbitrary a => Arbitrary (Assoc a) where + arbitrary = liftM Assoc arbitrary + +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_list_int_double a = a == mid a + where types = a :: [(Int, Double)] +prop_mid_list_string_string a = a == mid a + where types = a :: [(String, String)] +prop_mid_map_string_int a = a == mid a + where types = a :: Assoc [(String,Int)] + +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_list_int_double + , testProperty "[(string, string)]" prop_mid_list_string_string + , testProperty "Assoc [(string, int)]" prop_mid_map_string_int + ] + ] + +main = defaultMain tests