diff --git a/msgpack-binary.cabal b/msgpack-binary.cabal --- a/msgpack-binary.cabal +++ b/msgpack-binary.cabal @@ -1,5 +1,5 @@ name: msgpack-binary -version: 0.0.14 +version: 0.0.15 synopsis: A Haskell implementation of MessagePack homepage: http://msgpack.org/ license: BSD3 @@ -35,11 +35,12 @@ Data.MessagePack.Get Data.MessagePack.Put build-depends: - base < 5 - , binary >= 0.7.0.0 + base < 5 + , binary >= 0.7.0.0 , bytestring , data-binary-ieee754 - , msgpack-types >= 0.0.1 && < 0.1.0 + , monad-validate + , msgpack-types >= 0.2 && < 0.3 , text executable msgpack-parser diff --git a/src/Data/MessagePack.hs b/src/Data/MessagePack.hs --- a/src/Data/MessagePack.hs +++ b/src/Data/MessagePack.hs @@ -1,6 +1,8 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE Safe #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Trustworthy #-} +{-# OPTIONS_GHC -Wno-orphans #-} -------------------------------------------------------------------- -- | -- Module : Data.MessagePack @@ -19,6 +21,8 @@ -- * Simple interface to pack and unpack msgpack binary pack , unpack + , unpackEither + , unpackValidate -- * Re-export modules -- $reexports @@ -27,7 +31,9 @@ import Control.Applicative (Applicative) import Control.Monad ((>=>)) +import Control.Monad.Validate (MonadValidate (..), runValidate) import Data.Binary (Binary (..), decodeOrFail, encode) +import Data.Binary.Get (Get) import qualified Data.ByteString.Lazy as L import Data.MessagePack.Get as X @@ -37,8 +43,24 @@ -- | Pack a Haskell value to MessagePack binary. pack :: MessagePack a => a -> L.ByteString -pack = encode . toObject +pack = encode . toObject defaultConfig +-- | Unpack MessagePack binary to a Haskell value. +-- +-- On failure, returns a list of error messages. +unpackValidate :: (MonadValidate DecodeError m, MessagePack a) + => L.ByteString -> m a +unpackValidate = eitherToM . decodeOrFail >=> fromObjectWith defaultConfig + where + eitherToM (Left (_, _, msg)) = refute $ decodeError msg + eitherToM (Right (_, _, res)) = return res + + +unpackEither :: (MessagePack a) + => L.ByteString -> Either DecodeError a +unpackEither = runValidate . unpackValidate + + -- | Unpack MessagePack binary to a Haskell value. If it fails, it fails in the -- Monad. In the Maybe monad, failure returns Nothing. #if (MIN_VERSION_base(4,13,0)) @@ -47,10 +69,10 @@ unpack :: (Applicative m, Monad m, MessagePack a) #endif => L.ByteString -> m a -unpack = eitherToM . decodeOrFail >=> fromObject +unpack = eitherToM . unpackEither where - eitherToM (Left (_, _, msg)) = fail msg - eitherToM (Right (_, _, res)) = return res + eitherToM (Left msgs) = fail $ show msgs + eitherToM (Right res) = return res instance Binary Object where @@ -59,3 +81,7 @@ put = putObject {-# INLINE put #-} + +instance MonadValidate DecodeError Get where + refute = fail . show + tolerate m = m >> return Nothing diff --git a/test/Data/MessagePackSpec.hs b/test/Data/MessagePackSpec.hs --- a/test/Data/MessagePackSpec.hs +++ b/test/Data/MessagePackSpec.hs @@ -1,6 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} {-# LANGUAGE Trustworthy #-} module Data.MessagePackSpec where @@ -12,8 +13,8 @@ import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy as L8 import qualified Data.ByteString.Lazy.Char8 as L -import Data.Hashable (Hashable) import qualified Data.HashMap.Strict as HashMap +import Data.Hashable (Hashable) import Data.Int (Int16, Int32, Int64, Int8) import qualified Data.IntMap as IntMap import qualified Data.Map as Map @@ -23,7 +24,6 @@ import qualified Data.Vector as V import qualified Data.Vector.Storable as VS import qualified Data.Vector.Unboxed as VU -import Data.Void (Void) import Data.Word (Word, Word16, Word32, Word64, Word8) import GHC.Generics (Generic) @@ -60,10 +60,9 @@ | Foo4 Int | Foo5 Int | Foo6 { unFoo3 :: Int } - | Foo7 (Maybe Foo) - | Foo8 Int - | Foo9 Int Int - | Foo10 Int Int Int + | Foo7 Int + | Foo8 Int Int + | Foo9 Int Int Int deriving (Eq, Show, Generic) instance MessagePack Foo @@ -77,9 +76,8 @@ , Foo5 <$> arbitrary , Foo6 <$> arbitrary , Foo7 <$> arbitrary - , Foo8 <$> arbitrary - , Foo9 <$> arbitrary <*> arbitrary - , Foo10 <$> arbitrary <*> arbitrary <*> arbitrary + , Foo8 <$> arbitrary <*> arbitrary + , Foo9 <$> arbitrary <*> arbitrary <*> arbitrary ] @@ -147,7 +145,6 @@ checkMessage (unpack (pack $ ObjectInt (-1)) :: R.Result Foo) checkMessage (unpack (pack [ObjectInt (-1), ObjectInt 0]) :: R.Result Foo) checkMessage (unpack (pack $ ObjectArray []) :: R.Result TyConArgs) - checkMessage (unpack (pack [0 :: Int, 1, 2, 3]) :: R.Result TyConArgs) checkMessage (unpack (pack $ ObjectArray []) :: R.Result Record) checkMessage (unpack (pack [0 :: Int, 1, 2, 3]) :: R.Result Record) checkMessage (unpack (pack "") :: R.Result Unit) @@ -284,8 +281,6 @@ property $ \(a :: L.ByteString) -> a `shouldBe` mid a it "lazy-text" $ property $ \(a :: LT.Text) -> a `shouldBe` mid a - it "maybe int" $ - property $ \(a :: (Maybe Int)) -> a `shouldBe` mid a it "[int]" $ property $ \(a :: [Int]) -> a `shouldBe` mid a it "vector int" $ @@ -324,42 +319,6 @@ property $ \(a :: IntMap.IntMap Int) -> a `shouldBe` mid a it "HashMap String Int" $ property $ \(a :: HashMap.HashMap String Int) -> a `shouldBe` mid a - it "maybe int" $ - property $ \(a :: Maybe Int) -> a `shouldBe` mid a - it "maybe nil" $ - property $ \(a :: Maybe ()) -> a `shouldBe` mid a - it "maybe maybe int" $ - property $ \(a :: Maybe (Maybe Int)) -> a `shouldBe` mid a - it "maybe bool" $ - property $ \(a :: Maybe Bool) -> a `shouldBe` mid a - it "maybe double" $ - property $ \(a :: Maybe Double) -> a `shouldBe` mid a - it "maybe string" $ - property $ \(a :: Maybe String) -> a `shouldBe` mid a - it "maybe bytestring" $ - property $ \(a :: Maybe S.ByteString) -> a `shouldBe` mid a - it "maybe lazy-bytestring" $ - property $ \(a :: Maybe L.ByteString) -> a `shouldBe` mid a - it "maybe [int]" $ - property $ \(a :: Maybe [Int]) -> a `shouldBe` mid a - it "maybe [string]" $ - property $ \(a :: Maybe [String]) -> a `shouldBe` mid a - it "maybe (int, int)" $ - property $ \(a :: Maybe (Int, Int)) -> a `shouldBe` mid a - it "maybe (int, int, int)" $ - property $ \(a :: Maybe (Int, Int, Int)) -> a `shouldBe` mid a - it "maybe (int, int, int, int)" $ - property $ \(a :: Maybe (Int, Int, Int, Int)) -> a `shouldBe` mid a - it "maybe (int, int, int, int, int)" $ - property $ \(a :: Maybe (Int, Int, Int, Int, Int)) -> a `shouldBe` mid a - it "maybe [(int, double)]" $ - property $ \(a :: Maybe [(Int, Double)]) -> a `shouldBe` mid a - it "maybe [(string, string)]" $ - property $ \(a :: Maybe [(String, String)]) -> a `shouldBe` mid a - it "maybe (Assoc [(string, int)])" $ - property $ \(a :: Maybe (Assoc [(String, Int)])) -> a `shouldBe` mid a - it "either int float" $ - property $ \(a :: Either Int Float) -> a `shouldBe` mid a it "generics" $ property $ \(a :: Foo) -> a `shouldBe` mid a @@ -375,19 +334,16 @@ describe "show" $ do it "Foo" $ do - show (toObject Foo1) `shouldBe` "ObjectWord 0" - show (toObject $ Foo3 3) `shouldBe` "ObjectArray [ObjectWord 2,ObjectWord 3]" - show (toObject $ Foo3 (-3)) `shouldBe` "ObjectArray [ObjectWord 2,ObjectInt (-3)]" - show (toObject $ Foo9 3 5) `shouldBe` "ObjectArray [ObjectWord 8,ObjectArray [ObjectWord 3,ObjectWord 5]]" - show (toObject $ Foo9 (-3) (-5)) `shouldBe` "ObjectArray [ObjectWord 8,ObjectArray [ObjectInt (-3),ObjectInt (-5)]]" - show (toObject $ Foo10 3 5 7) `shouldBe` "ObjectArray [ObjectWord 9,ObjectArray [ObjectWord 3,ObjectWord 5,ObjectWord 7]]" - show (toObject $ Foo10 (-3) (-5) 7) `shouldBe` "ObjectArray [ObjectWord 9,ObjectArray [ObjectInt (-3),ObjectInt (-5),ObjectWord 7]]" + show (toObject defaultConfig Foo1) `shouldBe` "ObjectWord 0" + show (toObject defaultConfig $ Foo3 3) `shouldBe` "ObjectArray [ObjectWord 2,ObjectWord 3]" + show (toObject defaultConfig $ Foo3 (-3)) `shouldBe` "ObjectArray [ObjectWord 2,ObjectInt (-3)]" + show (toObject defaultConfig $ Foo8 3 5) `shouldBe` "ObjectArray [ObjectWord 7,ObjectArray [ObjectWord 3,ObjectWord 5]]" + show (toObject defaultConfig $ Foo8 (-3) (-5)) `shouldBe` "ObjectArray [ObjectWord 7,ObjectArray [ObjectInt (-3),ObjectInt (-5)]]" + show (toObject defaultConfig $ Foo9 3 5 7) `shouldBe` "ObjectArray [ObjectWord 8,ObjectArray [ObjectWord 3,ObjectWord 5,ObjectWord 7]]" + show (toObject defaultConfig $ Foo9 (-3) (-5) 7) `shouldBe` "ObjectArray [ObjectWord 8,ObjectArray [ObjectInt (-3),ObjectInt (-5),ObjectWord 7]]" it "TyConArgs" $ - show (toObject $ TyConArgs 3 5 7) `shouldBe` "ObjectArray [ObjectWord 3,ObjectWord 5,ObjectWord 7]" + show (toObject defaultConfig $ TyConArgs 3 5 7) `shouldBe` "ObjectArray [ObjectWord 3,ObjectWord 5,ObjectWord 7]" it "Record" $ - show (toObject $ Record 3 5 "7") `shouldBe` "ObjectArray [ObjectWord 3,ObjectDouble 5.0,ObjectStr \"7\"]" - -voidTest :: Void -> Object -voidTest = toObject + show (toObject defaultConfig $ Record 3 5 "7") `shouldBe` "ObjectArray [ObjectWord 3,ObjectDouble 5.0,ObjectStr \"7\"]" diff --git a/test/Data/Result.hs b/test/Data/Result.hs --- a/test/Data/Result.hs +++ b/test/Data/Result.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE Safe #-} +{-# LANGUAGE StrictData #-} module Data.Result ( Result (..) ) where @@ -21,7 +22,6 @@ instance Monad Result where return = Success - fail = Failure Success x >>= f = f x Failure msg >>= _ = Failure msg