msgpack-binary 0.0.14 → 0.0.15
raw patch · 4 files changed
+55/−72 lines, 4 filesdep +monad-validatedep ~msgpack-types
Dependencies added: monad-validate
Dependency ranges changed: msgpack-types
Files
- msgpack-binary.cabal +5/−4
- src/Data/MessagePack.hs +33/−7
- test/Data/MessagePackSpec.hs +16/−60
- test/Data/Result.hs +1/−1
msgpack-binary.cabal view
@@ -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
src/Data/MessagePack.hs view
@@ -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
test/Data/MessagePackSpec.hs view
@@ -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\"]"
test/Data/Result.hs view
@@ -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