packages feed

data-msgpack-types (empty) → 0.0.1

raw patch · 11 files changed

+726/−0 lines, 11 filesdep +QuickCheckdep +basedep +bytestringsetup-changed

Dependencies added: QuickCheck, base, bytestring, containers, deepseq, hashable, text, unordered-containers, vector, void

Files

+ 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-types.cabal view
@@ -0,0 +1,52 @@+name:                 data-msgpack-types+version:              0.0.1+synopsis:             A Haskell implementation of MessagePack.+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+description:+  A Haskell implementation of MessagePack <http://msgpack.org/>+  .+  This is a fork of msgpack-haskell <https://github.com/msgpack/msgpack-haskell>,+  since the original author is unreachable. This fork incorporates a number of+  bugfixes and is actively being developed.++source-repository head+  type:             git+  location:         https://github.com/TokTok/hs-msgpack-types.git++library+  default-language: Haskell2010+  hs-source-dirs:+      src+  ghc-options:+      -Wall+      -fno-warn-unused-imports+  exposed-modules:+      Data.MessagePack.Types+      Data.MessagePack.Types.Class+      Data.MessagePack.Types.Object+      Data.MessagePack.Types.Option+      Data.MessagePack.Types.Result+  other-modules:+      Data.MessagePack.Types.Assoc+      Data.MessagePack.Types.Generic+      Data.MessagePack.Types.Instances+  build-depends:+      base < 5+    , QuickCheck+    , bytestring+    , containers+    , deepseq+    , hashable+    , text+    , unordered-containers+    , vector+    , void
+ src/Data/MessagePack/Types.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE Safe #-}++module Data.MessagePack.Types (+  -- * Re-export modules+  -- $reexports+    module X+  ) where++import           Data.MessagePack.Types.Assoc     as X+import           Data.MessagePack.Types.Class     as X+import           Data.MessagePack.Types.Generic   ()+import           Data.MessagePack.Types.Instances ()+import           Data.MessagePack.Types.Object    as X+import           Data.MessagePack.Types.Option    as X
+ src/Data/MessagePack/Types/Assoc.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE Trustworthy                #-}++--------------------------------------------------------------------+-- |+-- Module    : Data.MessagePack.Types.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.Types.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/Types/Class.hs view
@@ -0,0 +1,276 @@+{-# 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.Types.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 qualified Data.Vector                   as V+import qualified Data.Vector.Storable          as VS+import qualified Data.Vector.Unboxed           as VU+import           Data.Word                     (Word, Word16, Word32, Word64,+                                                Word8)+import           GHC.Generics++import           Data.MessagePack.Types.Assoc+import           Data.MessagePack.Types.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++toWord :: Integral a => a -> Word64+toWord = fromIntegral++fromWord :: Integral a => Word64 -> a+fromWord = fromIntegral++instance MessagePack Int64 where+  toObject i+    | i < 0 = ObjectInt i+    | otherwise = ObjectWord $ toWord i+  fromObject = \case+    ObjectInt n  -> return n+    ObjectWord n -> return $ toInt n+    _            -> fail "invalid encoding for integer type"++instance MessagePack Word64 where+  toObject = ObjectWord+  fromObject = \case+    ObjectWord 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 . toWord; fromObject o = fromWord <$> fromObject o }+instance MessagePack Word8  where { toObject = toObject . toWord; fromObject o = fromWord <$> fromObject o }+instance MessagePack Word16 where { toObject = toObject . toWord; fromObject o = fromWord <$> fromObject o }+instance MessagePack Word32 where { toObject = toObject . toWord; fromObject o = fromWord <$> fromObject o }+++-- Core instances.++instance MessagePack Object where+  toObject = id+  fromObject = return++instance MessagePack () where+  toObject _ = ObjectNil+  fromObject = \case+    ObjectNil      -> return ()+    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+    ObjectWord   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+    ObjectWord   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 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"++instance MessagePack a => MessagePack (V.Vector a) where+  toObject = ObjectArray . map toObject . V.toList+  fromObject = \case+    ObjectArray o -> V.fromList <$> mapM fromObject o+    _             -> fail "invalid encoding for Vector"++instance (MessagePack a, VU.Unbox a) => MessagePack (VU.Vector a) where+  toObject = ObjectArray . map toObject . VU.toList+  fromObject = \case+    ObjectArray o -> VU.fromList <$> mapM fromObject o+    _             -> fail "invalid encoding for Unboxed Vector"++instance (MessagePack a, VS.Storable a) => MessagePack (VS.Vector a) where+  toObject = ObjectArray . map toObject . VS.toList+  fromObject = \case+    ObjectArray o -> VS.fromList <$> mapM fromObject o+    _             -> fail "invalid encoding for Storable Vector"++-- 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/Types/Generic.hs view
@@ -0,0 +1,129 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE KindSignatures      #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE Safe                #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}+module Data.MessagePack.Types.Generic () where++import           Control.Applicative           (Applicative, (<$>), (<*>))+import           Control.Monad                 ((>=>))+import           Data.Bits                     (shiftR)+import           Data.Word                     (Word64)+import           GHC.Generics++import           Data.MessagePack.Types.Class+import           Data.MessagePack.Types.Object (Object (..))++instance GMessagePack V1 where+  gToObject = undefined+  gFromObject = fail "can't instantiate void type"++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+    ObjectWord 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/Types/Instances.hs view
@@ -0,0 +1,14 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Data.MessagePack.Types.Instances () where++import           Data.Void                      (Void)++import           Data.MessagePack.Types.Class   (MessagePack)+import           Data.MessagePack.Types.Generic ()+++instance MessagePack a => MessagePack (Maybe a)++instance (MessagePack a, MessagePack b) => MessagePack (Either a b)++instance MessagePack Void
+ src/Data/MessagePack/Types/Object.hs view
@@ -0,0 +1,68 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE LambdaCase         #-}+{-# LANGUAGE Safe               #-}+module Data.MessagePack.Types.Object+  ( Object (..)+  ) where++import           Control.Applicative       ((<$), (<$>), (<*>), (<|>))+import           Control.DeepSeq           (NFData (..))+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                 (Word64, Word8)+import           GHC.Generics              (Generic)+import           Prelude                   hiding (putStr)+import           Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)+import qualified Test.QuickCheck.Gen       as Gen+++-- | Object Representation of MessagePack data.+data Object+  = ObjectNil+    -- ^ represents nil+  | ObjectBool                  !Bool+    -- ^ represents true or false+  | ObjectInt    {-# UNPACK #-} !Int64+    -- ^ represents a negative integer+  | ObjectWord   {-# UNPACK #-} !Word64+    -- ^ represents a positive 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 Arbitrary Object where+  arbitrary = Gen.sized $ \n -> Gen.oneof+    [ return ObjectNil+    , ObjectBool   <$> arbitrary+    , ObjectInt    <$> negatives+    , ObjectWord   <$> arbitrary+    , ObjectFloat  <$> arbitrary+    , ObjectDouble <$> arbitrary+    , ObjectStr    <$> (T.pack <$> arbitrary)+    , ObjectBin    <$> (S.pack <$> arbitrary)+    , ObjectArray  <$> Gen.resize (n `div` 2) arbitrary+    , ObjectMap    <$> Gen.resize (n `div` 4) arbitrary+    , ObjectExt    <$> arbitrary <*> (S.pack <$> arbitrary)+    ]+    where negatives = Gen.choose (minBound, -1)
+ src/Data/MessagePack/Types/Option.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable     #-}+{-# LANGUAGE DeriveFunctor      #-}+{-# LANGUAGE DeriveTraversable  #-}+module Data.MessagePack.Types.Option+  ( Option (..)+  ) where++import           Control.Applicative           (Alternative (..),+                                                Applicative (..), (<$>))+import           Control.Monad                 (Monad (..), MonadPlus (..))+import           Data.Data                     (Data)+import           Data.Foldable                 (Foldable)+import           Data.Traversable              (Traversable)+import           Data.Typeable                 (Typeable)+import           Test.QuickCheck.Arbitrary     (Arbitrary (..))+import qualified Test.QuickCheck.Gen           as Gen++import           Data.MessagePack.Types.Class  (MessagePack (..))+import           Data.MessagePack.Types.Object (Object (..))+++data Option a+  = None+  | Some a+  deriving (Eq, Ord, Show, Read, Foldable, Functor, Traversable, Data, Typeable)++instance Applicative Option where+  pure = Some++  Some f <*> m = fmap f m+  None   <*> _ = None++instance Monad Option where+  return = Some+  fail _ = None++  None   >>= _ = None+  Some x >>= f = f x++instance Alternative Option where+  empty = None++  None <|> x = x+  x    <|> _ = x++instance MonadPlus Option where+  mzero = empty+  mplus = (<|>)++instance MessagePack a => MessagePack (Option a) where+  toObject None     = ObjectNil+  toObject (Some a) = toObject a++  fromObject ObjectNil = return None+  fromObject x         = Some <$> fromObject x++instance Arbitrary a => Arbitrary (Option a) where+  arbitrary = Gen.oneof+    [ pure None+    , Some <$> arbitrary+    ]
+ src/Data/MessagePack/Types/Result.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE DeriveFoldable    #-}+{-# LANGUAGE DeriveFunctor     #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE Safe              #-}+module Data.MessagePack.Types.Result+  ( Result (..)+  ) where++import           Control.Applicative       (Alternative (..), Applicative (..),+                                            (<$>), (<*>))+import           Data.Foldable             (Foldable)+import           Data.Traversable          (Traversable)+import           Test.QuickCheck.Arbitrary (Arbitrary (..))+import qualified Test.QuickCheck.Gen       as Gen+++data Result a+  = Success a+  | Failure String+  deriving (Read, Show, Eq, Functor, Traversable, Foldable)+++instance Applicative Result where+  pure = Success++  Success f   <*> x = fmap f x+  Failure msg <*> _ = Failure msg+++instance Alternative Result where+  empty = Failure "empty alternative"++  s@Success {} <|> _ = s+  _            <|> r = r+++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+    ]