data-msgpack (empty) → 0.0.2
raw patch · 12 files changed
+979/−0 lines, 12 filesdep +QuickCheckdep +basedep +binarysetup-changed
Dependencies added: QuickCheck, base, binary, bytestring, containers, data-binary-ieee754, data-msgpack, deepseq, hashable, hspec, text, unordered-containers
Files
- LICENSE +24/−0
- Setup.lhs +3/−0
- data-msgpack.cabal +59/−0
- src/Data/MessagePack.hs +50/−0
- src/Data/MessagePack/Assoc.hs +35/−0
- src/Data/MessagePack/Class.hs +250/−0
- src/Data/MessagePack/Generic.hs +126/−0
- src/Data/MessagePack/Get.hs +147/−0
- src/Data/MessagePack/Object.hs +110/−0
- src/Data/MessagePack/Put.hs +139/−0
- src/Data/MessagePack/Result.hs +35/−0
- test/testsuite.hs +1/−0
+ LICENSE view
@@ -0,0 +1,24 @@+Copyright (c) 2009-2010, Hideyuki Tanaka+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+ * Neither the name of the Hideyuki Tanaka nor the+ names of its contributors may be used to endorse or promote products+ derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY Hideyuki Tanaka ''AS IS'' AND ANY+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL <copyright holder> BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ data-msgpack.cabal view
@@ -0,0 +1,59 @@+name: data-msgpack+version: 0.0.2+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: Iphigenia Df <iphydf@gmail.com>+copyright: Copyright (c) 2009-2016, Hideyuki Tanaka+category: Data+stability: Experimental+cabal-version: >= 1.10+build-type: Simple++source-repository head+ type: git+ location: https://github.com/TokTok/msgpack-haskell.git++library+ default-language: Haskell2010+ hs-source-dirs:+ src+ exposed-modules:+ Data.MessagePack+ Data.MessagePack.Assoc+ Data.MessagePack.Class+ Data.MessagePack.Generic+ Data.MessagePack.Get+ Data.MessagePack.Object+ Data.MessagePack.Put+ Data.MessagePack.Result+ build-depends:+ base < 5+ , QuickCheck+ , binary+ , bytestring+ , containers+ , data-binary-ieee754+ , deepseq+ , hashable+ , text+ , unordered-containers++test-suite testsuite+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: test+ main-is: testsuite.hs+ build-depends:+ base < 5+ , QuickCheck+ , bytestring+ , containers+ , data-msgpack+ , hashable+ , hspec+ , text+ , unordered-containers
+ src/Data/MessagePack.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE Safe #-}+--------------------------------------------------------------------+-- |+-- 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+ ) where++import Control.Applicative (Applicative)+import Control.Monad ((>=>))+import Data.Binary (decodeOrFail, encode)+import qualified Data.ByteString.Lazy as L++import Data.MessagePack.Assoc as X+import Data.MessagePack.Class as X+import Data.MessagePack.Generic ()+import Data.MessagePack.Get as X+import Data.MessagePack.Object as X+import Data.MessagePack.Put as X+++-- | 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 fails in the+-- Monad. In the Maybe monad, failure returns Nothing.+unpack :: (Applicative m, Monad m, MessagePack a)+ => L.ByteString -> m a+unpack = eitherToM . decodeOrFail >=> fromObject+ where+ eitherToM (Left (_, _, msg)) = fail msg+ eitherToM (Right (_, _, res)) = return res
+ src/Data/MessagePack/Assoc.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE Trustworthy #-}++--------------------------------------------------------------------+-- |+-- 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.Applicative ((<$>))+import Control.DeepSeq (NFData)+import Data.Typeable (Typeable)+import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)++-- 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, Read, Eq, Ord, Typeable, NFData)++instance Arbitrary a => Arbitrary (Assoc a) where+ arbitrary = Assoc <$> arbitrary
+ src/Data/MessagePack/Class.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE Trustworthy #-}+{-# 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.Class+ ( MessagePack (..)+ , GMessagePack (..)+ ) where++import Control.Applicative (Applicative, (<$>), (<*>))+import Control.Arrow ((***))+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import Data.Hashable (Hashable)+import qualified Data.HashMap.Strict as HashMap+import Data.Int (Int16, Int32, Int64, Int8)+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.Word (Word, Word16, Word32, Word64, Word8)+import GHC.Generics++import Data.MessagePack.Assoc+import Data.MessagePack.Object+++-- Generic serialisation.++class GMessagePack f where+ gToObject :: f a -> Object+ gFromObject :: (Applicative m, Monad m) => Object -> m (f a)+++class MessagePack a where+ toObject :: a -> Object+ fromObject :: (Applicative m, Monad m) => Object -> m a++ default toObject :: (Generic a, GMessagePack (Rep a))+ => a -> Object+ toObject = genericToObject+ default fromObject :: ( Applicative m, Monad m+ , Generic a, GMessagePack (Rep a))+ => Object -> m a+ fromObject = genericFromObject+++genericToObject :: (Generic a, GMessagePack (Rep a))+ => a -> Object+genericToObject = gToObject . from++genericFromObject :: ( Applicative m, Monad m+ , Generic a, GMessagePack (Rep a))+ => Object -> m a+genericFromObject x = to <$> gFromObject x+++-- Instances for integral types (Int etc.).++toInt :: Integral a => a -> Int64+toInt = fromIntegral++fromInt :: Integral a => Int64 -> a+fromInt = fromIntegral++instance MessagePack Int64 where+ toObject = ObjectInt+ fromObject = \case+ ObjectInt n -> return n+ _ -> fail "invalid encoding for integer type"++instance MessagePack Int where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o }+instance MessagePack Int8 where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o }+instance MessagePack Int16 where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o }+instance MessagePack Int32 where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o }++instance MessagePack Word where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o }+instance MessagePack Word8 where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o }+instance MessagePack Word16 where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o }+instance MessagePack Word32 where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o }+instance MessagePack Word64 where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o }+++-- Core instances.++instance MessagePack Object where+ toObject = id+ fromObject = return++instance MessagePack () where+ toObject _ = ObjectArray []+ fromObject = \case+ ObjectArray [] -> return ()+ _ -> fail "invalid encoding for ()"++instance MessagePack Bool where+ toObject = ObjectBool+ fromObject = \case+ ObjectBool b -> return b+ _ -> fail "invalid encoding for Bool"++instance MessagePack Float where+ toObject = ObjectFloat+ fromObject = \case+ ObjectInt n -> return $ fromIntegral n+ ObjectFloat f -> return f+ ObjectDouble d -> return $ realToFrac d+ _ -> fail "invalid encoding for Float"++instance MessagePack Double where+ toObject = ObjectDouble+ fromObject = \case+ ObjectInt n -> return $ fromIntegral n+ ObjectFloat f -> return $ realToFrac f+ ObjectDouble d -> return d+ _ -> fail "invalid encoding for Double"++-- Because of overlapping instance, this must be above [a].+-- IncoherentInstances and TypeSynonymInstances are required for this to work.+instance MessagePack String where+ toObject = toObject . T.pack+ fromObject obj = T.unpack <$> fromObject obj+++-- Instances for nullable types.++instance MessagePack a => MessagePack (Maybe a) where+ toObject = \case+ Just a -> toObject a+ Nothing -> ObjectNil++ fromObject = \case+ ObjectNil -> return Nothing+ obj -> Just <$> fromObject obj+++-- Instances for binary and UTF-8 encoded string.++instance MessagePack S.ByteString where+ toObject = ObjectBin+ fromObject = \case+ ObjectBin r -> return r+ _ -> fail "invalid encoding for ByteString"++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 -> return s+ _ -> fail "invalid encoding for Text"++instance MessagePack LT.Text where+ toObject = toObject . LT.toStrict+ fromObject obj = LT.fromStrict <$> fromObject obj+++-- Instances for array-like data structures.++instance MessagePack a => MessagePack [a] where+ toObject = ObjectArray . map toObject+ fromObject = \case+ ObjectArray xs -> mapM fromObject xs+ _ -> fail "invalid encoding for list"+++-- Instances for map-like data structures.++instance (MessagePack a, MessagePack b) => MessagePack (Assoc [(a, b)]) where+ toObject (Assoc xs) = ObjectMap $ map (toObject *** toObject) xs+ fromObject = \case+ ObjectMap xs ->+ Assoc <$> mapM (\(k, v) -> (,) <$> fromObject k <*> fromObject v) xs+ _ ->+ fail "invalid encoding for Assoc"++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+++-- Instances for various tuple arities.++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 _ = fail "invalid encoding for tuple"++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 _ = fail "invalid encoding for tuple"++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 _ = fail "invalid encoding for tuple"++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 _ = fail "invalid encoding for tuple"++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 _ = fail "invalid encoding for tuple"++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 _ = fail "invalid encoding for tuple"++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 _ = fail "invalid encoding for tuple"++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 _ = fail "invalid encoding for tuple"
+ src/Data/MessagePack/Generic.hs view
@@ -0,0 +1,126 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+module Data.MessagePack.Generic () where++import Control.Applicative (Applicative, (<$>), (<*>))+import Control.Monad ((>=>))+import Data.Bits (shiftR)+import Data.Word (Word64)+import GHC.Generics++import Data.MessagePack.Class+import Data.MessagePack.Object (Object (..))+++instance GMessagePack U1 where+ gToObject U1 = ObjectNil+ gFromObject ObjectNil = return U1+ gFromObject _ = fail "invalid encoding for custom unit type"++instance (GMessagePack a, GProdPack b) => GMessagePack (a :*: b) where+ gToObject = toObject . prodToObject+ gFromObject = fromObject >=> prodFromObject++instance (GSumPack a, GSumPack b, SumSize a, SumSize b) => GMessagePack (a :+: b) where+ gToObject = sumToObject 0 size+ where+ size = unTagged (sumSize :: Tagged (a :+: b) Word64)++ gFromObject = \case+ ObjectInt code -> checkSumFromObject0 size (fromIntegral code)+ o -> fromObject o >>= uncurry (checkSumFromObject size)+ where+ size = unTagged (sumSize :: Tagged (a :+: b) Word64)++instance GMessagePack a => GMessagePack (M1 t c a) where+ gToObject (M1 x) = gToObject x+ gFromObject x = M1 <$> gFromObject x++instance MessagePack a => GMessagePack (K1 i a) where+ gToObject (K1 x) = toObject x+ gFromObject o = K1 <$> fromObject o+++-- Product type packing.++class GProdPack f where+ prodToObject :: f a -> [Object]+ prodFromObject :: (Applicative m, Monad m) => [Object] -> m (f a)+++instance (GMessagePack a, GProdPack b) => GProdPack (a :*: b) where+ prodToObject (a :*: b) = gToObject a : prodToObject b+ prodFromObject (a:b) = (:*:) <$> gFromObject a <*> prodFromObject b+ prodFromObject _ = fail "invalid encoding for product type"++instance GMessagePack a => GProdPack (M1 t c a) where+ prodToObject (M1 x) = [gToObject x]+ prodFromObject [x] = M1 <$> gFromObject x+ prodFromObject _ = fail "invalid encoding for product type"+++-- Sum type packing.++checkSumFromObject0 :: (Applicative m, Monad m) => (GSumPack f) => Word64 -> Word64 -> m (f a)+checkSumFromObject0 size code+ | code < size = sumFromObject code size ObjectNil+ | otherwise = fail "invalid encoding for sum type"+++checkSumFromObject :: (Applicative m, Monad m) => (GSumPack f) => Word64 -> Word64 -> Object -> m (f a)+checkSumFromObject size code x+ | code < size = sumFromObject code size x+ | otherwise = fail "invalid encoding for sum type"+++class GSumPack f where+ sumToObject :: Word64 -> Word64 -> f a -> Object+ sumFromObject :: (Applicative m, Monad m) => Word64 -> Word64 -> Object -> m (f a)+++instance (GSumPack a, GSumPack b) => GSumPack (a :+: b) where+ sumToObject code size = \case+ L1 x -> sumToObject code sizeL x+ R1 x -> sumToObject (code + sizeL) sizeR x+ where+ sizeL = size `shiftR` 1+ sizeR = size - sizeL++ sumFromObject code size x+ | code < sizeL = L1 <$> sumFromObject code sizeL x+ | otherwise = R1 <$> sumFromObject (code - sizeL) sizeR x+ where+ sizeL = size `shiftR` 1+ sizeR = size - sizeL+++instance GSumPack (C1 c U1) where+ sumToObject code _ _ = toObject code+ sumFromObject _ _ = gFromObject+++instance GMessagePack a => GSumPack (C1 c a) where+ sumToObject code _ x = toObject (code, gToObject x)+ sumFromObject _ _ = gFromObject+++-- Sum size.++class SumSize f where+ sumSize :: Tagged f Word64++newtype Tagged (s :: * -> *) b = Tagged { unTagged :: b }++instance (SumSize a, SumSize b) => SumSize (a :+: b) where+ sumSize = Tagged $ unTagged (sumSize :: Tagged a Word64) ++ unTagged (sumSize :: Tagged b Word64)++instance SumSize (C1 c a) where+ sumSize = Tagged 1
+ src/Data/MessagePack/Get.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE Trustworthy #-}++--------------------------------------------------------------------+-- |+-- 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 (empty, (<$), (<$>), (<*>), (<|>))+import Control.Monad (guard, replicateM)+import Data.Binary (Get)+import Data.Binary.Get (getByteString, getWord16be, getWord32be,+ getWord64be, getWord8)+import Data.Binary.IEEE754 (getFloat32be, getFloat64be)+import Data.Bits ((.&.))+import qualified Data.ByteString as S+import Data.Int (Int16, Int32, Int64, Int8)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Word (Word8)++getNil :: Get ()+getNil = tag 0xC0++getBool :: Get Bool+getBool =+ False <$ tag 0xC2 <|>+ True <$ tag 0xC3++getInt :: Get Int64+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 [a]+getArray g = do+ len <- getWord8 >>= \case+ t | t .&. 0xF0 == 0x90 ->+ return $ fromIntegral $ t .&. 0x0F+ 0xDC -> fromIntegral <$> getWord16be+ 0xDD -> fromIntegral <$> getWord32be+ _ -> empty+ replicateM len g++getMap :: Get a -> Get b -> Get [(a, b)]+getMap k v = do+ len <- getWord8 >>= \case+ t | t .&. 0xF0 == 0x80 ->+ return $ fromIntegral $ t .&. 0x0F+ 0xDE -> fromIntegral <$> getWord16be+ 0xDF -> fromIntegral <$> getWord32be+ _ -> empty+ 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,110 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE Safe #-}+module Data.MessagePack.Object (Object (..)) where++import Control.Applicative ((<$), (<$>), (<*>), (<|>))+import Control.DeepSeq (NFData (..))+import Data.Binary (Binary (get, put), Get, Put)+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import Data.Int (Int64)+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import Data.Typeable (Typeable)+import Data.Word (Word8)+import GHC.Generics (Generic)+import Prelude hiding (putStr)+import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)+import qualified Test.QuickCheck.Gen as Gen++import Data.MessagePack.Get+import Data.MessagePack.Put+++-- | Object Representation of MessagePack data.+data Object+ = ObjectNil+ -- ^ represents nil+ | ObjectBool !Bool+ -- ^ represents true or false+ | ObjectInt {-# UNPACK #-} !Int64+ -- ^ 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 ![Object]+ -- ^ represents a sequence of objects+ | ObjectMap ![(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 (Read, Show, Eq, Ord, Typeable, Generic)++instance NFData Object++instance Binary Object where+ get = getObject+ put = putObject+++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 Arbitrary Object where+ arbitrary = Gen.sized $ \n -> Gen.oneof+ [ return ObjectNil+ , ObjectBool <$> arbitrary+ , ObjectInt <$> arbitrary+ , ObjectFloat <$> arbitrary+ , ObjectDouble <$> arbitrary+ , ObjectStr <$> arbitrary+ , ObjectBin <$> arbitrary+ , ObjectArray <$> Gen.resize (n `div` 2) arbitrary+ , ObjectMap <$> Gen.resize (n `div` 4) arbitrary+ , ObjectExt <$> arbitrary <*> arbitrary+ ]++instance Arbitrary S.ByteString where+ arbitrary = S.pack <$> arbitrary++instance Arbitrary L.ByteString where+ arbitrary = L.pack <$> arbitrary++instance Arbitrary T.Text where+ arbitrary = T.pack <$> arbitrary++instance Arbitrary LT.Text where+ arbitrary = LT.pack <$> arbitrary
+ src/Data/MessagePack/Put.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE Trustworthy #-}+--------------------------------------------------------------------+-- |+-- 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 (Put)+import Data.Binary.IEEE754 (putFloat32be, putFloat64be)+import Data.Binary.Put (putByteString, putWord16be, putWord32be,+ putWord64be, putWord8, putWord8)+import Data.Bits ((.|.))+import qualified Data.ByteString as S+import Data.Int (Int64)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Word (Word8)++import Prelude hiding (putStr)++putNil :: Put+putNil = putWord8 0xC0++putBool :: Bool -> Put+putBool False = putWord8 0xC2+putBool True = putWord8 0xC3++putInt :: Int64 -> 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 0xCA+ 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) -> [a] -> Put+putArray p xs = do+ case length xs of+ len | len <= 15 ->+ putWord8 $ 0x90 .|. fromIntegral len+ | len < 0x10000 ->+ putWord8 0xDC >> putWord16be (fromIntegral len)+ | otherwise ->+ putWord8 0xDD >> putWord32be (fromIntegral len)+ mapM_ p xs++putMap :: (a -> Put) -> (b -> Put) -> [(a, b)] -> Put+putMap p q xs = do+ case length xs of+ len | len <= 15 ->+ putWord8 $ 0x80 .|. fromIntegral len+ | len < 0x10000 ->+ putWord8 0xDE >> putWord16be (fromIntegral len)+ | otherwise ->+ putWord8 0xDF >> putWord32be (fromIntegral len)+ 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
+ src/Data/MessagePack/Result.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE Safe #-}+module Data.MessagePack.Result where++import Control.Applicative (Applicative, pure, (<$>), (<*>))+import Test.QuickCheck.Arbitrary (Arbitrary (..))+import qualified Test.QuickCheck.Gen as Gen+++data Result a+ = Success a+ | Failure String+ deriving (Read, Show, Eq, Functor)+++instance Applicative Result where+ pure = Success++ Success f <*> x = fmap f x+ Failure msg <*> _ = Failure msg+++instance Monad Result where+ return = pure+ fail = Failure++ Success x >>= f = f x+ Failure msg >>= _ = Failure msg+++instance Arbitrary a => Arbitrary (Result a) where+ arbitrary = Gen.oneof+ [ Success <$> arbitrary+ , Failure <$> arbitrary+ ]
+ test/testsuite.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}