msgpack 0.7.1.5 → 0.7.2.5
raw patch · 11 files changed
+1250/−1246 lines, 11 filesdep ~QuickCheckdep ~bytestringdep ~template-haskellsetup-changed
Dependency ranges changed: QuickCheck, bytestring, template-haskell, vector
Files
- Data/MessagePack.hs +27/−27
- Data/MessagePack/Assoc.hs +28/−28
- Data/MessagePack/Derive.hs +140/−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 +6/−6
- 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,140 @@-{-# 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 _ _ {- derivings -}) ->+ -- use default implement+ instanceD (cx tyVars) (ct ''OBJECT name tyVars) []+ _ -> error $ "cant derive Object: " ++ show tyName+ return $ g ++ p ++ [o]++failN :: (MonadPlus m, OBJECT a) => Maybe Object -> m a+failN Nothing = mzero+failN (Just a) =+ case tryFromObject a of+ Left _ -> mzero+ Right v -> return v++cx :: [TyVarBndr] -> CxtQ+cx tyVars =+ cxt [ classP cl [varT tv]+ | cl <- [''Packable, ''Unpackable, ''OBJECT]+ , PlainTV tv <- tyVars ]++ct :: Name -> Name -> [TyVarBndr] -> TypeQ+ct tc tyName tyVars =+ appT (conT tc) $ foldl appT (conT tyName) $+ map (\(PlainTV n) -> varT n) tyVars++key :: Name -> Name -> [Char]+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 "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 +{-# 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,5 +1,5 @@ Name: msgpack -Version: 0.7.1.5 +Version: 0.7.2.5 Synopsis: A Haskell implementation of MessagePack Description: A Haskell implementation of MessagePack <http://msgpack.org/> Homepage: http://msgpack.org/ @@ -21,16 +21,16 @@ Build-depends: base == 4.* , ghc-prim >= 0.2 , mtl >= 2.0 - , bytestring == 0.9.* + , bytestring == 0.10.* , text == 0.11.* , containers >= 0.4 , unordered-containers >= 0.1 && < 0.3 , hashable - , vector >= 0.7 && < 0.10 + , vector >= 0.7 && < 0.11 , attoparsec >= 0.8 && < 0.11 , blaze-builder >= 0.3 && < 0.4 , deepseq >= 1.1 && < 1.4 - , template-haskell >= 2.4 && < 2.8 + , template-haskell >= 2.4 && < 2.9 Ghc-options: -Wall @@ -48,8 +48,8 @@ Main-is: Test.hs Build-depends: base == 4.* - , bytestring == 0.9.* - , QuickCheck == 2.4.* + , bytestring == 0.10.* + , QuickCheck == 2.5.* , 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