Hello community, here is the log from the commit of package ghc-store for openSUSE:Factory checked in at 2017-08-31 20:59:52 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-store (Old) and /work/SRC/openSUSE:Factory/.ghc-store.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-store" Thu Aug 31 20:59:52 2017 rev:2 rq:513501 version:0.4.3.1 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-store/ghc-store.changes 2017-05-10 20:51:04.318153140 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-store.new/ghc-store.changes 2017-08-31 20:59:53.438525082 +0200 @@ -1,0 +2,5 @@ +Wed Jul 26 16:56:09 UTC 2017 - psimons@suse.com + +- Update to version 0.4.3.1. + +------------------------------------------------------------------- Old: ---- store-0.3.1.tar.gz New: ---- store-0.4.3.1.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-store.spec ++++++ --- /var/tmp/diff_new_pack.AkTH4d/_old 2017-08-31 20:59:54.550368864 +0200 +++ /var/tmp/diff_new_pack.AkTH4d/_new 2017-08-31 20:59:54.558367740 +0200 @@ -19,7 +19,7 @@ %global pkg_name store %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.3.1 +Version: 0.4.3.1 Release: 0 Summary: Fast binary serialization License: MIT ++++++ store-0.3.1.tar.gz -> store-0.4.3.1.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/store-0.3.1/ChangeLog.md new/store-0.4.3.1/ChangeLog.md --- old/store-0.3.1/ChangeLog.md 2017-02-16 07:28:28.000000000 +0100 +++ new/store-0.4.3.1/ChangeLog.md 2017-05-09 02:43:17.000000000 +0200 @@ -1,5 +1,44 @@ # ChangeLog +## 0.4.3.1 + +* Fixed compilation on GHC 7.8 + +## 0.4.3 + +* Less aggressive inlining, resulting in faster compilation / simplifier + not running out of ticks + +## 0.4.2 + +* Fixed testsuite + +## 0.4.1 + +* Breaking change in the encoding of Map / Set / IntMap / IntSet, + to use ascending key order. Attempting to decode data written by + prior versions of store (and vice versa) will almost always fail + with a decent error message. If you're unlucky enough to have a + collision in the data with a random Word32 magic number, then the + error may not be so clear, or in extremely rare cases, + successfully decode, yielding incorrect results. See + [#97](https://github.com/fpco/store/issues/97) and + [#101](https://github.com/fpco/store/pull/101). + + +* Performance improvement of the 'Peek' monad, by introducing more + strictness. This required a change to the internal API. + +* API and behavior of 'Data.Store.Version' changed. Previously, it + would check the version tag after decoding the contents. It now + also stores a magic Word32 tag at the beginning, so that it fails + more gracefully when decoding input that lacks encoded version + info. + +## 0.4.0 + +Deprecated in favor of 0.4.1 + ## 0.3.1 * Fix to derivation of primitive vectors, only relevant when built with diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/store-0.3.1/bench/Bench.hs new/store-0.4.3.1/bench/Bench.hs --- old/store-0.3.1/bench/Bench.hs 2016-06-13 11:34:39.000000000 +0200 +++ new/store-0.4.3.1/bench/Bench.hs 2017-02-28 06:37:20.000000000 +0100 @@ -13,6 +13,10 @@ import Criterion.Main import qualified Data.ByteString as BS import Data.Int +import qualified Data.IntMap.Strict as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set import Data.Store import Data.Typeable import qualified Data.Vector as V @@ -71,6 +75,16 @@ _ -> error "This does not compute." ) <$> V.enumFromTo 1 (100 :: Int) nestedTuples = (\i -> ((i,i+1),(i+2,i+3))) <$> V.enumFromTo (1::Int) 100 + + ints = [1..100] :: [Int] + pairs = map (\x -> (x, x)) ints + strings = show <$> ints + intsSet = Set.fromDistinctAscList ints + intSet = IntSet.fromDistinctAscList ints + intsMap = Map.fromDistinctAscList pairs + intMap = IntMap.fromDistinctAscList pairs + stringsSet = Set.fromList strings + stringsMap = Map.fromList (zip strings ints) #endif defaultMain [ bgroup "encode" @@ -80,6 +94,12 @@ , benchEncode' "10kb storable" (SV.fromList ([1..(256 * 10)] :: [Int32])) , benchEncode' "1kb normal" (V.fromList ([1..256] :: [Int32])) , benchEncode' "10kb normal" (V.fromList ([1..(256 * 10)] :: [Int32])) + , benchEncode intsSet + , benchEncode intSet + , benchEncode intsMap + , benchEncode intMap + , benchEncode stringsSet + , benchEncode stringsMap #endif , benchEncode smallprods , benchEncode smallmanualprods @@ -95,6 +115,12 @@ , benchDecode' "10kb storable" (SV.fromList ([1..(256 * 10)] :: [Int32])) , benchDecode' "1kb normal" (V.fromList ([1..256] :: [Int32])) , benchDecode' "10kb normal" (V.fromList ([1..(256 * 10)] :: [Int32])) + , benchDecode intsSet + , benchDecode intSet + , benchDecode intsMap + , benchDecode intMap + , benchDecode stringsSet + , benchDecode stringsMap #endif , benchDecode smallprods , benchDecode smallmanualprods diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/store-0.3.1/src/Data/Store/Impl.hs new/store-0.4.3.1/src/Data/Store/Impl.hs --- old/store-0.3.1/src/Data/Store/Impl.hs 2017-02-14 20:28:40.000000000 +0100 +++ new/store-0.4.3.1/src/Data/Store/Impl.hs 2017-05-06 04:41:28.000000000 +0200 @@ -90,26 +90,22 @@ -- this package) combined with auomatic definition of instances. encode :: Store a => a -> BS.ByteString encode x = unsafeEncodeWith (poke x) (getSize x) -{-# INLINE encode #-} -- | Decodes a value from a 'BS.ByteString'. Returns an exception if -- there's an error while decoding, or if decoding undershoots / -- overshoots the end of the buffer. decode :: Store a => BS.ByteString -> Either PeekException a decode = unsafePerformIO . try . decodeIO -{-# INLINE decode #-} -- | Decodes a value from a 'BS.ByteString', potentially throwing -- exceptions. It is an exception to not consume all input. decodeEx :: Store a => BS.ByteString -> a decodeEx = unsafePerformIO . decodeIO -{-# INLINE decodeEx #-} -- | Decodes a value from a 'BS.ByteString', potentially throwing -- exceptions. It is an exception to not consume all input. decodeIO :: Store a => BS.ByteString -> IO a decodeIO = decodeIOWith peek -{-# INLINE decodeIO #-} ------------------------------------------------------------------------ -- Size diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/store-0.3.1/src/Data/Store/Internal.hs new/store-0.4.3.1/src/Data/Store/Internal.hs --- old/store-0.3.1/src/Data/Store/Internal.hs 2017-02-14 20:29:04.000000000 +0100 +++ new/store-0.4.3.1/src/Data/Store/Internal.hs 2017-05-06 04:50:14.000000000 +0200 @@ -46,6 +46,8 @@ , sizeSet, pokeSet, peekSet -- ** Store instances in terms of IsMap , sizeMap, pokeMap, peekMap + -- *** Utilities for ordered maps + , sizeOrdMap, pokeOrdMap, peekOrdMapWith -- ** Store instances in terms of IArray , sizeArray, pokeArray, peekArray -- ** Store instances in terms of Generic @@ -54,6 +56,7 @@ , GStorePeek, genericPeek -- ** Peek utilities , skip, isolate + , peekMagic -- ** Static Size type -- -- This portion of the library is still work-in-progress. @@ -81,9 +84,12 @@ import Data.HashSet (HashSet) import Data.Hashable (Hashable) import Data.IntMap (IntMap) +import qualified Data.IntMap.Strict as IntMap import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet import qualified Data.List.NonEmpty as NE import Data.Map (Map) +import qualified Data.Map.Strict as Map import Data.MonoTraversable import Data.Monoid import Data.Orphans () @@ -92,6 +98,7 @@ import Data.Sequence (Seq) import Data.Sequences (IsSequence, Index, replicateM) import Data.Set (Set) +import qualified Data.Set as Set import Data.Store.Impl import Data.Store.Core import Data.Store.TH.Internal @@ -216,11 +223,7 @@ :: (Store (ContainerKey t), Store (MapValue t), IsMap t) => t -> Poke () -pokeMap t = do - poke (olength t) - ofoldl' (\acc (k, x) -> poke k >> poke x >> acc) - (return ()) - (mapToList t) +pokeMap = pokeSequence . mapToList {-# INLINE pokeMap #-} -- | Implement 'peek' for an 'IsMap' of where both 'ContainerKey' and @@ -231,6 +234,61 @@ peekMap = mapFromList <$> peek {-# INLINE peekMap #-} +------------------------------------------------------------------------ +-- Utilities for defining 'Store' instances for ordered containers like +-- 'IntMap' and 'Map' + +-- | Marker for maps that are encoded in ascending order instead of the +-- descending order mistakenly implemented in 'peekMap' in store versions +-- < 0.4. +-- +-- See https://github.com/fpco/store/issues/97. +markMapPokedInAscendingOrder :: Word32 +markMapPokedInAscendingOrder = 1217678090 + +-- | Ensure the presence of a given magic value. +-- +-- Throws a 'PeekException' if the value isn't present. +peekMagic + :: (Eq a, Show a, Store a) + => String -> a -> Peek () +peekMagic markedThing x = do + x' <- peek + when (x' /= x) $ + fail ("Expected marker for " ++ markedThing ++ ": " ++ show x ++ " but got: " ++ show x') +{-# INLINE peekMagic #-} + +-- | Like 'sizeMap' but should only be used for ordered containers where +-- 'Data.Containers.mapToList' returns an ascending list. +sizeOrdMap + :: forall t. + (Store (ContainerKey t), Store (MapValue t), IsMap t) + => Size t +sizeOrdMap = + combineSizeWith (const markMapPokedInAscendingOrder) id size sizeMap +{-# INLINE sizeOrdMap #-} + +-- | Like 'pokeMap' but should only be used for ordered containers where +-- 'Data.Containers.mapToList' returns an ascending list. +pokeOrdMap + :: (Store (ContainerKey t), Store (MapValue t), IsMap t) + => t -> Poke () +pokeOrdMap x = poke markMapPokedInAscendingOrder >> pokeMap x +{-# INLINE pokeOrdMap #-} + +-- | Decode the results of 'pokeOrdMap' using a given function to construct +-- the map. +peekOrdMapWith + :: (Store (ContainerKey t), Store (MapValue t)) + => ([(ContainerKey t, MapValue t)] -> t) + -- ^ A function to construct the map from an ascending list such as + -- 'Map.fromDistinctAscList'. + -> Peek t +peekOrdMapWith f = do + peekMagic "ascending Map / IntMap" markMapPokedInAscendingOrder + f <$> peek +{-# INLINE peekOrdMapWith #-} + {- ------------------------------------------------------------------------ -- Utilities for defining list-like 'Store' instances in terms of Foldable @@ -279,7 +337,7 @@ remaining = peekStateEndPtr ps `minusPtr` ptr when (len > remaining) $ -- Do not perform the check on the new pointer, since it could have overflowed tooManyBytes len remaining "skip" - return (ptr2, ()) + return $ PeekResult ptr2 () -- | Isolate the input to n bytes, skipping n bytes forward. Fails if @m@ -- advances the offset beyond the isolated region. @@ -291,10 +349,10 @@ remaining = end `minusPtr` ptr when (len > remaining) $ -- Do not perform the check on the new pointer, since it could have overflowed tooManyBytes len remaining "isolate" - (ptr', x) <- runPeek m ps ptr + PeekResult ptr' x <- runPeek m ps ptr when (ptr' > end) $ throwIO $ PeekException (ptr' `minusPtr` end) "Overshot end of isolated bytes" - return (ptr2, x) + return $ PeekResult ptr2 x ------------------------------------------------------------------------ -- Instances for types based on flat representations @@ -303,9 +361,6 @@ size = sizeSequence poke = pokeSequence peek = V.unsafeFreeze =<< peekMutableSequence MV.new MV.write - {-# INLINE size #-} - {-# INLINE peek #-} - {-# INLINE poke #-} instance Storable a => Store (SV.Vector a) where size = VarSize $ \x -> @@ -319,9 +374,6 @@ len <- peek fp <- peekToPlainForeignPtr "Data.Storable.Vector.Vector" (sizeOf (undefined :: a) * len) liftIO $ SV.unsafeFreeze (MSV.MVector len fp) - {-# INLINE size #-} - {-# INLINE peek #-} - {-# INLINE poke #-} instance Store BS.ByteString where size = VarSize $ \x -> @@ -335,9 +387,6 @@ len <- peek fp <- peekToPlainForeignPtr "Data.ByteString.ByteString" len return (BS.PS fp 0 len) - {-# INLINE size #-} - {-# INLINE peek #-} - {-# INLINE poke #-} instance Store SBS.ShortByteString where size = VarSize $ \x -> @@ -351,9 +400,6 @@ len <- peek ByteArray array <- peekToByteArray "Data.ByteString.Short.ShortByteString" len return (SBS.SBS array) - {-# INLINE size #-} - {-# INLINE peek #-} - {-# INLINE poke #-} instance Store LBS.ByteString where -- FIXME: faster conversion? Is this ever going to be a problem? @@ -366,9 +412,6 @@ -- FIXME: more efficient implementation that avoids the double copy poke = poke . LBS.toStrict peek = fmap LBS.fromStrict peek - {-# INLINE size #-} - {-# INLINE peek #-} - {-# INLINE poke #-} instance Store T.Text where size = VarSize $ \x -> @@ -382,9 +425,6 @@ w16Len <- peek ByteArray array <- peekToByteArray "Data.Text.Text" (2 * w16Len) return (T.Text (TA.Array array) 0 w16Len) - {-# INLINE size #-} - {-# INLINE peek #-} - {-# INLINE poke #-} ------------------------------------------------------------------------ -- Known size instances @@ -421,9 +461,6 @@ let len = fromInteger (natVal (Proxy :: Proxy n)) fp <- peekToPlainForeignPtr ("StaticSize " ++ show len ++ " Data.ByteString.ByteString") len return (StaticSize (BS.PS fp 0 len)) - {-# INLINE size #-} - {-# INLINE peek #-} - {-# INLINE poke #-} -- NOTE: this could be a 'Lift' instance, but we can't use type holes in -- TH. Alternatively we'd need a (TypeRep -> Type) function and Typeable @@ -446,9 +483,6 @@ size = sizeSequence poke = pokeSequence peek = peekSequence - {-# INLINE size #-} - {-# INLINE peek #-} - {-# INLINE poke #-} instance Store a => Store (NE.NonEmpty a) @@ -456,75 +490,62 @@ size = sizeSequence poke = pokeSequence peek = peekSequence - {-# INLINE size #-} - {-# INLINE peek #-} - {-# INLINE poke #-} instance (Store a, Ord a) => Store (Set a) where - size = sizeSet + size = + VarSize $ \t -> + sizeOf (undefined :: Int) + + case size of + ConstSize n -> n * Set.size t + VarSize f -> Set.foldl' (\acc a -> acc + f a) 0 t poke = pokeSet - peek = peekSet - {-# INLINE size #-} - {-# INLINE peek #-} - {-# INLINE poke #-} + peek = Set.fromDistinctAscList <$> peek instance Store IntSet where size = sizeSet poke = pokeSet - peek = peekSet - {-# INLINE size #-} - {-# INLINE peek #-} - {-# INLINE poke #-} + peek = IntSet.fromDistinctAscList <$> peek instance Store a => Store (IntMap a) where - size = sizeMap - poke = pokeMap - peek = peekMap - {-# INLINE size #-} - {-# INLINE peek #-} - {-# INLINE poke #-} + size = sizeOrdMap + poke = pokeOrdMap + peek = peekOrdMapWith IntMap.fromDistinctAscList instance (Ord k, Store k, Store a) => Store (Map k a) where - size = sizeMap - poke = pokeMap - peek = peekMap - {-# INLINE size #-} - {-# INLINE peek #-} - {-# INLINE poke #-} + size = + VarSize $ \t -> + sizeOf markMapPokedInAscendingOrder + sizeOf (undefined :: Int) + + case (size, size) of + (ConstSize nk, ConstSize na) -> (nk + na) * Map.size t + (szk, sza) -> + Map.foldlWithKey' + (\acc k a -> acc + getSizeWith szk k + getSizeWith sza a) + 0 + t + poke = pokeOrdMap + peek = peekOrdMapWith Map.fromDistinctAscList instance (Eq k, Hashable k, Store k, Store a) => Store (HashMap k a) where size = sizeMap poke = pokeMap peek = peekMap - {-# INLINE size #-} - {-# INLINE peek #-} - {-# INLINE poke #-} instance (Eq a, Hashable a, Store a) => Store (HashSet a) where size = sizeSet poke = pokeSet peek = peekSet - {-# INLINE size #-} - {-# INLINE peek #-} - {-# INLINE poke #-} instance (A.Ix i, Store i, Store e) => Store (A.Array i e) where -- TODO: Speed up poke and peek size = sizeArray poke = pokeArray peek = peekArray - {-# INLINE size #-} - {-# INLINE peek #-} - {-# INLINE poke #-} instance (A.Ix i, A.IArray A.UArray e, Store i, Store e) => Store (A.UArray i e) where -- TODO: Speed up poke and peek size = sizeArray poke = pokeArray peek = peekArray - {-# INLINE size #-} - {-# INLINE peek #-} - {-# INLINE poke #-} sizeArray :: (A.Ix i, A.IArray a e, Store i, Store e) => Size (a i e) sizeArray = VarSize $ \arr -> @@ -624,9 +645,6 @@ size = contramap (\(MkFixed x) -> x) (size :: Size Integer) poke (MkFixed x) = poke x peek = MkFixed <$> peek - {-# INLINE size #-} - {-# INLINE peek #-} - {-# INLINE poke #-} -- instance Store a => Store (Tree a) where @@ -645,33 +663,21 @@ size = combineSize (\(x :% _) -> x) (\(_ :% y) -> y) poke (x :% y) = poke (x, y) peek = uncurry (:%) <$> peek - {-# INLINE size #-} - {-# INLINE peek #-} - {-# INLINE poke #-} instance Store Time.Day where size = contramap Time.toModifiedJulianDay (size :: Size Integer) poke = poke . Time.toModifiedJulianDay peek = Time.ModifiedJulianDay <$> peek - {-# INLINE size #-} - {-# INLINE peek #-} - {-# INLINE poke #-} instance Store Time.DiffTime where size = contramap (realToFrac :: Time.DiffTime -> Pico) (size :: Size Pico) poke = (poke :: Pico -> Poke ()) . realToFrac peek = Time.picosecondsToDiffTime <$> peek - {-# INLINE size #-} - {-# INLINE peek #-} - {-# INLINE poke #-} instance Store Time.UTCTime where size = combineSize Time.utctDay Time.utctDayTime poke (Time.UTCTime day time) = poke (day, time) peek = uncurry Time.UTCTime <$> peek - {-# INLINE size #-} - {-# INLINE peek #-} - {-# INLINE poke #-} instance Store () instance Store a => Store (Dual a) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/store-0.3.1/src/Data/Store/Streaming.hs new/store-0.4.3.1/src/Data/Store/Streaming.hs --- old/store-0.3.1/src/Data/Store/Streaming.hs 2017-01-06 04:12:07.000000000 +0100 +++ new/store-0.4.3.1/src/Data/Store/Streaming.hs 2017-05-06 04:41:19.000000000 +0200 @@ -80,15 +80,13 @@ poke messageMagic poke bodyLength poke x -{-# INLINE encodeMessage #-} -- | The result of peeking at the next message can either be a -- successfully deserialised object, or a request for more input. type PeekMessage i m a = FT ((->) i) m a -needMoreInput :: Monad m => PeekMessage i m i +needMoreInput :: PeekMessage i m i needMoreInput = wrap return -{-# INLINE needMoreInput #-} -- | Given some sort of input, fills the 'ByteBuffer' with it. -- @@ -100,7 +98,6 @@ -- up the encoded message. decodeFromPtr :: (MonadIO m, Store a) => Ptr Word8 -> Int -> m a decodeFromPtr ptr n = liftIO $ decodeIOWithFromPtr peek ptr n -{-# INLINE decodeFromPtr #-} peekSized :: (MonadIO m, Store a) => FillByteBuffer i m -> ByteBuffer -> Int -> PeekMessage i m a peekSized fill bb n = go @@ -113,7 +110,6 @@ lift (fill bb needed inp) go Right ptr -> decodeFromPtr ptr n -{-# INLINE peekSized #-} -- | Read and check the magic number from a 'ByteBuffer' peekMessageMagic :: MonadIO m => FillByteBuffer i m -> ByteBuffer -> PeekMessage i m () @@ -122,12 +118,10 @@ mm | mm == messageMagic -> return () mm -> liftIO . throwIO $ PeekException 0 . T.pack $ "Wrong message magic, " ++ show mm -{-# INLINE peekMessageMagic #-} -- | Decode a 'SizeTag' from a 'ByteBuffer'. peekMessageSizeTag :: MonadIO m => FillByteBuffer i m -> ByteBuffer -> PeekMessage i m SizeTag peekMessageSizeTag fill bb = peekSized fill bb sizeTagLength -{-# INLINE peekMessageSizeTag #-} -- | Decode some object from a 'ByteBuffer', by first reading its -- header, and then the actual data. @@ -136,7 +130,6 @@ fmap Message $ do peekMessageMagic fill bb peekMessageSizeTag fill bb >>= peekSized fill bb -{-# INLINE peekMessage #-} -- | Decode a 'Message' from a 'ByteBuffer' and an action that can get -- additional inputs to refill the buffer when necessary. @@ -165,18 +158,15 @@ return Nothing where maybeDecode m = runMaybeT (iterTM (\consumeInp -> consumeInp =<< MaybeT getInp) m) -{-# INLINE decodeMessage #-} -- | Decode some 'Message' from a 'ByteBuffer', by first reading its -- header, and then the actual 'Message'. peekMessageBS :: (MonadIO m, Store a) => ByteBuffer -> PeekMessage ByteString m (Message a) peekMessageBS = peekMessage (\bb _ bs -> BB.copyByteString bb bs) -{-# INLINE peekMessageBS #-} decodeMessageBS :: (MonadIO m, Store a) => ByteBuffer -> m (Maybe ByteString) -> m (Maybe (Message a)) decodeMessageBS = decodeMessage (\bb _ bs -> BB.copyByteString bb bs) -{-# INLINE decodeMessageBS #-} #ifndef mingw32_HOST_OS @@ -193,7 +183,6 @@ peekMessageFd :: (MonadIO m, Store a) => ByteBuffer -> Fd -> PeekMessage ReadMoreData m (Message a) peekMessageFd bb fd = peekMessage (\bb_ needed ReadMoreData -> do _ <- BB.fillFromFd bb_ fd needed; return ()) bb -{-# INLINE peekMessageFd #-} -- | Decodes all the message using 'registerFd' to find out when a 'Socket' is -- ready for reading. @@ -207,17 +196,15 @@ case mbMsg of Just msg -> return msg Nothing -> liftIO (fail "decodeMessageFd: impossible: got Nothing") -{-# INLINE decodeMessageFd #-} #endif -- | Conduit for encoding 'Message's to 'ByteString's. conduitEncode :: (Monad m, Store a) => C.Conduit (Message a) m ByteString conduitEncode = C.map encodeMessage -{-# INLINE conduitEncode #-} -- | Conduit for decoding 'Message's from 'ByteString's. -conduitDecode :: (MonadIO m, MonadResource m, Store a) +conduitDecode :: (MonadResource m, Store a) => Maybe Int -- ^ Initial length of the 'ByteBuffer' used for -- buffering the incoming 'ByteString's. If 'Nothing', @@ -234,4 +221,3 @@ case mmessage of Nothing -> return () Just message -> C.yield message >> go buffer -{-# INLINE conduitDecode #-} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/store-0.3.1/src/Data/Store/TH/Internal.hs new/store-0.4.3.1/src/Data/Store/TH/Internal.hs --- old/store-0.3.1/src/Data/Store/TH/Internal.hs 2017-01-31 03:07:00.000000000 +0100 +++ new/store-0.4.3.1/src/Data/Store/TH/Internal.hs 2017-05-09 02:42:26.000000000 +0200 @@ -16,6 +16,7 @@ , deriveManyStorePrimVector , deriveManyStoreUnboxVector , deriveStore + , makeStore -- * Misc utilties used in Store test , getAllInstanceTypes1 , isMonoType @@ -46,7 +47,7 @@ import Safe (headMay) import TH.Derive (Deriver(..)) import TH.ReifySimple -import TH.Utilities (expectTyCon1, dequalify, plainInstanceD) +import TH.Utilities (expectTyCon1, dequalify, plainInstanceD, appsT) instance Deriver (Store a) where runDeriver _ preds ty = do @@ -54,6 +55,18 @@ dt <- reifyDataTypeSubstituted argTy (:[]) <$> deriveStore preds argTy (dtCons dt) +-- | Given the name of a type, generate a Store instance for it, +-- assuming that all type variables also need to be Store instances. +-- +-- Note that when used with datatypes that require type variables, the +-- ScopedTypeVariables extension is required. +makeStore :: Name -> Q [Dec] +makeStore name = do + dt <- reifyDataType name + let preds = map (storePred . VarT) (dtTvs dt) + argTy = appsT (ConT name) (map VarT (dtTvs dt)) + (:[]) <$> deriveStore preds argTy (dtCons dt) + deriveStore :: Cxt -> Type -> [DataCon] -> Q Dec deriveStore preds headTy cons0 = makeStoreInstance preds headTy @@ -244,16 +257,10 @@ deriveTupleStoreInstance :: Int -> Dec deriveTupleStoreInstance n = - deriveGenericInstance (map storeCxt tvs) + deriveGenericInstance (map storePred tvs) (foldl1 AppT (TupleT n : tvs)) where tvs = take n (map (VarT . mkName . (:[])) ['a'..'z']) - storeCxt ty = -#if MIN_VERSION_template_haskell(2,10,0) - AppT (ConT ''Store) ty -#else - ClassP ''Store [ty] -#endif deriveGenericInstance :: Cxt -> Type -> Dec deriveGenericInstance cs ty = plainInstanceD cs (AppT (ConT ''Store) ty) [] @@ -337,12 +344,6 @@ concatMap (map snd . dcFields) cons -} let extraPreds = map (storePred . AppT (ConT ''UV.Vector)) $ listify isVarT ty - storePred = -#if MIN_VERSION_template_haskell(2,10,0) - AppT (ConT ''Store) -#else - ClassP ''Store . (:[]) -#endif deriveStore (nub (preds ++ extraPreds)) ty cons _ -> fail "impossible case in deriveManyStoreUnboxVector" @@ -382,11 +383,8 @@ cs (AppT (ConT ''Store) ty) [ ValD (VarP 'size) (NormalB sizeExpr) [] - , PragmaD (InlineP 'size Inline FunLike AllPhases) , ValD (VarP 'peek) (NormalB peekExpr) [] - , PragmaD (InlineP 'peek Inline FunLike AllPhases) , ValD (VarP 'poke) (NormalB pokeExpr) [] - , PragmaD (InlineP 'poke Inline FunLike AllPhases) ] -- TODO: either generate random types that satisfy instances with @@ -427,3 +425,11 @@ getTyHead (ForallT _ _ x) = getTyHead x getTyHead (AppT l _) = getTyHead l getTyHead x = x + +storePred :: Type -> Pred +storePred ty = +#if MIN_VERSION_template_haskell(2,10,0) + AppT (ConT ''Store) ty +#else + ClassP ''Store [ty] +#endif diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/store-0.3.1/src/Data/Store/TH.hs new/store-0.4.3.1/src/Data/Store/TH.hs --- old/store-0.3.1/src/Data/Store/TH.hs 2016-10-07 01:21:44.000000000 +0200 +++ new/store-0.4.3.1/src/Data/Store/TH.hs 2017-05-09 01:45:00.000000000 +0200 @@ -2,18 +2,27 @@ -- | This module exports TH utilities intended to be useful to users. -- --- However, the visible exports do not show the main things that will be --- useful, which is using TH to generate 'Store' instances, via --- "TH.Derive". It's used like this: +-- 'makeStore' can be used to generate a 'Store' instance for types, +-- when all the type variables also require 'Store' instances. If some +-- do not, then instead use "TH.Derive" like this: -- -- @ --- data Foo = Foo Int | Bar Int +-- {-# LANGUAGE TemplateHaskell #-} +-- {-# LANGUAGE ScopedTypeVariables #-} +-- +-- import TH.Derive +-- import Data.Store +-- +-- data Foo a = Foo a | Bar Int -- -- $($(derive [d| --- instance Deriving (Store Foo) +-- instance Store a => Deriving (Store (Foo a)) -- |])) -- @ -- +-- Note that when used with datatypes that require type variables, the +-- ScopedTypeVariables extension is required. +-- -- One advantage of using this Template Haskell definition of Store -- instances is that in some cases they can be faster than the instances -- defined via Generics. Specifically, sum types which can yield @@ -21,9 +30,9 @@ -- The instances generated via generics always use 'VarSize' for sum -- types. module Data.Store.TH - ( + ( makeStore -- * Testing Store instances - smallcheckManyStore + , smallcheckManyStore , checkRoundtrip , assertRoundtrip ) where @@ -37,6 +46,7 @@ import Test.Hspec import Test.Hspec.SmallCheck (property) import Test.SmallCheck +import Data.Store.TH.Internal (makeStore) ------------------------------------------------------------------------ -- Testing diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/store-0.3.1/src/Data/Store/Version.hs new/store-0.4.3.1/src/Data/Store/Version.hs --- old/store-0.3.1/src/Data/Store/Version.hs 2016-08-05 03:21:03.000000000 +0200 +++ new/store-0.4.3.1/src/Data/Store/Version.hs 2017-03-04 07:37:56.000000000 +0100 @@ -23,16 +23,13 @@ -- will be minimized when directly feasible. module Data.Store.Version ( StoreVersion(..) - , WithVersion(..) , VersionConfig(..) , hashedVersionConfig , namedVersionConfig - , wrapVersion - , checkVersion - , VersionCheckException(..) + , encodeWithVersionQ + , decodeWithVersionQ ) where -import Control.Exception import Control.Monad import Control.Monad.Trans.State import qualified Crypto.Hash.SHA1 as SHA1 @@ -48,6 +45,7 @@ import Data.Text.Encoding.Error (lenientDecode) import qualified Data.Text.IO as T import Data.Typeable.Internal (TypeRep(..)) +import Data.Word (Word32) import GHC.Generics (Generic) import Language.Haskell.TH import System.Directory @@ -59,11 +57,6 @@ newtype StoreVersion = StoreVersion { unStoreVersion :: BS.ByteString } deriving (Eq, Show, Ord, Data, Typeable, Generic, Store) -data WithVersion a = WithVersion a StoreVersion - deriving (Eq, Show, Ord, Data, Typeable, Generic) - -instance Store a => Store (WithVersion a) - -- | Configuration for the version checking of a particular type. data VersionConfig a = VersionConfig { vcExpectedHash :: Maybe String @@ -92,13 +85,13 @@ , vcRenames = M.empty } -wrapVersion :: Data a => VersionConfig a -> Q Exp -wrapVersion = impl Wrap +encodeWithVersionQ :: Data a => VersionConfig a -> Q Exp +encodeWithVersionQ = impl Encode -checkVersion :: Data a => VersionConfig a -> Q Exp -checkVersion = impl Check +decodeWithVersionQ :: Data a => VersionConfig a -> Q Exp +decodeWithVersionQ = impl Decode -data WhichFunc = Wrap | Check +data WhichFunc = Encode | Decode impl :: forall a. Data a => WhichFunc -> VersionConfig a -> Q Exp impl wf vc = do @@ -131,15 +124,16 @@ ", but " ++ show expectedHash ++ " is specified.\n" ++ "The data used to construct the hash has been written to " ++ show newPath ++ extraMsg ++ "\n" + let atype = typeRepToType (typeRep proxy) case wf of - Wrap -> [e| (\x -> (x :: $(typeRepToType (typeRep proxy))) `WithVersion` $(version)) |] - Check -> [e| (\(WithVersion x gotVersion) -> - if gotVersion /= $(version) - then Left (VersionCheckException - { expectedVersion = $(version) - , receivedVersion = gotVersion - }) - else Right x) |] + Encode -> [e| \x -> ( getSize markEncodedVersion + getSize $(version) + getSize x + , poke markEncodedVersion >> poke $(version) >> poke (x :: $(atype))) |] + Decode -> [e| do + peekMagic "version tag" markEncodedVersion + gotVersion <- peek + if gotVersion /= $(version) + then fail (displayVersionError $(version) gotVersion) + else peek :: Peek $(atype) |] {- txtWithComments <- runIO $ T.readFile path @@ -286,26 +280,11 @@ tyConOf :: Typeable a => Proxy a -> TyCon tyConOf = typeRepTyCon . typeRep -data VersionCheckException = VersionCheckException - { expectedVersion :: StoreVersion - , receivedVersion :: StoreVersion - } deriving -#if MIN_VERSION_base(4,8,0) - (Typeable, Show) - -instance Exception VersionCheckException where - displayException = displayVCE -#else - (Typeable) - -instance Show VersionCheckException where - show = displayVCE - -instance Exception VersionCheckException -#endif - -displayVCE :: VersionCheckException -> String -displayVCE VersionCheckException{..} = +displayVersionError :: StoreVersion -> StoreVersion -> String +displayVersionError expectedVersion receivedVersion = "Mismatch detected by Data.Store.Version - expected " ++ T.unpack (decodeUtf8With lenientDecode (unStoreVersion expectedVersion)) ++ " but got " ++ T.unpack (decodeUtf8With lenientDecode (unStoreVersion receivedVersion)) + +markEncodedVersion :: Word32 +markEncodedVersion = 3908297288 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/store-0.3.1/src/System/IO/ByteBuffer.hs new/store-0.4.3.1/src/System/IO/ByteBuffer.hs --- old/store-0.3.1/src/System/IO/ByteBuffer.hs 2016-11-16 22:01:15.000000000 +0100 +++ new/store-0.4.3.1/src/System/IO/ByteBuffer.hs 2017-05-06 04:42:18.000000000 +0200 @@ -142,7 +142,6 @@ writeIORef bb (Left $ ByteBufferException loc (show e)) Left _ -> return () throwIO e -{-# INLINE bbHandler #-} -- | Try to use the 'BBRef' of a 'ByteBuffer', or throw a 'ByteBufferException' if it's invalid. useBBRef :: (BBRef -> IO a) -> ByteBuffer -> IO a @@ -185,7 +184,6 @@ , contained = 0 , consumed = 0 } -{-# INLINE new #-} -- | Free a byte buffer. free :: MonadIO m => ByteBuffer -> m () @@ -195,7 +193,6 @@ writeIORef bb $ Left (ByteBufferException "free" "ByteBuffer has explicitly been freed and is no longer valid.") Left _ -> return () -- the ByteBuffer is either invalid or has already been freed. -{-# INLINE free #-} -- | Perform some action with a bytebuffer, with automatic allocation -- and deallocation. @@ -224,7 +221,6 @@ , consumed = 0 , ptr = ptr bbref } -{-# INLINE resetBBRef #-} -- | Make sure the buffer is at least @minSize@ bytes long. -- @@ -246,7 +242,6 @@ , consumed = consumed bbref , ptr = ptr' } -{-# INLINE enlargeBBRef #-} -- | Copy the contents of a 'ByteString' to a 'ByteBuffer'. -- @@ -277,7 +272,6 @@ , contained = contained bbref'' + bsSize , consumed = consumed bbref'' , ptr = ptr bbref''} -{-# INLINE copyByteString #-} #ifndef mingw32_HOST_OS @@ -295,7 +289,6 @@ (bbref', readBytes) <- fillBBRefFromFd sock bbref maxBytes writeIORef bb $ Right bbref' return readBytes -{-# INLINE fillFromFd #-} {- Note: I'd like to use these two definitions: @@ -352,7 +345,6 @@ else do let bbref' = bbref{ contained = contained + bytes } go (readBytes + bytes) bbref' -{-# INLINE fillBBRefFromFd #-} foreign import ccall unsafe "recv" -- c_recv returns -1 in the case of errors. @@ -386,7 +378,6 @@ else do writeIORef bb $ Right bbref { consumed = consumed bbref + n } return $ Right (ptr bbref `plusPtr` consumed bbref) -{-# INLINE unsafeConsume #-} -- | As `unsafeConsume`, but instead of returning a `Ptr` into the -- contents of the `ByteBuffer`, it returns a `ByteString` containing @@ -404,7 +395,6 @@ bs <- liftIO $ createBS ptr n return (Right bs) Left missing -> return (Left missing) -{-# INLINE consume #-} {-@ createBS :: p:(Ptr Word8) -> {v:Nat | v <= plen p} -> IO ByteString @-} createBS :: Ptr Word8 -> Int -> IO ByteString @@ -412,7 +402,6 @@ fp <- mallocForeignPtrBytes n withForeignPtr fp (\p -> copyBytes p ptr n) return (BS.PS fp 0 n) -{-# INLINE createBS #-} -- below are liquid haskell qualifiers, and specifications for external functions. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/store-0.3.1/store.cabal new/store-0.4.3.1/store.cabal --- old/store-0.3.1/store.cabal 2017-02-16 07:29:02.000000000 +0100 +++ new/store-0.4.3.1/store.cabal 2017-05-09 02:44:12.000000000 +0200 @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: store -version: 0.3.1 +version: 0.4.3.1 synopsis: Fast binary serialization category: Serialization, Data homepage: https://github.com/fpco/store#readme @@ -37,7 +37,7 @@ ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 build-depends: base >=4.7 && <5 - , store-core >=0.3 && <0.4 + , store-core >=0.4 && <0.5 , th-utilities >=0.2 , primitive >=0.6 , th-reify-many >=0.1.6 @@ -102,7 +102,7 @@ ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 - , store-core >=0.3 && <0.4 + , store-core >=0.4 && <0.5 , th-utilities >=0.2 , primitive >=0.6 , th-reify-many >=0.1.6 @@ -160,7 +160,7 @@ ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 -threaded -rtsopts -with-rtsopts=-N -with-rtsopts=-T -O2 build-depends: base >=4.7 && <5 - , store-core >=0.3 && <0.4 + , store-core >=0.4 && <0.5 , th-utilities >=0.2 , primitive >=0.6 , th-reify-many >=0.1.6 @@ -218,7 +218,7 @@ ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 -threaded -rtsopts -with-rtsopts=-N1 -with-rtsopts=-s -with-rtsopts=-qg build-depends: base >=4.7 && <5 - , store-core >=0.3 && <0.4 + , store-core >=0.4 && <0.5 , th-utilities >=0.2 , primitive >=0.6 , th-reify-many >=0.1.6 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/store-0.3.1/test/Allocations.hs new/store-0.4.3.1/test/Allocations.hs --- old/store-0.3.1/test/Allocations.hs 2016-10-27 00:36:13.000000000 +0200 +++ new/store-0.4.3.1/test/Allocations.hs 2017-02-28 06:37:20.000000000 +0100 @@ -7,8 +7,11 @@ module Main where import Control.DeepSeq -import Data.List +import qualified Data.IntMap.Strict as IntMap +import qualified Data.IntSet as IntSet import qualified Data.Serialize as Cereal +import qualified Data.Set as Set +import qualified Data.Map.Strict as Map import qualified Data.Store as Store import qualified Data.Vector as Boxed import qualified Data.Vector.Serialize () @@ -19,26 +22,39 @@ -- | Main entry point. main :: IO () main = - mainWith encoding + mainWith weighing --- | Weigh encoding with Store vs Cereal. -encoding :: Weigh () -encoding = +-- | Weigh weighing with Store vs Cereal. +weighing :: Weigh () +weighing = do fortype "[Int]" (\n -> replicate n 0 :: [Int]) fortype "Boxed Vector Int" (\n -> Boxed.replicate n 0 :: Boxed.Vector Int) fortype "Storable Vector Int" (\n -> Storable.replicate n 0 :: Storable.Vector Int) + fortype "Set Int" (Set.fromDistinctAscList . ints) + fortype "IntSet" (IntSet.fromDistinctAscList . ints) + fortype "Map Int Int" (Map.fromDistinctAscList . intpairs) + fortype "IntMap Int" (IntMap.fromDistinctAscList . intpairs) where fortype label make = scale (\(n,nstr) -> do let title :: String -> String title for = printf "%12s %-20s %s" nstr (label :: String) for + encodeDecode en de = + (return . (`asTypeOf` make n) . de . force . en . make) n action (title "Allocate") (return (make n)) action (title "Encode: Store") (return (Store.encode (force (make n)))) action (title "Encode: Cereal") - (return (Cereal.encode (force (make n))))) - scale func = - mapM_ func + (return (Cereal.encode (force (make n)))) + action (title "Encode/Decode: Store") + (encodeDecode Store.encode Store.decodeEx) + action (title "Encode/Decode: Cereal") + (encodeDecode Cereal.encode (fromRight . Cereal.decode))) + scale f = + mapM_ f (map (\x -> (x,commas x)) [1000000,2000000,10000000]) + ints n = [1..n] :: [Int] + intpairs = map (\x -> (x, x)) . ints + fromRight = either (error "Left") id diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/store-0.3.1/test/Data/StoreSpec.hs new/store-0.4.3.1/test/Data/StoreSpec.hs --- old/store-0.3.1/test/Data/StoreSpec.hs 2016-11-16 22:52:41.000000000 +0100 +++ new/store-0.4.3.1/test/Data/StoreSpec.hs 2017-03-04 08:07:44.000000000 +0100 @@ -307,7 +307,7 @@ , [t| X |] ]) describe "Manually listed polymorphic store instances" - $(smallcheckManyStore verbose 2 + $(smallcheckManyStore verbose 4 [ [t| SV.Vector Int8 |] , [t| V.Vector Int8 |] , [t| SerialRatio Int8 |] @@ -396,6 +396,12 @@ assertRoundtrip verbose (250 :: Word8, 40918 :: Word16, 120471416 :: Word32) assertRoundtrip verbose (250 :: Word8, 10.1 :: Float, 8697.65 :: Double) (return () :: IO ()) + it "Expects the right marker when deserializing ordered maps (#97)" $ do + let m = mapFromList [(1, ()), (2, ()), (3, ())] :: HashMap Int () + bs = encode m + (decodeEx bs :: HashMap Int ()) `shouldBe` m + evaluate (decodeEx bs :: Map Int ()) `shouldThrow` isUnexpectedMarkerException + evaluate (decodeEx bs :: IntMap ()) `shouldThrow` isUnexpectedMarkerException isPokeException :: Test.Hspec.Selector PokeException isPokeException = const True @@ -405,3 +411,7 @@ isTooManyBytesException :: Test.Hspec.Selector PeekException isTooManyBytesException (PeekException _ t) = "Attempted to read too many bytes" `T.isPrefixOf` t + +isUnexpectedMarkerException :: Test.Hspec.Selector PeekException +isUnexpectedMarkerException (PeekException _ t) = + "Expected marker for ascending Map / IntMap: " `T.isPrefixOf` t