store 0.3 → 0.3.1

raw patch · 9 files changed

+80/−62 lines, 9 filesdep +contravariantdep ~arraydep ~asyncdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: contravariant

Dependency ranges changed: array, async, base, base-orphans, base64-bytestring, bytestring, conduit, containers, cryptohash, deepseq, directory, filepath, free, ghc-prim, hashable, hspec, hspec-smallcheck, integer-gmp, lifted-base, monad-control, mono-traversable, network, primitive, resourcet, safe, semigroups, smallcheck, streaming-commons, syb, template-haskell, text, th-lift, th-lift-instances, th-orphans, th-reify-many, th-utilities, time, transformers, unordered-containers, vector, void

API changes (from Hackage documentation)

Files

• ChangeLog.md +11/−0
• src/Data/Store/Impl.hs +14/−13
• src/Data/Store/Internal.hs +5/−4
• src/Data/Store/Streaming.hs +31/−16
• src/Data/Store/TH/Internal.hs +2/−2
• src/Data/Store/TypeHash/Internal.hs +2/−1
• store.cabal +6/−8
• test/Data/Store/StreamingSpec.hs +5/−18
• test/Data/StoreSpec.hs +4/−0

@@ -1,5 +1,16 @@ # ChangeLog +## 0.3.1++* Fix to derivation of primitive vectors, only relevant when built with+  primitive-0.6.2.0 or later++* Removes INLINE pragmas on the generic default methods.  This+  dramatically improves compilation time on recent GHC versions.+  See [#91](https://github.com/fpco/store/issues/91).++* Adds `instance Contravariant Size`+ ## 0.3  * Uses store-core-0.3.*, which has support for alignment sensitive

