store 0.4.2 → 0.4.3
raw patch · 8 files changed
+33/−105 lines, 8 filesdep ~basedep ~template-haskellPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, template-haskell
API changes (from Hackage documentation)
+ Data.Store.TH: makeStore :: Name -> Q [Dec]
+ Data.Store.TH.Internal: makeStore :: Name -> Q [Dec]
Files
- ChangeLog.md +9/−0
- src/Data/Store/Impl.hs +0/−4
- src/Data/Store/Internal.hs +0/−66
- src/Data/Store/Streaming.hs +0/−14
- src/Data/Store/TH.hs +9/−5
- src/Data/Store/TH/Internal.hs +14/−4
- src/System/IO/ByteBuffer.hs +0/−11
- store.cabal +1/−1
ChangeLog.md view
@@ -1,5 +1,14 @@ # ChangeLog +## 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,
src/Data/Store/Impl.hs view
@@ -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
src/Data/Store/Internal.hs view
@@ -361,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 ->@@ -377,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 ->@@ -393,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 ->@@ -409,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?@@ -424,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 ->@@ -440,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@@ -479,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@@ -504,9 +483,6 @@ size = sizeSequence poke = pokeSequence peek = peekSequence- {-# INLINE size #-}- {-# INLINE peek #-}- {-# INLINE poke #-} instance Store a => Store (NE.NonEmpty a) @@ -514,9 +490,6 @@ size = sizeSequence poke = pokeSequence peek = peekSequence- {-# INLINE size #-}- {-# INLINE peek #-}- {-# INLINE poke #-} instance (Store a, Ord a) => Store (Set a) where size =@@ -527,25 +500,16 @@ VarSize f -> Set.foldl' (\acc a -> acc + f a) 0 t poke = pokeSet peek = Set.fromDistinctAscList <$> peek- {-# INLINE size #-}- {-# INLINE peek #-}- {-# INLINE poke #-} instance Store IntSet where size = sizeSet poke = pokeSet peek = IntSet.fromDistinctAscList <$> peek- {-# INLINE size #-}- {-# INLINE peek #-}- {-# INLINE poke #-} instance Store a => Store (IntMap a) where size = sizeOrdMap poke = pokeOrdMap peek = peekOrdMapWith IntMap.fromDistinctAscList- {-# INLINE size #-}- {-# INLINE peek #-}- {-# INLINE poke #-} instance (Ord k, Store k, Store a) => Store (Map k a) where size =@@ -560,43 +524,28 @@ t poke = pokeOrdMap peek = peekOrdMapWith Map.fromDistinctAscList- {-# INLINE size #-}- {-# INLINE peek #-}- {-# INLINE poke #-} 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 ->@@ -696,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 @@ -717,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)
src/Data/Store/Streaming.hs view
@@ -80,7 +80,6 @@ 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.@@ -88,7 +87,6 @@ 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,14 +196,12 @@ 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 :: (MonadResource m, Store a)@@ -234,4 +221,3 @@ case mmessage of Nothing -> return () Just message -> C.yield message >> go buffer-{-# INLINE conduitDecode #-}
src/Data/Store/TH.hs view
@@ -2,9 +2,9 @@ -- | 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@@ -14,6 +14,9 @@ -- |])) -- @ --+-- 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 +24,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 +40,7 @@ import Test.Hspec import Test.Hspec.SmallCheck (property) import Test.SmallCheck+import Data.Store.TH.Internal (makeStore) ------------------------------------------------------------------------ -- Testing
src/Data/Store/TH/Internal.hs view
@@ -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+ preds <- mapM (\tv -> [t| Store $(varT tv) |]) (dtTvs dt)+ let 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@@ -382,11 +395,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
src/System/IO/ByteBuffer.hs view
@@ -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.
store.cabal view
@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: store-version: 0.4.2+version: 0.4.3 synopsis: Fast binary serialization category: Serialization, Data homepage: https://github.com/fpco/store#readme