packages feed

msgpack-types (empty) → 0.0.4

raw patch · 12 files changed

+901/−0 lines, 12 filesdep +QuickCheckdep +basedep +bytestringsetup-changed

Dependencies added: QuickCheck, base, bytestring, containers, deepseq, generic-arbitrary, hashable, hspec, msgpack-types, text, unordered-containers, vector

Files

+ LICENSE view
@@ -0,0 +1,25 @@+Copyright (c) 2017-2018, The TokTok Team+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
+ msgpack-types.cabal view
@@ -0,0 +1,74 @@+name:                 msgpack-types+version:              0.0.4+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+  other-modules:+      Data.MessagePack.Types.Assoc+      Data.MessagePack.Types.Class+      Data.MessagePack.Types.Generic+      Data.MessagePack.Types.Instances+      Data.MessagePack.Types.Object+  build-depends:+      base < 5+    , QuickCheck+    , bytestring+    , containers+    , deepseq+    , hashable+    , text+    , unordered-containers+    , vector++test-suite testsuite+  type: exitcode-stdio-1.0+  default-language: Haskell2010+  hs-source-dirs: test+  main-is: testsuite.hs+  other-modules:+      Data.MessagePack.Types.AssocSpec+      Data.MessagePack.Types.ClassSpec+  ghc-options:+      -Wall+      -fno-warn-unused-imports+  build-depends:+      base < 5+    , QuickCheck+    , bytestring+    , containers+    , deepseq+    , generic-arbitrary+    , hashable+    , hspec+    , msgpack-types+    , text+    , unordered-containers+    , vector
+ src/Data/MessagePack/Types.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE Safe #-}+module Data.MessagePack.Types+    ( Assoc (..)+    , Object (..)+    , MessagePack (..)+    ) where++import           Data.MessagePack.Types.Assoc     (Assoc (..))+import           Data.MessagePack.Types.Class     (MessagePack (..))+import           Data.MessagePack.Types.Instances ()+import           Data.MessagePack.Types.Object    (Object (..))
+ src/Data/MessagePack/Types/Assoc.hs view
@@ -0,0 +1,36 @@+{-# 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,302 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DefaultSignatures   #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE Trustworthy         #-}++--------------------------------------------------------------------+-- |+-- 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                  (Generic, Rep, from, to)++import           Data.MessagePack.Types.Assoc  (Assoc (..))+import           Data.MessagePack.Types.Object (Object (..))+++-- Generic serialisation.++class GMessagePack f where+    gToObject :: f a -> Object+    gFromObject+        :: ( Applicative m+           , Monad m+#if (MIN_VERSION_base(4,13,0))+           , MonadFail m+#endif+           )+        => Object+        -> m (f a)+++class MessagePack a where+    toObject :: a -> Object+    fromObject+        :: ( Applicative m+           , Monad m+#if (MIN_VERSION_base(4,13,0))+           , MonadFail m+#endif+           )+        => Object+        -> m a++    default toObject :: (Generic a, GMessagePack (Rep a)) => a -> Object+    toObject = genericToObject+    default fromObject+        :: ( Applicative m+           , Monad m+#if (MIN_VERSION_base(4,13,0))+           , MonadFail m+#endif+           , 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+#if (MIN_VERSION_base(4,13,0))+       , MonadFail m+#endif+       , 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,159 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE CPP                 #-}+{-# 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+#if (MIN_VERSION_base(4,13,0))+           , MonadFail m+#endif+           )+        => [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+#if (MIN_VERSION_base(4,13,0))+       , MonadFail m+#endif+       )+    => (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+#if (MIN_VERSION_base(4,13,0))+       , MonadFail m+#endif+       )+    => (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+#if (MIN_VERSION_base(4,13,0))+           , MonadFail m+#endif+           )+        => 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,12 @@+{-# 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,64 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE Safe               #-}+module Data.MessagePack.Types.Object+    ( Object (..)+    ) where++import           Control.Applicative       ((<$>), (<*>))+import           Control.DeepSeq           (NFData (..))+import qualified Data.ByteString           as S+import           Data.Int                  (Int64)+import qualified Data.Text                 as T+import           Data.Typeable             (Typeable)+import           Data.Word                 (Word64, Word8)+import           GHC.Generics              (Generic)+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+        [ pure 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)
+ test/Data/MessagePack/Types/AssocSpec.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy         #-}+module Data.MessagePack.Types.AssocSpec where++import           Data.MessagePack.Types (Assoc (..))+import           Test.Hspec             (Spec, describe, it, shouldBe)+import           Test.QuickCheck        (Arbitrary (..), property)++spec :: Spec+spec =+    describe "Assoc" $+        it "has a working Read/Show implementation"+            $ property+            $ \(x :: Assoc [(Int, Int)]) -> read (show x) `shouldBe` x
+ test/Data/MessagePack/Types/ClassSpec.hs view
@@ -0,0 +1,200 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy         #-}+module Data.MessagePack.Types.ClassSpec where++import           Control.Applicative               (empty, pure, (<$>), (<*>),+                                                    (<|>))+import           Control.Monad                     (mplus, mzero)+import qualified Data.ByteString                   as BS+import qualified Data.ByteString.Lazy              as LBS+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           Data.MessagePack.Types            (Assoc (..),+                                                    MessagePack (..),+                                                    Object (..))+import qualified Data.Text                         as Text+import qualified Data.Text.Lazy                    as LText+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                      (Generic)+import           Test.Hspec                        (Spec, describe, it,+                                                    shouldBe, shouldSatisfy)+import           Test.QuickCheck                   (Arbitrary (..),+                                                    genericShrink, property,+                                                    withMaxSuccess)+import           Test.QuickCheck.Arbitrary.Generic (genericArbitrary)++data MyType+    = SequenceTyCon Int String+    | EnumTyCon+    | RecordTyCon { intValue :: Int }+    | F01 Int8+    | F02 Int16+    | F03 Int32+    | F04 Int64+    | F05 Word+    | F06 Word8+    | F07 Word16+    | F08 Word32+    | F09 Word64+    | F10 ()+    | F11 Bool+    | F12 Float+    | F13 Double+    | F14 BS.ByteString+    | F15 LBS.ByteString+    | F16 Text.Text+    | F17 LText.Text+    | F18 (V.Vector Int)+    | F19 (VS.Vector Int)+    | F20 (VU.Vector Int)+    | F21 (Assoc [(Int, String)])+    | F22 (Map.Map Int Int)+    | F23 (IntMap.IntMap Int)+    | F24 (HashMap.HashMap Int Int)+    | F25 (Int, Int)+    | F26 (Int, Int, Int)+    | F27 (Int, Int, Int, Int)+    | F28 (Int, Int, Int, Int, Int)+    | F29 (Int, Int, Int, Int, Int, Int)+    | F30 (Int, Int, Int, Int, Int, Int, Int)+    | F31 (Int, Int, Int, Int, Int, Int, Int, Int)+    | F32 (Int, Int, Int, Int, Int, Int, Int, Int, Int)+    deriving (Show, Eq, Generic)++instance MessagePack MyType+instance Arbitrary MyType where+    arbitrary = genericArbitrary+    shrink = genericShrink++instance Arbitrary BS.ByteString where+    arbitrary = BS.pack . take 10 <$> arbitrary+instance Arbitrary LBS.ByteString where+    arbitrary = LBS.pack . take 10 <$> arbitrary+instance Arbitrary Text.Text where+    arbitrary = Text.pack . take 10 <$> arbitrary+instance Arbitrary LText.Text where+    arbitrary = LText.pack . take 10 <$> arbitrary+instance Arbitrary a => Arbitrary (V.Vector a) where+    arbitrary = V.fromList <$> arbitrary+instance (Arbitrary a, VS.Storable a) => Arbitrary (VS.Vector a) where+    arbitrary = VS.fromList <$> arbitrary+instance (Arbitrary a, VU.Unbox a) => Arbitrary (VU.Vector a) where+    arbitrary = VU.fromList <$> arbitrary+instance (Arbitrary a, Hashable a, Eq a, Arbitrary b) => Arbitrary (HashMap.HashMap a b) where+    arbitrary = HashMap.fromList <$> arbitrary+++spec :: Spec+spec = do+    describe "GMessagePack" $ do+        it "is a reversible operation" $ property $ \(x :: MyType) ->+            fromObject (toObject x) `shouldBe` Just x++        it "handles arbitrary values"+            $ withMaxSuccess 100000+            $ property+            $ \ob -> fromObject ob `shouldSatisfy` \case+                  Just EnumTyCon -> True+                  Just _         -> True+                  Nothing        -> True++        it "produces msgpack values as expected" $ do+            toObject (SequenceTyCon 111 "hello")+                `shouldBe` ObjectArray+                               [ ObjectWord 0+                               , ObjectArray [ObjectWord 111, ObjectStr "hello"]+                               ]+            toObject EnumTyCon `shouldBe` ObjectWord 1+            toObject (RecordTyCon 222)+                `shouldBe` ObjectArray [ObjectWord 2, ObjectWord 222]++    describe "MessagePack" $ do+        it "handles wrong encodings correctly" $ do+            (fromObject $ ObjectArray [ObjectWord 1, ObjectWord 222] :: Maybe MyType)+                `shouldBe` Nothing+            (fromObject ObjectNil :: Maybe MyType)+                `shouldBe` Nothing+            (fromObject $ ObjectArray [ObjectWord 99999] :: Maybe MyType)+                `shouldBe` Nothing+            (fromObject $ ObjectArray [] :: Maybe MyType)+                `shouldBe` Nothing+            (fromObject ObjectNil :: Maybe Int64)+                `shouldBe` Nothing+            (fromObject ObjectNil :: Maybe BS.ByteString)+                `shouldBe` Nothing+            (fromObject ObjectNil :: Maybe LBS.ByteString)+                `shouldBe` Nothing+            (fromObject ObjectNil :: Maybe Text.Text)+                `shouldBe` Nothing+            (fromObject ObjectNil :: Maybe LText.Text)+                `shouldBe` Nothing+            (fromObject ObjectNil :: Maybe (V.Vector Int))+                `shouldBe` Nothing+            (fromObject ObjectNil :: Maybe (VU.Vector Int))+                `shouldBe` Nothing+            (fromObject ObjectNil :: Maybe (VS.Vector Int))+                `shouldBe` Nothing+            (fromObject ObjectNil :: Maybe (Assoc [(Int, Int)]))+                `shouldBe` Nothing+            (fromObject ObjectNil :: Maybe (Map.Map Int Int))+                `shouldBe` Nothing+            (fromObject ObjectNil :: Maybe (IntMap.IntMap Int))+                `shouldBe` Nothing+            (fromObject ObjectNil :: Maybe (HashMap.HashMap Int Int))+                `shouldBe` Nothing+            (fromObject ObjectNil :: Maybe Word64)+                `shouldBe` Nothing+            (fromObject (ObjectArray [ObjectWord 0]) :: Maybe ())+                `shouldBe` Nothing+            (fromObject ObjectNil :: Maybe (Int, Int))+                `shouldBe` Nothing+            (fromObject ObjectNil :: Maybe (Int, Int, Int))+                `shouldBe` Nothing+            (fromObject ObjectNil :: Maybe (Int, Int, Int, Int))+                `shouldBe` Nothing+            (fromObject ObjectNil :: Maybe (Int, Int, Int, Int, Int))+                `shouldBe` Nothing+            (fromObject ObjectNil :: Maybe (Int, Int, Int, Int, Int, Int))+                `shouldBe` Nothing+            (fromObject ObjectNil :: Maybe (Int, Int, Int, Int, Int, Int, Int))+                `shouldBe` Nothing+            (fromObject ObjectNil :: Maybe (Int, Int, Int, Int, Int, Int, Int, Int))+                `shouldBe` Nothing+            (fromObject ObjectNil :: Maybe (Int, Int, Int, Int, Int, Int, Int, Int, Int))+                `shouldBe` Nothing++        it "has a working Read/Show implementation" $ property $ \(x :: Object) ->+            read (show x) `shouldBe` x++        it "can parse both nil and [] as ()" $ do+            (fromObject ObjectNil :: Maybe ())+                `shouldBe` Just ()+            (fromObject (ObjectArray []) :: Maybe ())+                `shouldBe` Just ()++        it "can parse ints and doubles as floats" $ do+            (fromObject (ObjectDouble 123) :: Maybe Float)+                `shouldBe` Just 123+            (fromObject (ObjectWord 123) :: Maybe Float)+                `shouldBe` Just 123+            (fromObject (ObjectInt (-123)) :: Maybe Float)+                `shouldBe` Just (-123)++        it "can parse ints and floats as doubles" $ do+            (fromObject (ObjectFloat 123) :: Maybe Double)+                `shouldBe` Just 123+            (fromObject (ObjectWord 123) :: Maybe Double)+                `shouldBe` Just 123+            (fromObject (ObjectInt (-123)) :: Maybe Double)+                `shouldBe` Just (-123)
+ test/testsuite.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}