diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,5 +1,10 @@ # Changelog for `proto-lens` +## v0.3.1.0 +- Improve references to types/fields in decoding error messages (#187). +- Bump the dependency on `base` for `ghc-8.4.2`. +- Make `Registry` an instance of `Semigroup`. + ## v0.3.0.0 - Remove support for `ghc-7.10`. (#136) - Use a `.cabal` file that's auto-generated from `hpack`. (#138) diff --git a/proto-lens.cabal b/proto-lens.cabal --- a/proto-lens.cabal +++ b/proto-lens.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: f4741b76c0ffaab3c07146f386e2d9d450fa3c819af4f8631f11b4abf8f1feb4 +-- hash: 6ef7e9800a08c809a7ad77530c6f12c23b400af2c6c559a35f1a28e088bc3625 name: proto-lens -version: 0.3.0.0 +version: 0.3.1.0 synopsis: A lens-based implementation of protocol buffers in Haskell. description: The proto-lens library provides to protocol buffers using modern Haskell language and library patterns. Specifically, it provides: . @@ -42,7 +42,7 @@ src build-depends: attoparsec ==0.13.* - , base >=4.8 && <4.11 + , base >=4.8 && <4.12 , bytestring ==0.10.* , containers ==0.5.* , data-default-class >=0.0 && <0.2 diff --git a/src/Data/ProtoLens/Encoding.hs b/src/Data/ProtoLens/Encoding.hs --- a/src/Data/ProtoLens/Encoding.hs +++ b/src/Data/ProtoLens/Encoding.hs @@ -14,6 +14,7 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Data.ProtoLens.Encoding( encodeMessage, buildMessage, @@ -31,8 +32,10 @@ import Data.Attoparsec.ByteString as Parse import Data.Bool (bool) import Data.Monoid ((<>)) +import Data.Proxy (Proxy(Proxy)) import Data.Text.Encoding (encodeUtf8, decodeUtf8') import Data.Text.Encoding.Error (UnicodeException(..)) +import qualified Data.Text as T import qualified Data.ByteString as B import qualified Data.Map.Strict as Map import Data.ByteString.Lazy.Builder as Builder @@ -51,7 +54,7 @@ -- | Parse a message with the given ending delimiter (which will be EndGroup in -- the case of a group, and end-of-input otherwise). parseMessage :: forall msg . Message msg => Parser () -> Parser msg -parseMessage end = do +parseMessage end = (Parse. T.unpack (messageName (Proxy @msg))) $ do (msg, unsetFields) <- loop def requiredFields if Map.null unsetFields then return $ over unknownFields reverse @@ -73,6 +76,7 @@ Nothing -> (loop $! addUnknown tv msg) unsetFields Just field -> do !msg' <- parseAndAddField msg field tv + fieldDescriptorName field loop msg' $! Map.delete tag unsetFields -- | Decode a message from its wire format. Throws an error if the decoding @@ -91,25 +95,25 @@ -> Parser msg parseAndAddField !msg - (FieldDescriptor name typeDescriptor accessor) + (FieldDescriptor _ typeDescriptor accessor) (TaggedValue tag (WireValue wt val)) = let getSimpleVal = case typeDescriptor of MessageField GroupType -> do - Equal <- equalWireTypes name StartGroup wt - parseMessage (endOfGroup name tag) + Equal <- equalWireTypes StartGroup wt + parseMessage (endOfGroup tag) MessageField MessageType -> do - Equal <- equalWireTypes name Lengthy wt + Equal <- equalWireTypes Lengthy wt runEither $ decodeMessage val ScalarField f -> case fieldWireType f of FieldWireType fieldWt _ get -> do - Equal <- equalWireTypes name fieldWt wt + Equal <- equalWireTypes fieldWt wt runEither $ get val -- Get a block of packed values, reversed. getPackedVals = case typeDescriptor of MessageField _ -> fail "Messages can't be packed" ScalarField f -> case fieldWireType f of FieldWireType fieldWt _ get -> do - Equal <- equalWireTypes name Lengthy wt + Equal <- equalWireTypes Lengthy wt let getElt = do wv <- getWireValue fieldWt x <- runEither $ get wv @@ -133,8 +137,7 @@ <|> (do xs <- getPackedVals return $! over' f (xs ++) msg) - <|> fail ("Field " ++ name - ++ " expects a repeated field wire type but found " + <|> fail ("Expected a repeated field wire type but found " ++ show wt) MapField keyLens valueLens f -> do entry <- getSimpleVal @@ -259,10 +262,10 @@ (stringizeError . decodeUtf8') fieldWireType BytesField = identityFieldWireType Lengthy -endOfGroup :: String -> Tag -> Parser () -endOfGroup name tag = do +endOfGroup :: Tag -> Parser () +endOfGroup tag = do TaggedValue tag' (WireValue wt _) <- getTaggedValue - Equal <- equalWireTypes name EndGroup wt + Equal <- equalWireTypes EndGroup wt guard (tag == tag') -- | Helper function to define a field type whose decoding operation can't fail. diff --git a/src/Data/ProtoLens/Encoding/Wire.hs b/src/Data/ProtoLens/Encoding/Wire.hs --- a/src/Data/ProtoLens/Encoding/Wire.hs +++ b/src/Data/ProtoLens/Encoding/Wire.hs @@ -87,27 +87,27 @@ -- Assert that two wire types are the same, or fail with a message about this -- field. {-# INLINE equalWireTypes #-} -equalWireTypes :: Monad m => String -> WireType a -> WireType b +equalWireTypes :: Monad m => WireType a -> WireType b -> m (Equal a b) -equalWireTypes _ VarInt VarInt = return Equal -equalWireTypes _ Fixed64 Fixed64 = return Equal -equalWireTypes _ Fixed32 Fixed32 = return Equal -equalWireTypes _ Lengthy Lengthy = return Equal -equalWireTypes _ StartGroup StartGroup = return Equal -equalWireTypes _ EndGroup EndGroup = return Equal -equalWireTypes name expected actual - = fail $ "Field " ++ name ++ " expects wire type " ++ show expected +equalWireTypes VarInt VarInt = return Equal +equalWireTypes Fixed64 Fixed64 = return Equal +equalWireTypes Fixed32 Fixed32 = return Equal +equalWireTypes Lengthy Lengthy = return Equal +equalWireTypes StartGroup StartGroup = return Equal +equalWireTypes EndGroup EndGroup = return Equal +equalWireTypes expected actual + = fail $ "Expected wire type " ++ show expected ++ " but found " ++ show actual instance Eq WireValue where WireValue t v == WireValue t' v' - | Just Equal <- equalWireTypes "" t t' + | Just Equal <- equalWireTypes t t' = v == v' | otherwise = False instance Ord WireValue where WireValue t v `compare` WireValue t' v' - | Just Equal <- equalWireTypes "" t t' + | Just Equal <- equalWireTypes t t' = v `compare` v' | otherwise = wireTypeToInt t `compare` wireTypeToInt t' diff --git a/src/Data/ProtoLens/Message.hs b/src/Data/ProtoLens/Message.hs --- a/src/Data/ProtoLens/Message.hs +++ b/src/Data/ProtoLens/Message.hs @@ -61,6 +61,7 @@ import Data.Word import Lens.Family2 (Lens', over, set) import Lens.Family2.Unchecked (lens) +import qualified Data.Semigroup as Semigroup import Data.ProtoLens.Encoding.Wire ( Tag(..) @@ -285,7 +286,7 @@ -- -- See the @withRegistry@ functions in 'Data.ProtoLens.TextFormat' newtype Registry = Registry (Map.Map T.Text SomeMessageType) - deriving Monoid + deriving (Semigroup.Semigroup, Monoid) -- | Build a 'Registry' containing a single proto type. -- diff --git a/src/Data/ProtoLens/TextFormat.hs b/src/Data/ProtoLens/TextFormat.hs --- a/src/Data/ProtoLens/TextFormat.hs +++ b/src/Data/ProtoLens/TextFormat.hs @@ -5,6 +5,7 @@ -- https://developers.google.com/open-source/licenses/bsd -- | Functions for converting protocol buffers to a human-readable text format. +{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternGuards #-} @@ -39,6 +40,10 @@ import Numeric (showOct) import Text.Parsec (parse) import Text.PrettyPrint + +#if MIN_VERSION_base(4,11,0) +import Prelude hiding ((<>)) +#endif import Data.ProtoLens.Encoding.Wire import Data.ProtoLens.Message