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 - psim...@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
