diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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 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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/data-msgpack-types.cabal b/data-msgpack-types.cabal new file mode 100644 --- /dev/null +++ b/data-msgpack-types.cabal @@ -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 +copyright: Copyright (c) 2009-2016, Hideyuki Tanaka +category: Data +stability: Experimental +cabal-version: >= 1.10 +build-type: Simple +description: + A Haskell implementation of MessagePack + . + This is a fork of 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 diff --git a/src/Data/MessagePack/Types.hs b/src/Data/MessagePack/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/MessagePack/Types.hs @@ -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 diff --git a/src/Data/MessagePack/Types/Assoc.hs b/src/Data/MessagePack/Types/Assoc.hs new file mode 100644 --- /dev/null +++ b/src/Data/MessagePack/Types/Assoc.hs @@ -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 diff --git a/src/Data/MessagePack/Types/Class.hs b/src/Data/MessagePack/Types/Class.hs new file mode 100644 --- /dev/null +++ b/src/Data/MessagePack/Types/Class.hs @@ -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" diff --git a/src/Data/MessagePack/Types/Generic.hs b/src/Data/MessagePack/Types/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Data/MessagePack/Types/Generic.hs @@ -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 diff --git a/src/Data/MessagePack/Types/Instances.hs b/src/Data/MessagePack/Types/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Data/MessagePack/Types/Instances.hs @@ -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 diff --git a/src/Data/MessagePack/Types/Object.hs b/src/Data/MessagePack/Types/Object.hs new file mode 100644 --- /dev/null +++ b/src/Data/MessagePack/Types/Object.hs @@ -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) diff --git a/src/Data/MessagePack/Types/Option.hs b/src/Data/MessagePack/Types/Option.hs new file mode 100644 --- /dev/null +++ b/src/Data/MessagePack/Types/Option.hs @@ -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 + ] diff --git a/src/Data/MessagePack/Types/Result.hs b/src/Data/MessagePack/Types/Result.hs new file mode 100644 --- /dev/null +++ b/src/Data/MessagePack/Types/Result.hs @@ -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 + ]