diff --git a/Changes b/Changes new file mode 100644 --- /dev/null +++ b/Changes @@ -0,0 +1,95 @@ +Newest at the top. + +2.4.17 + +- PR #94. Change code generate for `mergeAppend` to avoid triggering GHC bug +- Fixes generated code for GHC-8.10 +- Some more small improvements of the generated code + +2.4.16 + +- PR #93. Fix up a534ea to support older base16-bytestring again, via CPP + +2.4.15 + +- PR #92. Allow newer haskell-src-exts and test for GHC-8.10.2 +- PR #90. Use base16-bytestring >= 1.0.0.0 after 'decode' API change + +2.4.14 + +- Issue #89 defaultUserHooks in Setup.hs is deprecated + +2.4.13 + +- Fix build for GHC-8.8 + +2.4.12 + +- New option to derive ToJSON/FromJSON +- Fix build for GHC-8.6 +- Drop support for GHC-7.10 +- New testsuite + +2.4.11 + +- pr #66. Attach deriving Typeable to data declaration in hs-boot files +- pr #65. Fix time complexity of serialization + +2.4.10 + +- pr #59. Add Semigroup instance + +2.4.9 + +- pr #48. Make parser float support natural or float data format + +2.4.8 + +- pr #58. Fix build for HSE-1.20 + +2.4.7 + +- pr #57. Add GHC 8.4 support (add Semigroup instances) + +2.4.6 + +- issue #55. Constraint haskell-src-exts to be < 1.20 + +2.4.5 + +- pr #54. Support haskell-src-exts 1.18 + +2.4.4 + +- pr #53. Allow decimal places at the end of line + +2.4.3 + +- pr #50. restrict haskell-src-exts version constraint + +2.4.2 + +- fix version constraints + +2.4.1 + +- issue #10, pr #47. Fixed not to lookup a entity defined in the parent package + +2.3.1: + +- add Generic deriving + +2016-03-22 2.3.0: + +- Dump to text as decimal instead of octal (PR #34) +- Oneof lenses + +2008-09: 0.3.1: + +- Change Parser.hs to allow negative enum values to match actual behavior of protoc. +- Use runST & castSTUArray for both Float and Double conversion to Word32 and Word64. +- Adding UnknownField support controlled by "-u" flag to hprotoc. +- Fix messageGet to use the new 'isReallyEmpty' and Parial Results get Nothing, to work better. +- Fix default instances of Descriptor messages to be Nothing instead of Just defaultValue. + +2008-09 : version 0.2.9 released. This is the first working release. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ import Distribution.Simple -main = defaultMainWithHooks defaultUserHooks +main = defaultMainWithHooks simpleUserHooks diff --git a/Text/ProtocolBuffers/Basic.hs b/Text/ProtocolBuffers/Basic.hs --- a/Text/ProtocolBuffers/Basic.hs +++ b/Text/ProtocolBuffers/Basic.hs @@ -22,6 +22,7 @@ import Data.Ix(Ix) import Data.Semigroup (Semigroup(..)) import Data.Sequence(Seq,(><)) +import Data.String (IsString(..)) import Data.Typeable(Typeable) import Data.Word(Word8,Word32,Word64) @@ -51,6 +52,9 @@ showsPrec d (Utf8 bs) = let s :: Int -> String -> ShowS s = showsPrec in s d (U.toString bs) + +instance IsString Utf8 where + fromString = uFromString instance Semigroup Utf8 where (<>) (Utf8 x) (Utf8 y) = Utf8 (x <> y) diff --git a/Text/ProtocolBuffers/Get.hs b/Text/ProtocolBuffers/Get.hs --- a/Text/ProtocolBuffers/Get.hs +++ b/Text/ProtocolBuffers/Get.hs @@ -75,6 +75,7 @@ --import qualified Data.ByteString as S(unpack) -- XXX testing --import qualified Data.ByteString.Lazy as L(pack) -- XXX testing import Control.Monad(ap) -- instead of Functor.fmap; ap for Applicative +import qualified Control.Monad.Fail as Fail import Data.Bits(Bits((.|.),(.&.)),shiftL) import qualified Data.ByteString as S(concat,length,null,splitAt,findIndex) import qualified Data.ByteString.Internal as S(ByteString(..),toForeignPtr,inlinePerformIO) @@ -130,77 +131,77 @@ let (TU'OK x i) = unsafePerformIO $ withForeignPtr fp $ \ptr0 -> do if ptr0 == nullPtr || len < 1 then error "Get.decode7unrolled: ByteString invariant failed" else do - let ok :: s -> Int -> IO (TU s) - ok x0 i0 = return (TU'OK x0 i0) - more,err :: IO (TU s) - more = return (TU'OK 0 0) -- decode7 - err = return (TU'OK 0 (-1)) -- throwError - {-# INLINE ok #-} - {-# INLINE more #-} - {-# INLINE err #-} + let ok :: s -> Int -> IO (TU s) + ok x0 i0 = return (TU'OK x0 i0) + more,err :: IO (TU s) + more = return (TU'OK 0 0) -- decode7 + err = return (TU'OK 0 (-1)) -- throwError + {-# INLINE ok #-} + {-# INLINE more #-} + {-# INLINE err #-} --- -- Next line is segfault fix for null bytestrings from Nathan Howell --- if ptr0 == nullPtr then more else do + -- -- Next line is segfault fix for null bytestrings from Nathan Howell + -- if ptr0 == nullPtr then more else do - let start = ptr0 `plusPtr` off :: Ptr Word8 - b'1 <- peek start - if b'1 < 128 then ok (fromIntegral b'1) 1 else do - let !val'1 = fromIntegral (b'1 .&. 0x7F) - !end = start `plusPtr` len - !ptr2 = start `plusPtr` 1 :: Ptr Word8 - if ptr2 >= end then more else do + let start = ptr0 `plusPtr` off :: Ptr Word8 + b'1 <- peek start + if b'1 < 128 then ok (fromIntegral b'1) 1 else do + let !val'1 = fromIntegral (b'1 .&. 0x7F) + !end = start `plusPtr` len + !ptr2 = start `plusPtr` 1 :: Ptr Word8 + if ptr2 >= end then more else do - b'2 <- peek ptr2 - if b'2 < 128 then ok (val'1 .|. (fromIntegral b'2 `shiftL` 7)) 2 else do - let !val'2 = (val'1 .|. (fromIntegral (b'2 .&. 0x7F) `shiftL` 7)) - !ptr3 = ptr2 `plusPtr` 1 - if ptr3 >= end then more else do + b'2 <- peek ptr2 + if b'2 < 128 then ok (val'1 .|. (fromIntegral b'2 `shiftL` 7)) 2 else do + let !val'2 = (val'1 .|. (fromIntegral (b'2 .&. 0x7F) `shiftL` 7)) + !ptr3 = ptr2 `plusPtr` 1 + if ptr3 >= end then more else do - b'3::Word8 <- peek ptr3 - if b'3 < 128 then ok (val'2 .|. (fromIntegral b'3 `shiftL` 14)) 3 else do - let !val'3 = (val'2 .|. (fromIntegral (b'3 .&. 0x7F) `shiftL` 14)) - !ptr4 = ptr3 `plusPtr` 1 - if ptr4 >= end then more else do + b'3::Word8 <- peek ptr3 + if b'3 < 128 then ok (val'2 .|. (fromIntegral b'3 `shiftL` 14)) 3 else do + let !val'3 = (val'2 .|. (fromIntegral (b'3 .&. 0x7F) `shiftL` 14)) + !ptr4 = ptr3 `plusPtr` 1 + if ptr4 >= end then more else do - b'4::Word8 <- peek ptr4 - if b'4 < 128 then ok (val'3 .|. (fromIntegral b'4 `shiftL` 21)) 4 else do - let !val'4 = (val'3 .|. (fromIntegral (b'4 .&. 0x7F) `shiftL` 21)) - !ptr5 = ptr4 `plusPtr` 1 - if ptr5 >= end then more else do + b'4::Word8 <- peek ptr4 + if b'4 < 128 then ok (val'3 .|. (fromIntegral b'4 `shiftL` 21)) 4 else do + let !val'4 = (val'3 .|. (fromIntegral (b'4 .&. 0x7F) `shiftL` 21)) + !ptr5 = ptr4 `plusPtr` 1 + if ptr5 >= end then more else do - b'5::Word8 <- peek ptr5 - if b'5 < 128 then ok (val'4 .|. (fromIntegral b'5 `shiftL` 28)) 5 else do - let !val'5 = (val'4 .|. (fromIntegral (b'5 .&. 0x7F) `shiftL` 28)) - !ptr6 = ptr5 `plusPtr` 1 - if ptr6 >= end then more else do + b'5::Word8 <- peek ptr5 + if b'5 < 128 then ok (val'4 .|. (fromIntegral b'5 `shiftL` 28)) 5 else do + let !val'5 = (val'4 .|. (fromIntegral (b'5 .&. 0x7F) `shiftL` 28)) + !ptr6 = ptr5 `plusPtr` 1 + if ptr6 >= end then more else do - b'6::Word8 <- peek ptr6 - if b'6 < 128 then ok (val'5 .|. (fromIntegral b'6 `shiftL` 35)) 6 else do - let !val'6 = (val'5 .|. (fromIntegral (b'6 .&. 0x7F) `shiftL` 35)) - !ptr7 = ptr6 `plusPtr` 1 - if ptr7 >= end then more else do + b'6::Word8 <- peek ptr6 + if b'6 < 128 then ok (val'5 .|. (fromIntegral b'6 `shiftL` 35)) 6 else do + let !val'6 = (val'5 .|. (fromIntegral (b'6 .&. 0x7F) `shiftL` 35)) + !ptr7 = ptr6 `plusPtr` 1 + if ptr7 >= end then more else do - b'7::Word8 <- peek ptr7 - if b'7 < 128 then ok (val'6 .|. (fromIntegral b'7 `shiftL` 42)) 7 else do - let !val'7 = (val'6 .|. (fromIntegral (b'7 .&. 0x7F) `shiftL` 42)) - !ptr8 = ptr7 `plusPtr` 1 - if ptr8 >= end then more else do + b'7::Word8 <- peek ptr7 + if b'7 < 128 then ok (val'6 .|. (fromIntegral b'7 `shiftL` 42)) 7 else do + let !val'7 = (val'6 .|. (fromIntegral (b'7 .&. 0x7F) `shiftL` 42)) + !ptr8 = ptr7 `plusPtr` 1 + if ptr8 >= end then more else do - b'8::Word8 <- peek ptr8 - if b'8 < 128 then ok (val'7 .|. (fromIntegral b'8 `shiftL` 49)) 8 else do - let !val'8 = (val'7 .|. (fromIntegral (b'8 .&. 0x7F) `shiftL` 49)) - !ptr9 = ptr8 `plusPtr` 1 - if ptr9 >= end then more else do + b'8::Word8 <- peek ptr8 + if b'8 < 128 then ok (val'7 .|. (fromIntegral b'8 `shiftL` 49)) 8 else do + let !val'8 = (val'7 .|. (fromIntegral (b'8 .&. 0x7F) `shiftL` 49)) + !ptr9 = ptr8 `plusPtr` 1 + if ptr9 >= end then more else do - b'9::Word8 <- peek ptr9 - if b'9 < 128 then ok (val'8 .|. (fromIntegral b'9 `shiftL` 56)) 9 else do - let !val'9 = (val'8 .|. (fromIntegral (b'9 .&. 0x7F) `shiftL` 56)) - !ptrA = ptr9 `plusPtr` 1 - if ptrA >= end then more else do + b'9::Word8 <- peek ptr9 + if b'9 < 128 then ok (val'8 .|. (fromIntegral b'9 `shiftL` 56)) 9 else do + let !val'9 = (val'8 .|. (fromIntegral (b'9 .&. 0x7F) `shiftL` 56)) + !ptrA = ptr9 `plusPtr` 1 + if ptrA >= end then more else do - b'A::Word8 <- peek ptrA - if b'A < 128 then ok (val'9 .|. (fromIntegral b'A `shiftL` 63)) 10 else do - err + b'A::Word8 <- peek ptrA + if b'A < 128 then ok (val'9 .|. (fromIntegral b'A `shiftL` 63)) 10 else do + err in if i > 0 then let ss' = (S.unsafeDrop i ss) @@ -232,44 +233,44 @@ | ptr < end = do w <- peek ptr trace ("w: " ++ show w) $ do - if (128>) w - then return $ T3 (succ (ptr `minusPtr` start) ) -- length of capture - (s .|. ((fromIntegral w) `shiftL` shift)) -- put the last bits into high position - (-1) -- negative shift indicates satisfied - else inner (ptr `plusPtr` 1) -- loop on next byte - (s .|. ((fromIntegral (w .&. 0x7F)) `shiftL` shift)) -- put the new bits into high position - (shift+7) -- increase high position for next loop + if (128>) w + then return $ T3 (succ (ptr `minusPtr` start) ) -- length of capture + (s .|. ((fromIntegral w) `shiftL` shift)) -- put the last bits into high position + (-1) -- negative shift indicates satisfied + else inner (ptr `plusPtr` 1) -- loop on next byte + (s .|. ((fromIntegral (w .&. 0x7F)) `shiftL` shift)) -- put the new bits into high position + (shift+7) -- increase high position for next loop | otherwise = return $ T3 (ptr `minusPtr` start) -- length so far (ptr past end-of-string so no succ) s -- value so far shift -- next shift to use inner start s1 shift1 (S ss bs n) <- getFull trace ("getFull says: "++ show ((S.length ss,ss),(L.length bs),n)) $ do - if S.null ss - then do - continue <- suspend - if continue - then go s1 shift1 - else fail "Get.decode7: Zero length input" -- XXX can be triggered! - else do - let (T3 i sOut shiftOut) = unsafePerformIO $ scanner ss - t = S.unsafeDrop i ss -- Warning: 't' may be mempty - n' = n + fromIntegral i - trace ("scanner says "++show ((i,toInteger sOut,shiftOut),(S.length t,n'))) $ do - if 0 <= shiftOut - then do - putFull_unsafe (make_state bs n') - if L.null bs + if S.null ss + then do + continue <- suspend + if continue + then go s1 shift1 + else fail "Get.decode7: Zero length input" -- XXX can be triggered! + else do + let (T3 i sOut shiftOut) = unsafePerformIO $ scanner ss + t = S.unsafeDrop i ss -- Warning: 't' may be mempty + n' = n + fromIntegral i + trace ("scanner says "++show ((i,toInteger sOut,shiftOut),(S.length t,n'))) $ do + if 0 <= shiftOut then do - continue <- suspend - if continue - then go sOut shiftOut - else return sOut + putFull_unsafe (make_state bs n') + if L.null bs + then do + continue <- suspend + if continue + then go sOut shiftOut + else return sOut + else do + go sOut shiftOut else do - go sOut shiftOut - else do - putFull_safe (S t bs n') -- bs from getFull is still valid - return sOut + putFull_safe (S t bs n') -- bs from getFull is still valid + return sOut data T2 = T2 !Int64 !Bool @@ -784,6 +785,11 @@ {-# INLINE return #-} m >>= k = Get (\sc -> unGet m (\ a -> seq a $ unGet (k a) sc)) {-# INLINE (>>=) #-} +#if !MIN_VERSION_base(4,11,0) + fail = Fail.fail +#endif + +instance Fail.MonadFail Get where fail = throwError . strMsg instance MonadError String Get where diff --git a/Text/ProtocolBuffers/ProtoJSON.hs b/Text/ProtocolBuffers/ProtoJSON.hs --- a/Text/ProtocolBuffers/ProtoJSON.hs +++ b/Text/ProtocolBuffers/ProtoJSON.hs @@ -41,5 +41,10 @@ parseJSONByteString = withObject "bytes" $ \o -> do t <- o .: "payload" case B16.decode (T.encodeUtf8 t) of +# if MIN_VERSION_base16_bytestring(1,0,0) + Right bs -> return (BL.fromStrict bs) + Left err -> fail $ "Failed to parse base16: " <> err +# else (bs, "") -> return (BL.fromStrict bs) _ -> fail "Failed to parse base16." +# endif diff --git a/Text/ProtocolBuffers/WireMessage.hs b/Text/ProtocolBuffers/WireMessage.hs --- a/Text/ProtocolBuffers/WireMessage.hs +++ b/Text/ProtocolBuffers/WireMessage.hs @@ -469,7 +469,7 @@ wireSizeErr ft x = error $ concat [ "Impossible? wireSize field type mismatch error: Field type number ", show ft , " does not match internal type ", show (typeOf x) ] wirePutErr :: Typeable a => FieldType -> a -> PutM b -wirePutErr ft x = fail $ concat [ "Impossible? wirePut field type mismatch error: Field type number ", show ft +wirePutErr ft x = error $ concat [ "Impossible? wirePut field type mismatch error: Field type number ", show ft , " does not match internal type ", show (typeOf x) ] wireGetErr :: Typeable a => FieldType -> Get a wireGetErr ft = answer where diff --git a/protocol-buffers.cabal b/protocol-buffers.cabal --- a/protocol-buffers.cabal +++ b/protocol-buffers.cabal @@ -1,6 +1,6 @@ name: protocol-buffers -version: 2.4.12 -cabal-version: >= 1.6 +version: 2.4.17 +cabal-version: >= 1.10 build-type: Simple license: BSD3 license-file: LICENSE @@ -14,12 +14,14 @@ category: Text extra-source-files: TODO README.md -Tested-With: GHC == 8.0.2, GHC == 8.2.1, GHC == 8.4.2, GHC == 8.6.2 + Changes +Tested-With: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.2, GHC == 8.6.2, GHC == 8.8.4, GHC == 8.10.2 source-repository head type: git location: git://github.com/k-bx/protocol-buffers.git Library + default-language: Haskell2010 -- Added -fspec-constr-count=10 to quiet ghc-7.0.2. ghc-options: -Wall -O2 -fspec-constr-count=10 -- ghc-prof-options: -auto-all -prof @@ -53,19 +55,19 @@ -- Most of these are needed for protocol-buffers (Get and WireMessage.hs) -- Nothing especially hazardous in this list - extensions: BangPatterns, - CPP, - DeriveDataTypeable, - EmptyDataDecls, - FlexibleInstances, - FunctionalDependencies, - GADTs, - GeneralizedNewtypeDeriving, - MagicHash, - MultiParamTypeClasses, - PatternGuards, - RankNTypes, - RecordWildCards - ScopedTypeVariables, - StandaloneDeriving, - TypeSynonymInstances + default-extensions: BangPatterns, + CPP, + DeriveDataTypeable, + EmptyDataDecls, + FlexibleInstances, + FunctionalDependencies, + GADTs, + GeneralizedNewtypeDeriving, + MagicHash, + MultiParamTypeClasses, + PatternGuards, + RankNTypes, + RecordWildCards + ScopedTypeVariables, + StandaloneDeriving, + TypeSynonymInstances