msgpack 0.7.2.5 → 1.0.0
raw patch · 15 files changed
+729/−1272 lines, 15 filesdep +binarydep +data-binary-ieee754dep +tastydep −attoparsecdep −ghc-primdep −template-haskelldep ~QuickCheckdep ~basedep ~blaze-builder
Dependencies added: binary, data-binary-ieee754, tasty, tasty-quickcheck
Dependencies removed: attoparsec, ghc-prim, template-haskell, test-framework, test-framework-quickcheck2
Dependency ranges changed: QuickCheck, base, blaze-builder, bytestring, containers, deepseq, hashable, mtl, text, unordered-containers, vector
Files
- Data/MessagePack.hs +0/−27
- Data/MessagePack/Assoc.hs +0/−28
- Data/MessagePack/Derive.hs +0/−140
- Data/MessagePack/Internal/Utf8.hs +0/−28
- Data/MessagePack/Object.hs +0/−366
- Data/MessagePack/Pack.hs +0/−221
- Data/MessagePack/Unpack.hs +0/−337
- msgpack.cabal +55/−55
- src/Data/MessagePack.hs +42/−0
- src/Data/MessagePack/Assoc.hs +29/−0
- src/Data/MessagePack/Get.hs +137/−0
- src/Data/MessagePack/Object.hs +274/−0
- src/Data/MessagePack/Put.hs +128/−0
- test/Test.hs +0/−70
- test/test.hs +64/−0
− Data/MessagePack.hs
@@ -1,27 +0,0 @@------------------------------------------------------------------------ |--- 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
@@ -1,28 +0,0 @@-{-# 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
@@ -1,140 +0,0 @@-{-# 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
@@ -1,28 +0,0 @@-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
@@ -1,366 +0,0 @@-{-# 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
@@ -1,221 +0,0 @@-{-# 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
@@ -1,337 +0,0 @@-{-# 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
msgpack.cabal view
@@ -1,55 +1,55 @@-Name: msgpack -Version: 0.7.2.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.10.* - , text == 0.11.* - , containers >= 0.4 - , unordered-containers >= 0.1 && < 0.3 - , hashable - , 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.9 - - 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.10.* - , QuickCheck == 2.5.* - , test-framework >= 0.5 - , test-framework-quickcheck2 >= 0.2.12 - , msgpack +name: msgpack+version: 1.0.0+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-2015, Hideyuki Tanaka+category: Data+stability: Experimental+cabal-version: >= 1.10+build-type: Simple++source-repository head+ type: git+ location: git://github.com/msgpack/msgpack-haskell.git++library+ default-language: Haskell2010+ hs-source-dirs: src++ exposed-modules: Data.MessagePack+ Data.MessagePack.Assoc+ Data.MessagePack.Object+ Data.MessagePack.Get+ Data.MessagePack.Put++ build-depends: base ==4.*+ , mtl >=2.2+ , bytestring >=0.10+ , text >=1.2+ , containers >=0.5.5+ , unordered-containers >=0.2.5+ , hashable+ , vector >=0.10+ , blaze-builder >=0.4+ , deepseq >=1.3+ , binary >=0.7+ , data-binary-ieee754++test-suite msgpack-tests+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: test++ main-is: test.hs++ build-depends: base+ , bytestring+ , QuickCheck >=2.8+ , tasty >=0.10+ , tasty-quickcheck >=0.8+ , msgpack
+ src/Data/MessagePack.hs view
@@ -0,0 +1,42 @@+--------------------------------------------------------------------+-- |+-- Module : Data.MessagePack+-- Copyright : (c) Hideyuki Tanaka, 2009-2015+-- License : BSD3+--+-- Maintainer: tanaka.hideyuki@gmail.com+-- Stability : experimental+-- Portability: portable+--+-- Simple interface to pack and unpack MessagePack data.+--+--------------------------------------------------------------------++module Data.MessagePack (+ -- * Simple interface to pack and unpack msgpack binary+ pack, unpack,++ -- * Re-export modules+ -- $reexports+ -- module X,+ module Data.MessagePack.Assoc,+ module Data.MessagePack.Get,+ module Data.MessagePack.Object,+ module Data.MessagePack.Put,+ ) where++import Data.Binary+import qualified Data.ByteString.Lazy as L++import Data.MessagePack.Assoc+import Data.MessagePack.Get+import Data.MessagePack.Object+import Data.MessagePack.Put++-- | Pack a Haskell value to MessagePack binary.+pack :: MessagePack a => a -> L.ByteString+pack = encode . toObject++-- | Unpack MessagePack binary to a Haskell value. If it fails, it returns Nothing.+unpack :: MessagePack a => L.ByteString -> Maybe a+unpack = fromObject . decode
+ src/Data/MessagePack/Assoc.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE 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)
+ src/Data/MessagePack/Get.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE LambdaCase #-}++--------------------------------------------------------------------+-- |+-- Module : Data.MessagePack.Get+-- Copyright : (c) Hideyuki Tanaka, 2009-2015+-- License : BSD3+--+-- Maintainer: tanaka.hideyuki@gmail.com+-- Stability : experimental+-- Portability: portable+--+-- MessagePack Deserializer using @Data.Binary@+--+--------------------------------------------------------------------++module Data.MessagePack.Get(+ getNil, getBool, getInt, getFloat, getDouble,+ getStr, getBin, getArray, getMap, getExt,+ ) where++import Control.Applicative+import Control.Monad+import Data.Binary+import Data.Binary.Get+import Data.Binary.IEEE754+import Data.Bits+import qualified Data.ByteString as S+import Data.Int+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Vector as V++getNil :: Get ()+getNil = tag 0xC0++getBool :: Get Bool+getBool =+ False <$ tag 0xC2 <|>+ True <$ tag 0xC3++getInt :: Get Int+getInt =+ getWord8 >>= \case+ c | c .&. 0x80 == 0x00 ->+ return $ fromIntegral c+ | c .&. 0xE0 == 0xE0 ->+ return $ fromIntegral (fromIntegral c :: Int8)+ 0xCC -> fromIntegral <$> getWord8+ 0xCD -> fromIntegral <$> getWord16be+ 0xCE -> fromIntegral <$> getWord32be+ 0xCF -> fromIntegral <$> getWord64be+ 0xD0 -> fromIntegral <$> getInt8+ 0xD1 -> fromIntegral <$> getInt16be+ 0xD2 -> fromIntegral <$> getInt32be+ 0xD3 -> fromIntegral <$> getInt64be+ _ -> empty++getFloat :: Get Float+getFloat = tag 0xCA >> getFloat32be++getDouble :: Get Double+getDouble = tag 0xCB >> getFloat64be++getStr :: Get T.Text+getStr = do+ len <- getWord8 >>= \case+ t | t .&. 0xE0 == 0xA0 ->+ return $ fromIntegral $ t .&. 0x1F+ 0xD9 -> fromIntegral <$> getWord8+ 0xDA -> fromIntegral <$> getWord16be+ 0xDB -> fromIntegral <$> getWord32be+ _ -> empty+ bs <- getByteString len+ case T.decodeUtf8' bs of+ Left _ -> empty+ Right v -> return v++getBin :: Get S.ByteString+getBin = do+ len <- getWord8 >>= \case+ 0xC4 -> fromIntegral <$> getWord8+ 0xC5 -> fromIntegral <$> getWord16be+ 0xC6 -> fromIntegral <$> getWord32be+ _ -> empty+ getByteString len++getArray :: Get a -> Get (V.Vector a)+getArray g = do+ len <- getWord8 >>= \case+ t | t .&. 0xF0 == 0x90 ->+ return $ fromIntegral $ t .&. 0x0F+ 0xDC -> fromIntegral <$> getWord16be+ 0xDD -> fromIntegral <$> getWord32be+ _ -> empty+ V.replicateM len g++getMap :: Get a -> Get b -> Get (V.Vector (a, b))+getMap k v = do+ len <- getWord8 >>= \case+ t | t .&. 0xF0 == 0x80 ->+ return $ fromIntegral $ t .&. 0x0F+ 0xDE -> fromIntegral <$> getWord16be+ 0xDF -> fromIntegral <$> getWord32be+ _ -> empty+ V.replicateM len $ (,) <$> k <*> v++getExt :: Get (Word8, S.ByteString)+getExt = do+ len <- getWord8 >>= \case+ 0xD4 -> return 1+ 0xD5 -> return 2+ 0xD6 -> return 4+ 0xD7 -> return 8+ 0xD8 -> return 16+ 0xC7 -> fromIntegral <$> getWord8+ 0xC8 -> fromIntegral <$> getWord16be+ 0xC9 -> fromIntegral <$> getWord32be+ _ -> empty+ (,) <$> getWord8 <*> getByteString len++getInt8 :: Get Int8+getInt8 = fromIntegral <$> getWord8++getInt16be :: Get Int16+getInt16be = fromIntegral <$> getWord16be++getInt32be :: Get Int32+getInt32be = fromIntegral <$> getWord32be++getInt64be :: Get Int64+getInt64be = fromIntegral <$> getWord64be++tag :: Word8 -> Get ()+tag t = do+ b <- getWord8+ guard $ t == b
+ src/Data/MessagePack/Object.hs view
@@ -0,0 +1,274 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE TypeSynonymInstances #-}++--------------------------------------------------------------------+-- |+-- Module : Data.MessagePack.Object+-- Copyright : (c) Hideyuki Tanaka, 2009-2015+-- License : BSD3+--+-- Maintainer: tanaka.hideyuki@gmail.com+-- Stability : experimental+-- Portability: portable+--+-- MessagePack object definition+--+--------------------------------------------------------------------++module Data.MessagePack.Object(+ -- * MessagePack Object+ Object(..),++ -- * MessagePack Serializable Types+ MessagePack(..),+ ) where++import Control.Applicative+import Control.Arrow+import Control.DeepSeq+import Data.Binary+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import Data.Hashable+import qualified Data.HashMap.Strict as HashMap+import qualified Data.IntMap.Strict as IntMap+import qualified Data.Map as Map+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import Data.Typeable+import qualified Data.Vector as V++import Data.MessagePack.Assoc+import Data.MessagePack.Get+import Data.MessagePack.Put++import Prelude hiding (putStr)++-- | Object Representation of MessagePack data.+data Object+ = ObjectNil+ -- ^ represents nil+ | ObjectBool !Bool+ -- ^ represents true or false+ | ObjectInt {-# UNPACK #-} !Int+ -- ^ represents an integer+ | ObjectFloat {-# UNPACK #-} !Float+ -- ^ represents a floating point number+ | ObjectDouble {-# UNPACK #-} !Double+ -- ^ represents a floating point number+ | ObjectStr !T.Text+ -- ^ extending Raw type represents a UTF-8 string+ | ObjectBin !S.ByteString+ -- ^ extending Raw type represents a byte array+ | ObjectArray !(V.Vector Object)+ -- ^ represents a sequence of objects+ | ObjectMap !(V.Vector (Object, Object))+ -- ^ represents key-value pairs of objects+ | ObjectExt {-# UNPACK #-} !Word8 !S.ByteString+ -- ^ represents a tuple of an integer and a byte array where+ -- the integer represents type information and the byte array represents data.+ deriving (Show, Eq, Ord, Typeable)++instance NFData Object where+ rnf obj = case obj of+ ObjectArray a -> rnf a+ ObjectMap m -> rnf m+ _ -> ()++getObject :: Get Object+getObject =+ ObjectNil <$ getNil+ <|> ObjectBool <$> getBool+ <|> ObjectInt <$> getInt+ <|> ObjectFloat <$> getFloat+ <|> ObjectDouble <$> getDouble+ <|> ObjectStr <$> getStr+ <|> ObjectBin <$> getBin+ <|> ObjectArray <$> getArray getObject+ <|> ObjectMap <$> getMap getObject getObject+ <|> uncurry ObjectExt <$> getExt++putObject :: Object -> Put+putObject = \case+ ObjectNil -> putNil+ ObjectBool b -> putBool b+ ObjectInt n -> putInt n+ ObjectFloat f -> putFloat f+ ObjectDouble d -> putDouble d+ ObjectStr t -> putStr t+ ObjectBin b -> putBin b+ ObjectArray a -> putArray putObject a+ ObjectMap m -> putMap putObject putObject m+ ObjectExt b r -> putExt b r++instance Binary Object where+ get = getObject+ put = putObject++class MessagePack a where+ toObject :: a -> Object+ fromObject :: Object -> Maybe a++-- core instances++instance MessagePack Object where+ toObject = id+ fromObject = Just++instance MessagePack () where+ toObject _ = ObjectNil+ fromObject = \case+ ObjectNil -> Just ()+ _ -> Nothing++instance MessagePack Int where+ toObject = ObjectInt+ fromObject = \case+ ObjectInt n -> Just n+ _ -> Nothing++instance MessagePack Bool where+ toObject = ObjectBool+ fromObject = \case+ ObjectBool b -> Just b+ _ -> Nothing++instance MessagePack Float where+ toObject = ObjectFloat+ fromObject = \case+ ObjectInt n -> Just $ fromIntegral n+ ObjectFloat f -> Just f+ ObjectDouble d -> Just $ realToFrac d+ _ -> Nothing++instance MessagePack Double where+ toObject = ObjectDouble+ fromObject = \case+ ObjectInt n -> Just $ fromIntegral n+ ObjectFloat f -> Just $ realToFrac f+ ObjectDouble d -> Just d+ _ -> Nothing++instance MessagePack S.ByteString where+ toObject = ObjectBin+ fromObject = \case+ ObjectBin r -> Just r+ _ -> Nothing++-- Because of overlapping instance, this must be above [a]+instance MessagePack String where+ toObject = toObject . T.pack+ fromObject obj = T.unpack <$> fromObject obj++instance MessagePack a => MessagePack (V.Vector a) where+ toObject = ObjectArray . V.map toObject+ fromObject = \case+ ObjectArray xs -> V.mapM fromObject xs+ _ -> Nothing++instance (MessagePack a, MessagePack b) => MessagePack (Assoc (V.Vector (a, b))) where+ toObject (Assoc xs) = ObjectMap $ V.map (toObject *** toObject) xs+ fromObject = \case+ ObjectMap xs ->+ Assoc <$> V.mapM (\(k, v) -> (,) <$> fromObject k <*> fromObject v) xs+ _ ->+ Nothing++-- util instances++-- nullable++instance MessagePack a => MessagePack (Maybe a) where+ toObject = \case+ Just a -> toObject a+ Nothing -> ObjectNil++ fromObject = \case+ ObjectNil -> Just Nothing+ obj -> fromObject obj++-- UTF8 string like++instance MessagePack L.ByteString where+ toObject = ObjectBin . L.toStrict+ fromObject obj = L.fromStrict <$> fromObject obj++instance MessagePack T.Text where+ toObject = ObjectStr+ fromObject = \case+ ObjectStr s -> Just s+ _ -> Nothing++instance MessagePack LT.Text where+ toObject = toObject . LT.toStrict+ fromObject obj = LT.fromStrict <$> fromObject obj++-- array like++instance MessagePack a => MessagePack [a] where+ toObject = toObject . V.fromList+ fromObject obj = V.toList <$> fromObject obj++-- map like++instance (MessagePack k, MessagePack v) => MessagePack (Assoc [(k, v)]) where+ toObject = toObject . Assoc . V.fromList . unAssoc+ fromObject obj = Assoc . V.toList . unAssoc <$> fromObject obj++instance (MessagePack k, MessagePack v, Ord k) => MessagePack (Map.Map k v) where+ toObject = toObject . Assoc . Map.toList+ fromObject obj = Map.fromList . unAssoc <$> fromObject obj++instance MessagePack v => MessagePack (IntMap.IntMap v) where+ toObject = toObject . Assoc . IntMap.toList+ fromObject obj = IntMap.fromList . unAssoc <$> fromObject obj++instance (MessagePack k, MessagePack v, Hashable k, Eq k) => MessagePack (HashMap.HashMap k v) where+ toObject = toObject . Assoc . HashMap.toList+ fromObject obj = HashMap.fromList . unAssoc <$> fromObject obj++-- tuples++instance (MessagePack a1, MessagePack a2) => MessagePack (a1, a2) where+ toObject (a1, a2) = ObjectArray [toObject a1, toObject a2]+ fromObject (ObjectArray [a1, a2]) = (,) <$> fromObject a1 <*> fromObject a2+ fromObject _ = Nothing++instance (MessagePack a1, MessagePack a2, MessagePack a3) => MessagePack (a1, a2, a3) where+ toObject (a1, a2, a3) = ObjectArray [toObject a1, toObject a2, toObject a3]+ fromObject (ObjectArray [a1, a2, a3]) = (,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3+ fromObject _ = Nothing++instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4) => MessagePack (a1, a2, a3, a4) where+ toObject (a1, a2, a3, a4) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4]+ fromObject (ObjectArray [a1, a2, a3, a4]) = (,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4+ fromObject _ = Nothing++instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4, MessagePack a5) => MessagePack (a1, a2, a3, a4, a5) where+ toObject (a1, a2, a3, a4, a5) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5]+ fromObject (ObjectArray [a1, a2, a3, a4, a5]) = (,,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 <*> fromObject a5+ fromObject _ = Nothing++instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4, MessagePack a5, MessagePack a6) => MessagePack (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]+ fromObject (ObjectArray [a1, a2, a3, a4, a5, a6]) = (,,,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 <*> fromObject a5 <*> fromObject a6+ fromObject _ = Nothing++instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4, MessagePack a5, MessagePack a6, MessagePack a7) => MessagePack (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]+ fromObject (ObjectArray [a1, a2, a3, a4, a5, a6, a7]) = (,,,,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 <*> fromObject a5 <*> fromObject a6 <*> fromObject a7+ fromObject _ = Nothing++instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4, MessagePack a5, MessagePack a6, MessagePack a7, MessagePack a8) => MessagePack (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]+ fromObject (ObjectArray [a1, a2, a3, a4, a5, a6, a7, a8]) = (,,,,,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 <*> fromObject a5 <*> fromObject a6 <*> fromObject a7 <*> fromObject a8+ fromObject _ = Nothing++instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4, MessagePack a5, MessagePack a6, MessagePack a7, MessagePack a8, MessagePack a9) => MessagePack (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]+ fromObject (ObjectArray [a1, a2, a3, a4, a5, a6, a7, a8, a9]) = (,,,,,,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 <*> fromObject a5 <*> fromObject a6 <*> fromObject a7 <*> fromObject a8 <*> fromObject a9+ fromObject _ = Nothing
+ src/Data/MessagePack/Put.hs view
@@ -0,0 +1,128 @@+--------------------------------------------------------------------+-- |+-- Module : Data.MessagePack.Put+-- Copyright : (c) Hideyuki Tanaka, 2009-2015+-- License : BSD3+--+-- Maintainer: tanaka.hideyuki@gmail.com+-- Stability : experimental+-- Portability: portable+--+-- MessagePack Serializer using @Data.Binary@+--+--------------------------------------------------------------------++module Data.MessagePack.Put (+ putNil, putBool, putInt, putFloat, putDouble,+ putStr, putBin, putArray, putMap, putExt,+ ) where++import Data.Binary+import Data.Binary.IEEE754+import Data.Binary.Put+import Data.Bits+import qualified Data.ByteString as S+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Vector as V++import Prelude hiding (putStr)++putNil :: Put+putNil = putWord8 0xC0++putBool :: Bool -> Put+putBool False = putWord8 0xC2+putBool True = putWord8 0xC3++putInt :: Int -> Put+putInt n+ | -32 <= n && n <= 127 =+ putWord8 $ fromIntegral n+ | 0 <= n && n < 0x100 =+ putWord8 0xCC >> putWord8 (fromIntegral n)+ | 0 <= n && n < 0x10000 =+ putWord8 0xCD >> putWord16be (fromIntegral n)+ | 0 <= n && n < 0x100000000 =+ putWord8 0xCE >> putWord32be (fromIntegral n)+ | 0 <= n =+ putWord8 0xCF >> putWord64be (fromIntegral n)+ | -0x80 <= n =+ putWord8 0xD0 >> putWord8 (fromIntegral n)+ | -0x8000 <= n =+ putWord8 0xD1 >> putWord16be (fromIntegral n)+ | -0x80000000 <= n =+ putWord8 0xD2 >> putWord32be (fromIntegral n)+ | otherwise =+ putWord8 0xD3 >> putWord64be (fromIntegral n)++putFloat :: Float -> Put+putFloat f = do+ putWord8 0xCB+ putFloat32be f++putDouble :: Double -> Put+putDouble d = do+ putWord8 0xCB+ putFloat64be d++putStr :: T.Text -> Put+putStr t = do+ let bs = T.encodeUtf8 t+ case S.length bs of+ len | len <= 31 ->+ putWord8 $ 0xA0 .|. fromIntegral len+ | len < 0x100 ->+ putWord8 0xD9 >> putWord8 (fromIntegral len)+ | len < 0x10000 ->+ putWord8 0xDA >> putWord16be (fromIntegral len)+ | otherwise ->+ putWord8 0xDB >> putWord32be (fromIntegral len)+ putByteString bs++putBin :: S.ByteString -> Put+putBin bs = do+ case S.length bs of+ len | len < 0x100 ->+ putWord8 0xC4 >> putWord8 (fromIntegral len)+ | len < 0x10000 ->+ putWord8 0xC5 >> putWord16be (fromIntegral len)+ | otherwise ->+ putWord8 0xC6 >> putWord32be (fromIntegral len)+ putByteString bs++putArray :: (a -> Put) -> V.Vector a -> Put+putArray p xs = do+ case V.length xs of+ len | len <= 15 ->+ putWord8 $ 0x90 .|. fromIntegral len+ | len < 0x10000 ->+ putWord8 0xDC >> putWord16be (fromIntegral len)+ | otherwise ->+ putWord8 0xDD >> putWord32be (fromIntegral len)+ V.mapM_ p xs++putMap :: (a -> Put) -> (b -> Put) -> V.Vector (a, b) -> Put+putMap p q xs = do+ case V.length xs of+ len | len <= 15 ->+ putWord8 $ 0x80 .|. fromIntegral len+ | len < 0x10000 ->+ putWord8 0xDE >> putWord16be (fromIntegral len)+ | otherwise ->+ putWord8 0xDF >> putWord32be (fromIntegral len)+ V.mapM_ (\(a, b) -> p a >> q b ) xs++putExt :: Word8 -> S.ByteString -> Put+putExt typ dat = do+ case S.length dat of+ 1 -> putWord8 0xD4+ 2 -> putWord8 0xD5+ 4 -> putWord8 0xD6+ 8 -> putWord8 0xD7+ 16 -> putWord8 0xD8+ len | len < 0x100 -> putWord8 0xC7 >> putWord8 (fromIntegral len)+ | len < 0x10000 -> putWord8 0xC8 >> putWord16be (fromIntegral len)+ | otherwise -> putWord8 0xC9 >> putWord32be (fromIntegral len)+ putWord8 typ+ putByteString dat
− test/Test.hs
@@ -1,70 +0,0 @@-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
+ test/test.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Main (main) where++import Control.Applicative+import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy.Char8 as L+import Data.Maybe+import Data.MessagePack+import Test.QuickCheck+import Test.Tasty+import Test.Tasty.QuickCheck++main :: IO ()+main = defaultMain tests++instance Arbitrary a => Arbitrary (Assoc a) where+ arbitrary = Assoc <$> arbitrary++instance Arbitrary S.ByteString where+ arbitrary = S.pack <$> arbitrary++instance Arbitrary L.ByteString where+ arbitrary = L.pack <$> arbitrary++mid :: MessagePack a => a -> a+mid = fromJust . unpack . pack++tests :: TestTree+tests =+ testGroup "Identity Properties"+ [ testProperty "int" $+ \(a :: Int) -> a == mid a+ , testProperty "nil" $+ \(a :: ()) -> a == mid a+ , testProperty "bool" $+ \(a :: Bool) -> a == mid a+ , testProperty "double" $+ \(a :: Double) -> a == mid a+ , testProperty "string" $+ \(a :: String) -> a == mid a+ , testProperty "bytestring" $+ \(a :: S.ByteString) -> a == mid a+ , testProperty "lazy-bytestring" $+ \(a :: L.ByteString) -> a == mid a+ , testProperty "[int]" $+ \(a :: [Int]) -> a == mid a+ , testProperty "[string]" $+ \(a :: [String]) -> a == mid a+ , testProperty "(int, int)" $+ \(a :: (Int, Int)) -> a == mid a+ , testProperty "(int, int, int)" $+ \(a :: (Int, Int, Int)) -> a == mid a+ , testProperty "(int, int, int, int)" $+ \(a :: (Int, Int, Int, Int)) -> a == mid a+ , testProperty "(int, int, int, int, int)" $+ \(a :: (Int, Int, Int, Int, Int)) -> a == mid a+ , testProperty "[(int, double)]" $+ \(a :: [(Int, Double)]) -> a == mid a+ , testProperty "[(string, string)]" $+ \(a :: [(String, String)]) -> a == mid a+ , testProperty "Assoc [(string, int)]" $+ \(a :: Assoc [(String, Int)]) -> a == mid a+ ]