msgpack-types 0.1.0 → 0.2.0
raw patch · 5 files changed
+342/−292 lines, 5 filesdep +monad-validatedep +transformers
Dependencies added: monad-validate, transformers
Files
- msgpack-types.cabal +4/−1
- src/Data/MessagePack/Types.hs +23/−5
- src/Data/MessagePack/Types/Class.hs +143/−135
- src/Data/MessagePack/Types/Generic.hs +81/−72
- test/Data/MessagePack/Types/ClassSpec.hs +91/−79
msgpack-types.cabal view
@@ -1,5 +1,5 @@ name: msgpack-types-version: 0.1.0+version: 0.2.0 synopsis: A Haskell implementation of MessagePack. homepage: http://msgpack.org/ license: BSD3@@ -43,7 +43,9 @@ , containers , deepseq , hashable+ , monad-validate , text+ , transformers , unordered-containers , vector @@ -69,6 +71,7 @@ , generic-arbitrary , hashable , hspec+ , monad-validate , msgpack-types , text , unordered-containers
src/Data/MessagePack/Types.hs view
@@ -1,11 +1,29 @@-{-# LANGUAGE Safe #-}+{-# LANGUAGE Trustworthy #-} module Data.MessagePack.Types ( Assoc (..) , Object (..) , MessagePack (..)+ , Config, defaultConfig+ , DecodeError, decodeError, errorMessages+ , fromObject ) where -import Data.MessagePack.Types.Assoc (Assoc (..))-import Data.MessagePack.Types.Class (MessagePack (..))-import Data.MessagePack.Types.Generic ()-import Data.MessagePack.Types.Object (Object (..))+import Control.Monad.Validate (runValidate)+import Data.MessagePack.Types.Assoc (Assoc (..))+import Data.MessagePack.Types.Class (Config, MessagePack (..),+ defaultConfig)+import Data.MessagePack.Types.DecodeError (DecodeError, decodeError,+ errorMessages)+import Data.MessagePack.Types.Generic ()+import Data.MessagePack.Types.Object (Object (..))+++-- | Similar to 'fromObjectWith' 'defaultConfig' but returns the result in+-- a 'MonadFail'.+--+-- Useful when running in another 'MonadFail' like 'Maybe'.+fromObject :: (MonadFail m, MessagePack a) => Object -> m a+fromObject obj =+ case runValidate (fromObjectWith defaultConfig obj) of+ Left err -> fail $ show err+ Right ok -> return ok
src/Data/MessagePack/Types/Class.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE Trustworthy #-} @@ -24,86 +25,92 @@ module Data.MessagePack.Types.Class ( MessagePack (..) , GMessagePack (..)+ , Config+ , defaultConfig ) where -import Control.Applicative (Applicative, (<$>), (<*>))-import Control.Arrow ((***))-import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L-import qualified Data.HashMap.Strict as HashMap-import Data.Hashable (Hashable)-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 Control.Applicative (Applicative, (<$>), (<*>))+import Control.Arrow ((***))+import Control.Monad.Validate (MonadValidate (..))+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import qualified Data.HashMap.Strict as HashMap+import Data.Hashable (Hashable)+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 (..))+import Data.MessagePack.Types.Assoc (Assoc (..))+import Data.MessagePack.Types.DecodeError (DecodeError)+import Data.MessagePack.Types.Object (Object (..)) +data Config = Config++defaultConfig :: Config+defaultConfig = Config++ -- Generic serialisation. class GMessagePack f where- gToObject :: f a -> Object+ gToObject :: Config -> f a -> Object gFromObject :: ( Applicative m , Monad m-#if (MIN_VERSION_base(4,13,0))- , MonadFail m-#endif+ , MonadValidate DecodeError m )- => Object+ => Config+ -> Object -> m (f a) class MessagePack a where- toObject :: a -> Object- fromObject+ toObject :: Config -> a -> Object+ fromObjectWith :: ( Applicative m , Monad m-#if (MIN_VERSION_base(4,13,0))- , MonadFail m-#endif+ , MonadValidate DecodeError m )- => Object+ => Config+ -> Object -> m a - default toObject :: (Generic a, GMessagePack (Rep a)) => a -> Object+ default toObject :: (Generic a, GMessagePack (Rep a)) => Config -> a -> Object toObject = genericToObject- default fromObject+ default fromObjectWith :: ( Applicative m , Monad m-#if (MIN_VERSION_base(4,13,0))- , MonadFail m-#endif+ , MonadValidate DecodeError m , Generic a, GMessagePack (Rep a))- => Object+ => Config+ -> Object -> m a- fromObject = genericFromObject+ fromObjectWith = genericFromObject -genericToObject :: (Generic a, GMessagePack (Rep a)) => a -> Object-genericToObject = gToObject . from+genericToObject :: (Generic a, GMessagePack (Rep a)) => Config -> a -> Object+genericToObject cfg = gToObject cfg . from genericFromObject :: ( Applicative m , Monad m-#if (MIN_VERSION_base(4,13,0))- , MonadFail m-#endif+ , MonadValidate DecodeError m , Generic a , GMessagePack (Rep a) )- => Object+ => Config+ -> Object -> m a-genericFromObject x = to <$> gFromObject x+genericFromObject cfg x = to <$> gFromObject cfg x -- Instances for integral types (Int etc.).@@ -121,183 +128,184 @@ fromWord = fromIntegral instance MessagePack Int64 where- toObject i | i < 0 = ObjectInt i- | otherwise = ObjectWord $ toWord i- fromObject = \case+ toObject _ i+ | i < 0 = ObjectInt i+ | otherwise = ObjectWord $ toWord i+ fromObjectWith _ = \case ObjectInt n -> return n ObjectWord n -> return $ toInt n- _ -> fail "invalid encoding for integer type"+ _ -> refute "invalid encoding for integer type" instance MessagePack Word64 where- toObject = ObjectWord- fromObject = \case+ toObject _ = ObjectWord+ fromObjectWith _ = \case ObjectWord n -> return n- _ -> fail "invalid encoding for integer type"+ _ -> refute "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 Int where { toObject cfg = toObject cfg . toInt; fromObjectWith cfg o = fromInt <$> fromObjectWith cfg o }+instance MessagePack Int8 where { toObject cfg = toObject cfg . toInt; fromObjectWith cfg o = fromInt <$> fromObjectWith cfg o }+instance MessagePack Int16 where { toObject cfg = toObject cfg . toInt; fromObjectWith cfg o = fromInt <$> fromObjectWith cfg o }+instance MessagePack Int32 where { toObject cfg = toObject cfg . toInt; fromObjectWith cfg o = fromInt <$> fromObjectWith cfg 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 }+instance MessagePack Word where { toObject cfg = toObject cfg . toWord; fromObjectWith cfg o = fromWord <$> fromObjectWith cfg o }+instance MessagePack Word8 where { toObject cfg = toObject cfg . toWord; fromObjectWith cfg o = fromWord <$> fromObjectWith cfg o }+instance MessagePack Word16 where { toObject cfg = toObject cfg . toWord; fromObjectWith cfg o = fromWord <$> fromObjectWith cfg o }+instance MessagePack Word32 where { toObject cfg = toObject cfg . toWord; fromObjectWith cfg o = fromWord <$> fromObjectWith cfg o } -- Core instances. instance MessagePack Object where- toObject = id- fromObject = return+ toObject _ = id+ fromObjectWith _ = return instance MessagePack () where- toObject _ = ObjectNil- fromObject = \case+ toObject _ _ = ObjectNil+ fromObjectWith _ = \case ObjectNil -> return () ObjectArray [] -> return ()- _ -> fail "invalid encoding for ()"+ _ -> refute "invalid encoding for ()" instance MessagePack Bool where- toObject = ObjectBool- fromObject = \case+ toObject _ = ObjectBool+ fromObjectWith _ = \case ObjectBool b -> return b- _ -> fail "invalid encoding for Bool"+ _ -> refute "invalid encoding for Bool" instance MessagePack Float where- toObject = ObjectFloat- fromObject = \case+ toObject _ = ObjectFloat+ fromObjectWith _ = \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"+ _ -> refute "invalid encoding for Float" instance MessagePack Double where- toObject = ObjectDouble- fromObject = \case+ toObject _ = ObjectDouble+ fromObjectWith _ = \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"+ _ -> refute "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+ toObject cfg = toObject cfg . T.pack+ fromObjectWith cfg obj = T.unpack <$> fromObjectWith cfg obj -- Instances for binary and UTF-8 encoded string. instance MessagePack S.ByteString where- toObject = ObjectBin- fromObject = \case+ toObject _ = ObjectBin+ fromObjectWith _ = \case ObjectBin r -> return r- _ -> fail "invalid encoding for ByteString"+ _ -> refute "invalid encoding for ByteString" instance MessagePack L.ByteString where- toObject = ObjectBin . L.toStrict- fromObject obj = L.fromStrict <$> fromObject obj+ toObject _ = ObjectBin . L.toStrict+ fromObjectWith cfg obj = L.fromStrict <$> fromObjectWith cfg obj instance MessagePack T.Text where- toObject = ObjectStr- fromObject = \case+ toObject _ = ObjectStr+ fromObjectWith _ = \case ObjectStr s -> return s- _ -> fail "invalid encoding for Text"+ _ -> refute "invalid encoding for Text" instance MessagePack LT.Text where- toObject = toObject . LT.toStrict- fromObject obj = LT.fromStrict <$> fromObject obj+ toObject cfg = toObject cfg . LT.toStrict+ fromObjectWith cfg obj = LT.fromStrict <$> fromObjectWith cfg 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"+ toObject cfg = ObjectArray . map (toObject cfg)+ fromObjectWith cfg = \case+ ObjectArray xs -> mapM (fromObjectWith cfg) xs+ _ -> refute "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"+ toObject cfg = ObjectArray . map (toObject cfg) . V.toList+ fromObjectWith cfg = \case+ ObjectArray o -> V.fromList <$> mapM (fromObjectWith cfg) o+ _ -> refute "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"+ toObject cfg = ObjectArray . map (toObject cfg) . VU.toList+ fromObjectWith cfg = \case+ ObjectArray o -> VU.fromList <$> mapM (fromObjectWith cfg) o+ _ -> refute "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"+ toObject cfg = ObjectArray . map (toObject cfg) . VS.toList+ fromObjectWith cfg = \case+ ObjectArray o -> VS.fromList <$> mapM (fromObjectWith cfg) o+ _ -> refute "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+ toObject cfg (Assoc xs) = ObjectMap $ map (toObject cfg *** toObject cfg) xs+ fromObjectWith cfg = \case ObjectMap xs ->- Assoc <$> mapM (\(k, v) -> (,) <$> fromObject k <*> fromObject v) xs- _ -> fail "invalid encoding for Assoc"+ Assoc <$> mapM (\(k, v) -> (,) <$> fromObjectWith cfg k <*> fromObjectWith cfg v) xs+ _ -> refute "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+ toObject cfg = toObject cfg . Assoc . Map.toList+ fromObjectWith cfg obj = Map.fromList . unAssoc <$> fromObjectWith cfg obj instance MessagePack v => MessagePack (IntMap.IntMap v) where- toObject = toObject . Assoc . IntMap.toList- fromObject obj = IntMap.fromList . unAssoc <$> fromObject obj+ toObject cfg = toObject cfg . Assoc . IntMap.toList+ fromObjectWith cfg obj = IntMap.fromList . unAssoc <$> fromObjectWith cfg 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+ toObject cfg = toObject cfg . Assoc . HashMap.toList+ fromObjectWith cfg obj = HashMap.fromList . unAssoc <$> fromObjectWith cfg 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"+ toObject cfg (a1, a2) = ObjectArray [toObject cfg a1, toObject cfg a2]+ fromObjectWith cfg (ObjectArray [a1, a2]) = (,) <$> fromObjectWith cfg a1 <*> fromObjectWith cfg a2+ fromObjectWith _ _ = refute "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"+ toObject cfg (a1, a2, a3) = ObjectArray [toObject cfg a1, toObject cfg a2, toObject cfg a3]+ fromObjectWith cfg (ObjectArray [a1, a2, a3]) = (,,) <$> fromObjectWith cfg a1 <*> fromObjectWith cfg a2 <*> fromObjectWith cfg a3+ fromObjectWith _ _ = refute "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"+ toObject cfg (a1, a2, a3, a4) = ObjectArray [toObject cfg a1, toObject cfg a2, toObject cfg a3, toObject cfg a4]+ fromObjectWith cfg (ObjectArray [a1, a2, a3, a4]) = (,,,) <$> fromObjectWith cfg a1 <*> fromObjectWith cfg a2 <*> fromObjectWith cfg a3 <*> fromObjectWith cfg a4+ fromObjectWith _ _ = refute "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"+ toObject cfg (a1, a2, a3, a4, a5) = ObjectArray [toObject cfg a1, toObject cfg a2, toObject cfg a3, toObject cfg a4, toObject cfg a5]+ fromObjectWith cfg (ObjectArray [a1, a2, a3, a4, a5]) = (,,,,) <$> fromObjectWith cfg a1 <*> fromObjectWith cfg a2 <*> fromObjectWith cfg a3 <*> fromObjectWith cfg a4 <*> fromObjectWith cfg a5+ fromObjectWith _ _ = refute "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"+ toObject cfg (a1, a2, a3, a4, a5, a6) = ObjectArray [toObject cfg a1, toObject cfg a2, toObject cfg a3, toObject cfg a4, toObject cfg a5, toObject cfg a6]+ fromObjectWith cfg (ObjectArray [a1, a2, a3, a4, a5, a6]) = (,,,,,) <$> fromObjectWith cfg a1 <*> fromObjectWith cfg a2 <*> fromObjectWith cfg a3 <*> fromObjectWith cfg a4 <*> fromObjectWith cfg a5 <*> fromObjectWith cfg a6+ fromObjectWith _ _ = refute "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"+ toObject cfg (a1, a2, a3, a4, a5, a6, a7) = ObjectArray [toObject cfg a1, toObject cfg a2, toObject cfg a3, toObject cfg a4, toObject cfg a5, toObject cfg a6, toObject cfg a7]+ fromObjectWith cfg (ObjectArray [a1, a2, a3, a4, a5, a6, a7]) = (,,,,,,) <$> fromObjectWith cfg a1 <*> fromObjectWith cfg a2 <*> fromObjectWith cfg a3 <*> fromObjectWith cfg a4 <*> fromObjectWith cfg a5 <*> fromObjectWith cfg a6 <*> fromObjectWith cfg a7+ fromObjectWith _ _ = refute "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"+ toObject cfg (a1, a2, a3, a4, a5, a6, a7, a8) = ObjectArray [toObject cfg a1, toObject cfg a2, toObject cfg a3, toObject cfg a4, toObject cfg a5, toObject cfg a6, toObject cfg a7, toObject cfg a8]+ fromObjectWith cfg (ObjectArray [a1, a2, a3, a4, a5, a6, a7, a8]) = (,,,,,,,) <$> fromObjectWith cfg a1 <*> fromObjectWith cfg a2 <*> fromObjectWith cfg a3 <*> fromObjectWith cfg a4 <*> fromObjectWith cfg a5 <*> fromObjectWith cfg a6 <*> fromObjectWith cfg a7 <*> fromObjectWith cfg a8+ fromObjectWith _ _ = refute "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"+ toObject cfg (a1, a2, a3, a4, a5, a6, a7, a8, a9) = ObjectArray [toObject cfg a1, toObject cfg a2, toObject cfg a3, toObject cfg a4, toObject cfg a5, toObject cfg a6, toObject cfg a7, toObject cfg a8, toObject cfg a9]+ fromObjectWith cfg (ObjectArray [a1, a2, a3, a4, a5, a6, a7, a8, a9]) = (,,,,,,,,) <$> fromObjectWith cfg a1 <*> fromObjectWith cfg a2 <*> fromObjectWith cfg a3 <*> fromObjectWith cfg a4 <*> fromObjectWith cfg a5 <*> fromObjectWith cfg a6 <*> fromObjectWith cfg a7 <*> fromObjectWith cfg a8 <*> fromObjectWith cfg a9+ fromObjectWith _ _ = refute "invalid encoding for tuple"
src/Data/MessagePack/Types/Generic.hs view
@@ -1,80 +1,93 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE IncoherentInstances #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE Safe #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StrictData #-}-{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} module Data.MessagePack.Types.Generic () where -import Control.Applicative (Applicative, (<$>), (<*>))-import Control.Monad ((>=>))-import Data.Bits (shiftR)-import Data.Word (Word64)+import Control.Applicative (Applicative, (<$>), (<*>))+import Control.Monad ((>=>))+import Control.Monad.Trans.State.Strict (StateT, evalStateT, get,+ put)+import Control.Monad.Validate (MonadValidate, refute)+import Data.Bits (shiftR)+import Data.Word (Word64) import GHC.Generics import Data.MessagePack.Types.Class-import Data.MessagePack.Types.Object (Object (..))+import Data.MessagePack.Types.DecodeError (DecodeError)+import Data.MessagePack.Types.Object (Object (..)) instance GMessagePack V1 where gToObject = undefined- gFromObject _ = fail "can't instantiate void type"+ gFromObject _ _ = refute "can't instantiate void type" instance GMessagePack U1 where- gToObject U1 = ObjectNil- gFromObject ObjectNil = return U1- gFromObject _ = fail "invalid encoding for custom unit type"+ gToObject _ U1 = ObjectNil+ gFromObject _ ObjectNil = return U1+ gFromObject _ _ = refute "invalid encoding for custom unit type" -instance (GMessagePack a, GProdPack b) => GMessagePack (a :*: b) where- gToObject = toObject . prodToObject- gFromObject = fromObject >=> prodFromObject+instance GProdPack a => GMessagePack a where+ gToObject cfg = toObject cfg . prodToObject cfg+ gFromObject cfg o = do+ list <- fromObjectWith cfg o+ evalStateT (prodFromObject cfg) list instance (GSumPack a, GSumPack b, SumSize a, SumSize b) => GMessagePack (a :+: b) where- gToObject = sumToObject 0 size+ gToObject cfg = sumToObject cfg 0 size where size = unTagged (sumSize :: Tagged (a :+: b) Word64) - gFromObject = \case- ObjectWord code -> checkSumFromObject0 size (fromIntegral code)- o -> fromObject o >>= uncurry (checkSumFromObject size)+ gFromObject cfg = \case+ ObjectWord code -> checkSumFromObject0 cfg size (fromIntegral code)+ o -> fromObjectWith cfg o >>= uncurry (checkSumFromObject cfg 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+ gToObject cfg (M1 x) = gToObject cfg x+ gFromObject cfg x = M1 <$> gFromObject cfg x instance MessagePack a => GMessagePack (K1 i a) where- gToObject (K1 x) = toObject x- gFromObject o = K1 <$> fromObject o+ gToObject cfg (K1 x) = toObject cfg x+ gFromObject cfg o = K1 <$> fromObjectWith cfg o -- Product type packing. class GProdPack f where- prodToObject :: f a -> [Object]+ prodToObject :: Config -> f a -> [Object] prodFromObject :: ( Applicative m , Monad m-#if (MIN_VERSION_base(4,13,0))- , MonadFail m-#endif+ , MonadValidate DecodeError m )- => [Object]- -> m (f a)+ => Config -> StateT [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 (GProdPack a, GProdPack b) => GProdPack (a :*: b) where+ prodToObject cfg (a :*: b) = prodToObject cfg a ++ prodToObject cfg b+ prodFromObject cfg = do+ f <- prodFromObject cfg+ g <- prodFromObject cfg+ pure $ f :*: g 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"+ prodToObject cfg (M1 x) = [gToObject cfg x]+ prodFromObject cfg = do+ objs <- get+ case objs of+ (x:xs) -> do+ put xs+ M1 <$> gFromObject cfg x+ _ -> refute "invalid encoding for product type" -- Sum type packing.@@ -82,67 +95,63 @@ checkSumFromObject0 :: ( Applicative m , Monad m-#if (MIN_VERSION_base(4,13,0))- , MonadFail m-#endif+ , MonadValidate DecodeError m )- => (GSumPack f) => Word64 -> Word64 -> m (f a)-checkSumFromObject0 size code | code < size = sumFromObject code size ObjectNil- | otherwise = fail "invalid encoding for sum type"+ => (GSumPack f) => Config -> Word64 -> Word64 -> m (f a)+checkSumFromObject0 cfg size code+ | code < size = sumFromObject cfg code size ObjectNil+ | otherwise = refute "invalid encoding for sum type" checkSumFromObject :: ( Applicative m , Monad m-#if (MIN_VERSION_base(4,13,0))- , MonadFail m-#endif+ , MonadValidate DecodeError 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"+ => (GSumPack f) => Config -> Word64 -> Word64 -> Object -> m (f a)+checkSumFromObject cfg size code x+ | code < size = sumFromObject cfg code size x+ | otherwise = refute "invalid encoding for sum type" class GSumPack f where- sumToObject :: Word64 -> Word64 -> f a -> Object+ sumToObject :: Config -> Word64 -> Word64 -> f a -> Object sumFromObject :: ( Applicative m , Monad m-#if (MIN_VERSION_base(4,13,0))- , MonadFail m-#endif+ , MonadValidate DecodeError m )- => Word64+ => Config -> 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+ sumToObject cfg code size = \case+ L1 x -> sumToObject cfg code sizeL x+ R1 x -> sumToObject cfg (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+ sumFromObject cfg code size x+ | code < sizeL = L1 <$> sumFromObject cfg code sizeL x+ | otherwise = R1 <$> sumFromObject cfg (code - sizeL) sizeR x where sizeL = size `shiftR` 1 sizeR = size - sizeL instance GSumPack (C1 c U1) where- sumToObject code _ _ = toObject code- sumFromObject _ _ = gFromObject+ sumToObject cfg code _ _ = toObject cfg code+ sumFromObject cfg _ _ = gFromObject cfg instance GMessagePack a => GSumPack (C1 c a) where- sumToObject code _ x = toObject (code, gToObject x)- sumFromObject _ _ = gFromObject+ sumToObject cfg code _ x = toObject cfg (code, gToObject cfg x)+ sumFromObject cfg _ _ = gFromObject cfg -- Sum size.
test/Data/MessagePack/Types/ClassSpec.hs view
@@ -10,6 +10,8 @@ import Control.Applicative (empty, pure, (<$>), (<*>), (<|>)) import Control.Monad (mplus, mzero)+import Control.Monad.Validate (MonadValidate (..),+ runValidate) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.HashMap.Strict as HashMap@@ -19,7 +21,8 @@ import qualified Data.Map as Map import Data.MessagePack.Types (Assoc (..), MessagePack (..),- Object (..))+ Object (..), defaultConfig,+ errorMessages) import qualified Data.Text as Text import qualified Data.Text.Lazy as LText import qualified Data.Vector as V@@ -36,7 +39,7 @@ import Test.QuickCheck.Arbitrary.Generic (genericArbitrary) data MyType- = SequenceTyCon Int String+ = SequenceTyCon Int String Int Int | EnumTyCon | RecordTyCon { intValue :: Int } | F01 Int8@@ -96,108 +99,117 @@ arbitrary = HashMap.fromList <$> arbitrary +type Result a = Either [String] a++decode :: MessagePack a => Object -> Result a+decode = mapLeft errorMessages . runValidate . fromObjectWith defaultConfig+ where+ mapLeft f (Left a) = Left (f a)+ mapLeft _ (Right b) = Right b++ spec :: Spec spec = do describe "GMessagePack" $ do it "is a reversible operation" $ withMaxSuccess 10000 $ property- $ \(x :: MyType) -> fromObject (toObject x) `shouldBe` Just x+ $ \(x :: MyType) -> decode (toObject defaultConfig x) `shouldBe` Right x it "handles arbitrary values" $ withMaxSuccess 10000 $ property- $ \ob -> fromObject ob `shouldSatisfy` \case- Just EnumTyCon -> True- Just _ -> True- Nothing -> True+ $ \ob -> decode ob `shouldSatisfy` \case+ Right EnumTyCon -> True+ Right _ -> True+ Left _ -> True it "produces msgpack values as expected" $ do- toObject (SequenceTyCon 111 "hello")+ toObject defaultConfig (SequenceTyCon 111 "hello" 2 3) `shouldBe` ObjectArray [ ObjectWord 0- , ObjectArray [ObjectWord 111, ObjectStr "hello"]+ , ObjectArray [ObjectWord 111, ObjectStr "hello", ObjectWord 2, ObjectWord 3] ]- toObject EnumTyCon `shouldBe` ObjectWord 1- toObject (RecordTyCon 222)+ toObject defaultConfig EnumTyCon `shouldBe` ObjectWord 1+ toObject defaultConfig (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+ (decode $ ObjectArray [ObjectWord 1, ObjectWord 222] :: Result MyType)+ `shouldBe` Left ["invalid encoding for custom unit type"]+ (decode ObjectNil :: Result MyType)+ `shouldBe` Left ["invalid encoding for tuple"]+ (decode $ ObjectArray [ObjectWord 99999] :: Result MyType)+ `shouldBe` Left ["invalid encoding for tuple"]+ (decode $ ObjectArray [] :: Result MyType)+ `shouldBe` Left ["invalid encoding for tuple"]+ (decode ObjectNil :: Result Int64)+ `shouldBe` Left ["invalid encoding for integer type"]+ (decode ObjectNil :: Result BS.ByteString)+ `shouldBe` Left ["invalid encoding for ByteString"]+ (decode ObjectNil :: Result LBS.ByteString)+ `shouldBe` Left ["invalid encoding for ByteString"]+ (decode ObjectNil :: Result Text.Text)+ `shouldBe` Left ["invalid encoding for Text"]+ (decode ObjectNil :: Result LText.Text)+ `shouldBe` Left ["invalid encoding for Text"]+ (decode ObjectNil :: Result (V.Vector Int))+ `shouldBe` Left ["invalid encoding for Vector"]+ (decode ObjectNil :: Result (VU.Vector Int))+ `shouldBe` Left ["invalid encoding for Unboxed Vector"]+ (decode ObjectNil :: Result (VS.Vector Int))+ `shouldBe` Left ["invalid encoding for Storable Vector"]+ (decode ObjectNil :: Result (Assoc [(Int, Int)]))+ `shouldBe` Left ["invalid encoding for Assoc"]+ (decode ObjectNil :: Result (Map.Map Int Int))+ `shouldBe` Left ["invalid encoding for Assoc"]+ (decode ObjectNil :: Result (IntMap.IntMap Int))+ `shouldBe` Left ["invalid encoding for Assoc"]+ (decode ObjectNil :: Result (HashMap.HashMap Int Int))+ `shouldBe` Left ["invalid encoding for Assoc"]+ (decode ObjectNil :: Result Word64)+ `shouldBe` Left ["invalid encoding for integer type"]+ (decode (ObjectArray [ObjectWord 0]) :: Result ())+ `shouldBe` Left ["invalid encoding for ()"]+ (decode ObjectNil :: Result (Int, Int))+ `shouldBe` Left ["invalid encoding for tuple"]+ (decode ObjectNil :: Result (Int, Int, Int))+ `shouldBe` Left ["invalid encoding for tuple"]+ (decode ObjectNil :: Result (Int, Int, Int, Int))+ `shouldBe` Left ["invalid encoding for tuple"]+ (decode ObjectNil :: Result (Int, Int, Int, Int, Int))+ `shouldBe` Left ["invalid encoding for tuple"]+ (decode ObjectNil :: Result (Int, Int, Int, Int, Int, Int))+ `shouldBe` Left ["invalid encoding for tuple"]+ (decode ObjectNil :: Result (Int, Int, Int, Int, Int, Int, Int))+ `shouldBe` Left ["invalid encoding for tuple"]+ (decode ObjectNil :: Result (Int, Int, Int, Int, Int, Int, Int, Int))+ `shouldBe` Left ["invalid encoding for tuple"]+ (decode $ ObjectArray [ObjectNil, ObjectNil] :: Result (Int, String))+ `shouldBe` Left ["invalid encoding for integer type", "invalid encoding for Text"] 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 ()+ (decode ObjectNil :: Result ())+ `shouldBe` Right ()+ (decode (ObjectArray []) :: Result ())+ `shouldBe` Right () 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)+ (decode (ObjectDouble 123) :: Result Float)+ `shouldBe` Right 123+ (decode (ObjectWord 123) :: Result Float)+ `shouldBe` Right 123+ (decode (ObjectInt (-123)) :: Result Float)+ `shouldBe` Right (-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)+ (decode (ObjectFloat 123) :: Result Double)+ `shouldBe` Right 123+ (decode (ObjectWord 123) :: Result Double)+ `shouldBe` Right 123+ (decode (ObjectInt (-123)) :: Result Double)+ `shouldBe` Right (-123)