@@ -22,6 +22,7 @@ import           Control.Exception (try) import           Control.Monad import qualified Data.ByteString as BS+import           Data.Functor.Contravariant (Contravariant(..)) import           Data.Proxy import           Data.Store.Core import           Data.Typeable (Typeable, typeRep)@@ -64,16 +65,18 @@      default size :: (Generic a, GStoreSize (Rep a)) => Size a     size = genericSize-    {-# INLINE size #-}      default poke :: (Generic a, GStorePoke (Rep a)) => a -> Poke ()     poke = genericPoke-    {-# INLINE poke #-}      default peek :: (Generic a , GStorePeek (Rep a)) => Peek a     peek = genericPeek-    {-# INLINE peek #-} +    -- NB: Do not INLINE the default implementations of size, poke, or peek!+    -- Doing so can lead to enormous memory blowup (a maximum residency of+    -- 5.17 GB with GHC 8.0.2 has been observed). For more information, please+    -- read issue #91.+ ------------------------------------------------------------------------ -- Utilities for encoding / decoding strict ByteStrings @@ -118,6 +121,11 @@     | ConstSize !Int     deriving Typeable +instance Contravariant Size where+  contramap f sz = case sz of+    ConstSize n -> ConstSize n+    VarSize g -> VarSize (\x -> g (f x))+ -- | Get the number of bytes needed to store the given value. See -- 'size'. getSize :: Store a => a -> Int@@ -131,13 +139,6 @@ getSizeWith (ConstSize n) _ = n {-# INLINE getSizeWith #-} --- | This allows for changing the type used as an input when the 'Size'--- is 'VarSize'.-contramapSize :: (a -> b) -> Size b -> Size a-contramapSize f (VarSize g) = VarSize (g . f)-contramapSize _ (ConstSize n) = ConstSize n-{-# INLINE contramapSize #-}- -- | Create an aggregate 'Size' by providing functions to split the -- input into two pieces. --@@ -186,7 +187,7 @@ -- Generics  genericSize :: (Generic a, GStoreSize (Rep a)) => Size a-genericSize = contramapSize from gsize+genericSize = contramap from gsize {-# INLINE genericSize #-}  genericPoke :: (Generic a, GStorePoke (Rep a)) => a -> Poke ()@@ -211,7 +212,7 @@ class GStorePeek f where gpeek :: Peek (f a)  instance GStoreSize f => GStoreSize (M1 i c f) where-    gsize = contramapSize unM1 gsize+    gsize = contramap unM1 gsize     {-# INLINE gsize #-} instance GStorePoke f => GStorePoke (M1 i c f) where     gpoke = gpoke . unM1@@ -221,7 +222,7 @@     {-# INLINE gpeek #-}  instance Store a => GStoreSize (K1 i a) where-    gsize = contramapSize unK1 size+    gsize = contramap unK1 size     {-# INLINE gsize #-} instance Store a => GStorePoke (K1 i a) where     gpoke = poke . unK1

@@ -39,7 +39,7 @@     -- ** Size type     , Size(..)     , getSize, getSizeWith-    , contramapSize, combineSize, combineSizeWith, addSize+    , combineSize, combineSizeWith, addSize     -- ** Store instances in terms of IsSequence     , sizeSequence, pokeSequence, peekSequence     -- ** Store instances in terms of IsSet@@ -76,6 +76,7 @@ import           Data.Data (Data) import           Data.Fixed (Fixed (..), Pico) import           Data.Foldable (forM_, foldl')+import           Data.Functor.Contravariant import           Data.HashMap.Strict (HashMap) import           Data.HashSet (HashSet) import           Data.Hashable (Hashable)@@ -620,7 +621,7 @@ -- instance Store GHC.Fingerprint.Types.Fingerprint where  instance Store (Fixed a) where-    size = contramapSize (\(MkFixed x) -> x) (size :: Size Integer)+    size = contramap (\(MkFixed x) -> x) (size :: Size Integer)     poke (MkFixed x) = poke x     peek = MkFixed <$> peek     {-# INLINE size #-}@@ -649,7 +650,7 @@     {-# INLINE poke #-}  instance Store Time.Day where-    size = contramapSize Time.toModifiedJulianDay (size :: Size Integer)+    size = contramap Time.toModifiedJulianDay (size :: Size Integer)     poke = poke . Time.toModifiedJulianDay     peek = Time.ModifiedJulianDay <$> peek     {-# INLINE size #-}@@ -657,7 +658,7 @@     {-# INLINE poke #-}  instance Store Time.DiffTime where-    size = contramapSize (realToFrac :: Time.DiffTime -> Pico) (size :: Size Pico)+    size = contramap (realToFrac :: Time.DiffTime -> Pico) (size :: Size Pico)     poke = (poke :: Pico -> Poke ()) . realToFrac     peek = Time.picosecondsToDiffTime <$> peek     {-# INLINE size #-}

@@ -115,22 +115,27 @@         Right ptr -> decodeFromPtr ptr n {-# INLINE peekSized #-} --- | Decode a header (magic number and 'SizeTag') from a 'ByteBuffer'.-peekMessageHeader :: MonadIO m => FillByteBuffer i m -> ByteBuffer -> PeekMessage i m SizeTag-peekMessageHeader fill bb = go-  where-    go = do-      messageMagic' <- peekSized fill bb magicLength-      unless (messageMagic == messageMagic') $-        liftIO . throwIO $ PeekException 0 . T.pack $ "Wrong message magic, " ++ show messageMagic'-      peekSized fill bb sizeTagLength-{-# INLINE peekMessageHeader #-}+-- | Read and check the magic number from a 'ByteBuffer'+peekMessageMagic :: MonadIO m => FillByteBuffer i m -> ByteBuffer -> PeekMessage i m ()+peekMessageMagic fill bb =+    peekSized fill bb magicLength >>= \case+      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. peekMessage :: (MonadIO m, Store a) => FillByteBuffer i m -> ByteBuffer -> PeekMessage i m (Message a) peekMessage fill bb =-  fmap Message (peekSized fill bb =<< peekMessageHeader fill bb)+  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@@ -141,15 +146,25 @@ -- 'Nothing'.  If there is some data available, but not enough to -- decode the whole 'Message', a 'PeekException' will be thrown. decodeMessage :: (Store a, MonadIO m) => FillByteBuffer i m -> ByteBuffer -> m (Maybe i) -> m (Maybe (Message a))-decodeMessage fill bb getInp = do-  mbRes <- runMaybeT (iterTM (\consumeInp -> consumeInp =<< MaybeT getInp) (peekMessage fill bb))-  case mbRes of-    Just x -> return (Just x)+decodeMessage fill bb getInp =+  maybeDecode (peekMessageMagic fill bb) >>= \case+    Just () -> maybeDecode (peekMessageSizeTag fill bb >>= peekSized fill bb) >>= \case+      Just x -> return (Just (Message x))+      Nothing -> do+        -- We have already read the message magic, so a failure to+        -- read the whole message means we have an incomplete message.+        available <- BB.availableBytes bb+        liftIO $ throwIO $ PeekException available $ T.pack+          "Data.Store.Streaming.decodeMessage: could not get enough bytes to decode message"     Nothing -> do       available <- BB.availableBytes bb-      unless (available == 0) $ liftIO $ throwIO $ PeekException available $ T.pack $+      -- At this point, we have not consumed anything yet, so if bb is+      -- empty, there simply was no message to read.+      unless (available == 0) $ liftIO $ throwIO $ PeekException available $ T.pack         "Data.Store.Streaming.decodeMessage: could not get enough bytes to decode message"       return Nothing+  where+    maybeDecode m = runMaybeT (iterTM (\consumeInp -> consumeInp =<< MaybeT getInp) m) {-# INLINE decodeMessage #-}  -- | Decode some 'Message' from a 'ByteBuffer', by first reading its

@@ -290,7 +290,7 @@             `M.difference`             stores     forM (M.toList primInsts) $ \primInst -> case primInst of-        ([instTy], TypeclassInstance cs ty _) -> do+        ([_], TypeclassInstance cs ty _) -> do             let argTy = head (tail (unAppsT ty))             sizeExpr <- [|                 VarSize $ \x ->@@ -309,7 +309,7 @@                 poke len                 pokeFromByteArray array (offset * sz) (len * sz)                 |]-            return $ makeStoreInstance cs instTy sizeExpr peekExpr pokeExpr+            return $ makeStoreInstance cs (AppT (ConT ''PV.Vector) argTy) sizeExpr peekExpr pokeExpr         _ -> fail "Invariant violated in derivemanyStorePrimVector"  

@@ -16,6 +16,7 @@ import qualified Data.ByteString as BS import           Data.Char (isUpper, isLower) import           Data.Data (Data)+import           Data.Functor.Contravariant import           Data.Generics (listify) import           Data.List (sortBy) import           Data.Monoid ((<>))@@ -40,7 +41,7 @@ instance NFData a => NFData (Tagged a)  instance (Store a, HasTypeHash a) => Store (Tagged a) where-    size = addSize 20 (contramapSize unTagged size)+    size = addSize 20 (contramap unTagged size)     peek = do         tag <- peek         let expected = typeHash (Proxy :: Proxy a)

@@ -1,9 +1,9 @@--- This file has been generated from package.yaml by hpack version 0.14.1.+-- This file has been generated from package.yaml by hpack version 0.17.0. -- -- see: https://github.com/sol/hpack  name:           store-version:        0.3+version:        0.3.1 synopsis:       Fast binary serialization category:       Serialization, Data homepage:       https://github.com/fpco/store#readme@@ -78,6 +78,7 @@     , network >=2.6.0.2     , streaming-commons >=0.1.10.0     , async >=2.0.2+    , contravariant >=1.3   exposed-modules:       Data.Store       Data.Store.Internal@@ -142,6 +143,7 @@     , network >=2.6.0.2     , streaming-commons >=0.1.10.0     , async >=2.0.2+    , contravariant >=1.3     , store   other-modules:       Data.Store.StreamingSpec@@ -199,18 +201,13 @@     , network >=2.6.0.2     , streaming-commons >=0.1.10.0     , async >=2.0.2+    , contravariant >=1.3     , store     , weigh     , criterion     , cereal     , cereal-vector     , vector-binary-instances-  other-modules:-      Data.Store.StreamingSpec-      Data.StoreSpec-      Data.StoreSpec.TH-      Spec-      System.IO.ByteBufferSpec   default-language: Haskell2010  benchmark store-bench@@ -262,6 +259,7 @@     , network >=2.6.0.2     , streaming-commons >=0.1.10.0     , async >=2.0.2+    , contravariant >=1.3     , criterion     , store   if flag(comparison-bench)

@@ -50,7 +50,6 @@     describe "ByteString" $ do       it "Throws an Exception on incomplete messages." decodeIncomplete       it "Throws an Exception on messages that are shorter than indicated." decodeTooShort-      it "Throws an Exception on messages that are longer than indicated." decodeTooLong #ifndef mingw32_HOST_OS     describe "Socket" $ do       it "Decodes data trickling through a socket." $ property decodeTricklingMessageFd@@ -196,26 +195,14 @@   let bs = encodeMessage (Message (42 :: Integer))   in BS.take (BS.length bs - 1) bs -decodeTooLong :: IO ()-decodeTooLong = BB.with Nothing $ \bb -> do-    BB.copyByteString bb (encodeMessageTooLong . Message $ (1 :: Int))-    (decodeMessageBS bb (return Nothing) :: IO (Maybe (Message Int)))-        `shouldThrow` \PeekException{} -> True- decodeTooShort :: IO () decodeTooShort = BB.with Nothing $ \bb -> do     BB.copyByteString bb (encodeMessageTooShort . Message $ (1 :: Int))     (decodeMessageBS bb (return Nothing) :: IO (Maybe (Message Int)))         `shouldThrow` \PeekException{} -> True -encodeMessageTooLong :: Store a => Message a -> BS.ByteString-encodeMessageTooLong (Message x) =-    let l = 8 + getSize x-        totalLength = 8 + l-    in unsafeEncodeWith (poke l >> poke x >> poke (0::Int64)) totalLength--encodeMessageTooShort :: Store a => Message a -> BS.ByteString-encodeMessageTooShort (Message _x) =-    let l = 0-        totalLength = 8 + l-    in unsafeEncodeWith (poke l) totalLength+encodeMessageTooShort :: Message Int -> BS.ByteString+encodeMessageTooShort msg =+    BS.take (BS.length encoded - (getSize (0 :: Int))) encoded+  where+    encoded = encodeMessage msg

@@ -392,6 +392,10 @@                             , BS.drop (sizeOf (10 :: Int)) bs                             ]         evaluate (decodeEx bs' :: BS.ByteString) `shouldThrow` isTooManyBytesException+    it "Handles unaligned access" $ do+        assertRoundtrip verbose (250 :: Word8, 40918 :: Word16, 120471416 :: Word32)+        assertRoundtrip verbose (250 :: Word8, 10.1 :: Float, 8697.65 :: Double)+        (return () :: IO ())  isPokeException :: Test.Hspec.Selector PokeException isPokeException = const True