diff --git a/Data/MessagePack.hs b/Data/MessagePack.hs
deleted file mode 100644
--- a/Data/MessagePack.hs
+++ /dev/null
@@ -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
diff --git a/Data/MessagePack/Assoc.hs b/Data/MessagePack/Assoc.hs
deleted file mode 100644
--- a/Data/MessagePack/Assoc.hs
+++ /dev/null
@@ -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)
diff --git a/Data/MessagePack/Derive.hs b/Data/MessagePack/Derive.hs
deleted file mode 100644
--- a/Data/MessagePack/Derive.hs
+++ /dev/null
@@ -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
diff --git a/Data/MessagePack/Internal/Utf8.hs b/Data/MessagePack/Internal/Utf8.hs
deleted file mode 100644
--- a/Data/MessagePack/Internal/Utf8.hs
+++ /dev/null
@@ -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
diff --git a/Data/MessagePack/Object.hs b/Data/MessagePack/Object.hs
deleted file mode 100644
--- a/Data/MessagePack/Object.hs
+++ /dev/null
@@ -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
diff --git a/Data/MessagePack/Pack.hs b/Data/MessagePack/Pack.hs
deleted file mode 100644
--- a/Data/MessagePack/Pack.hs
+++ /dev/null
@@ -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
diff --git a/Data/MessagePack/Unpack.hs b/Data/MessagePack/Unpack.hs
deleted file mode 100644
--- a/Data/MessagePack/Unpack.hs
+++ /dev/null
@@ -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
diff --git a/msgpack.cabal b/msgpack.cabal
--- a/msgpack.cabal
+++ b/msgpack.cabal
@@ -1,55 +1,55 @@
-Name: msgpack
-Version: 0.7.2.5
-Synopsis: A Haskell implementation of MessagePack
-Description: A Haskell implementation of MessagePack
-Homepage: http://msgpack.org/
-License: BSD3
-License-File: LICENSE
-Author: Hideyuki Tanaka
-Maintainer: Hideyuki Tanaka
-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
+homepage: http://msgpack.org/
+license: BSD3
+license-file: LICENSE
+author: Hideyuki Tanaka
+maintainer: Hideyuki Tanaka
+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
diff --git a/src/Data/MessagePack.hs b/src/Data/MessagePack.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/MessagePack.hs
@@ -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
diff --git a/src/Data/MessagePack/Assoc.hs b/src/Data/MessagePack/Assoc.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/MessagePack/Assoc.hs
@@ -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)
diff --git a/src/Data/MessagePack/Get.hs b/src/Data/MessagePack/Get.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/MessagePack/Get.hs
@@ -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
diff --git a/src/Data/MessagePack/Object.hs b/src/Data/MessagePack/Object.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/MessagePack/Object.hs
@@ -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
diff --git a/src/Data/MessagePack/Put.hs b/src/Data/MessagePack/Put.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/MessagePack/Put.hs
@@ -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
diff --git a/test/Test.hs b/test/Test.hs
deleted file mode 100644
--- a/test/Test.hs
+++ /dev/null
@@ -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
diff --git a/test/test.hs b/test/test.hs
new file mode 100644
--- /dev/null
+++ b/test/test.hs
@@ -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
+ ]