buffer (empty) → 0.5.0.1
raw patch · 7 files changed
+472/−0 lines, 7 filesdep +basedep +base-preludedep +buffersetup-changed
Dependencies added: base, base-prelude, buffer, bug, bytestring, criterion, quickcheck-instances, rerebase, tasty, tasty-hunit, tasty-quickcheck
Files
- LICENSE +22/−0
- Setup.hs +2/−0
- benchmarks/Main.hs +28/−0
- buffer.cabal +100/−0
- library/Buffer.hs +197/−0
- library/Buffer/Prelude.hs +73/−0
- tests/Main.hs +50/−0
+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2017, Nikita Volkov++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ benchmarks/Main.hs view
@@ -0,0 +1,28 @@+module Main where++import Prelude+import Bug+import Criterion.Main+import qualified Buffer as A+import qualified Data.ByteString as D+++main =+ defaultMain =<< sequence+ [+ benchPush "1" (2^8) 1+ ,+ benchPush "10" (2^8) 10+ ,+ benchPush "100" (2^8) 100+ ]++benchOnBuffer name size io =+ do+ buffer <- A.new size+ return (bench name (whnfIO (io buffer)))++benchPush name bufferSize factor =+ benchOnBuffer name bufferSize $ + let !bytes = fromString (replicate 10000 'a')+ in \buffer -> replicateM factor $ A.pushBytes buffer bytes
+ buffer.cabal view
@@ -0,0 +1,100 @@+name:+ buffer+version:+ 0.5.0.1+category:+ Data+synopsis:+ Simple mutable low-level buffer for IO+homepage:+ https://github.com/nikita-volkov/buffer +bug-reports:+ https://github.com/nikita-volkov/buffer/issues +author:+ Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer:+ Nikita Volkov <nikita.y.volkov@mail.ru>+copyright:+ (c) 2017, Nikita Volkov+license:+ MIT+license-file:+ LICENSE+build-type:+ Simple+cabal-version:+ >=1.10++source-repository head+ type:+ git+ location:+ git://github.com/nikita-volkov/buffer.git++library+ hs-source-dirs:+ library+ default-extensions:+ Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+ default-language:+ Haskell2010+ exposed-modules:+ Buffer+ other-modules:+ Buffer.Prelude+ build-depends:+ -- data:+ bytestring >= 0.10 && < 0.11,+ -- errors:+ bug >= 1 && < 2,+ -- general:+ base-prelude >= 1 && < 2,+ base >= 4.7 && < 5++test-suite tests+ type:+ exitcode-stdio-1.0+ hs-source-dirs:+ tests+ main-is:+ Main.hs+ ghc-options:+ -O2+ -threaded+ "-with-rtsopts=-N"+ default-extensions:+ Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+ default-language:+ Haskell2010+ build-depends:+ --+ buffer,+ -- testing:+ tasty == 0.11.*,+ tasty-quickcheck == 0.8.*,+ tasty-hunit == 0.9.*,+ quickcheck-instances >= 0.3.11 && < 0.4,+ --+ bug == 1.*,+ rerebase == 1.*++benchmark benchmarks+ type:+ exitcode-stdio-1.0+ hs-source-dirs:+ benchmarks+ main-is:+ Main.hs+ ghc-options:+ -O2+ -threaded+ -rtsopts+ default-extensions:+ Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveTraversable, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+ default-language:+ Haskell2010+ build-depends:+ buffer,+ criterion == 1.1.*,+ bug == 1.*,+ rerebase == 1.*
+ library/Buffer.hs view
@@ -0,0 +1,197 @@+module Buffer+(+ Buffer,+ new,+ -- * Pushing+ push,+ pushBytes,+ pushStorable,+ -- * Pulling+ pull,+ pullBytes,+ pullStorable,+ -- * Analysing+ getBytes,+ getSpace,+)+where++import Buffer.Prelude hiding (State, Buffer)+import Foreign.C+import qualified Data.ByteString.Internal as C++++foreign import ccall unsafe "memmove"+ memmove :: Ptr a {-^ Destination -} -> Ptr a {-^ Source -} -> CSize {-^ Count -} -> IO (Ptr a) {-^ Destination -}++foreign import ccall unsafe "memcpy"+ memcpy :: Ptr a {-^ Destination -} -> Ptr a {-^ Source -} -> CSize {-^ Count -} -> IO (Ptr a) {-^ Destination -}+++{-|+Mutable buffer.+-}+newtype Buffer =+ Buffer (IORef State)++data State =+ {-|+ * Buffer pointer+ * Start offset+ * End offset+ * Max amount+ -}+ State !(ForeignPtr Word8) !Int !Int !Int++{-|+Create a new buffer of the specified initial capacity.+-}+{-# INLINE new #-}+new :: Int -> IO Buffer+new capacity =+ do+ fptr <- mallocForeignPtrBytes capacity+ stateIORef <- newIORef (State fptr 0 0 capacity)+ return (Buffer stateIORef)++{-|+Prepares the buffer to be filled with at maximum the specified amount of bytes,+then uses the pointer-action to populate it.+It is your responsibility to ensure that the action does not exceed the space limit.++The pointer-action returns the amount of bytes it actually writes to the buffer.+That amount then is used to move the buffer's cursor accordingly.+It can also produce some @result@, which will then be emitted by @push@.++It also aligns or grows the buffer if required.+-}+{-# INLINABLE push #-}+push :: Buffer -> Int -> (Ptr Word8 -> IO (Int, result)) -> IO result+push (Buffer stateIORef) space ptrIO =+ do+ State fptr start end capacity <- readIORef stateIORef+ let+ remainingSpace = capacity - end+ capacityDelta = space - remainingSpace+ occupiedSpace = end - start+ in + if capacityDelta <= 0 -- Doesn't need more space?+ then + do+ (actualSpace, output) <- withForeignPtr fptr $ \ptr -> ptrIO (plusPtr ptr end)+ writeIORef stateIORef (State fptr start (end + actualSpace) capacity)+ return output+ else + if capacityDelta > start -- Needs growing?+ then+ -- Grow+ do+ let newCapacity = occupiedSpace + space+ newFPtr <- mallocForeignPtrBytes newCapacity+ (actualSpace, output) <- withForeignPtr newFPtr $ \newPtr -> do+ withForeignPtr fptr $ \ptr -> do+ memcpy newPtr (plusPtr ptr start) (fromIntegral occupiedSpace)+ ptrIO (plusPtr newPtr occupiedSpace)+ let newOccupiedSpace = occupiedSpace + actualSpace+ writeIORef stateIORef (State newFPtr 0 newOccupiedSpace newCapacity)+ return output+ else + -- Align+ do+ (actualSpace, output) <- withForeignPtr fptr $ \ptr -> do+ memmove ptr (plusPtr ptr start) (fromIntegral occupiedSpace)+ ptrIO (plusPtr ptr occupiedSpace)+ writeIORef stateIORef (State fptr 0 (occupiedSpace + actualSpace) capacity)+ return output++{-|+Pulls the specified amount of bytes from the buffer using the provided pointer-action,+freeing the buffer from the pulled bytes afterwards.++In case the buffer does not contain enough bytes yet,+the second action is called instead, given the amount of required bytes missing.+You should use that action to refill the buffer accordingly and pull again.+-}+{-# INLINE pull #-}+pull :: Buffer -> Int -> (Ptr Word8 -> IO result) -> (Int -> IO result) -> IO result+pull (Buffer stateIORef) pulledAmount ptrIO refill =+ do+ State fptr start end capacity <- readIORef stateIORef+ let newStart = start + pulledAmount+ if newStart > end+ then refill (newStart - end)+ else withForeignPtr fptr $ \ptr -> do+ pulled <- ptrIO (plusPtr ptr start)+ writeIORef stateIORef (State fptr newStart end capacity)+ return pulled++{-|+Push a byte array into the buffer.+-}+{-# INLINE pushBytes #-}+pushBytes :: Buffer -> ByteString -> IO ()+pushBytes buffer (C.PS bytesFPtr offset length) =+ push buffer length $ \ptr ->+ withForeignPtr bytesFPtr $ \bytesPtr ->+ C.memcpy ptr (plusPtr bytesPtr offset) length $> (length, ())++{-|+Pulls the specified amount of bytes, converting them into @result@,+if the buffer contains that amount.++In case the buffer does not contain enough bytes yet,+the second action is called instead, given the amount of required bytes missing.+You should use that action to refill the buffer accordingly and pull again.+-}+{-# INLINE pullBytes #-}+pullBytes :: Buffer -> Int -> (ByteString -> result) -> (Int -> IO result) -> IO result+pullBytes buffer amount bytesResult =+ pull buffer amount (\ptr -> fmap bytesResult (C.create amount (\destPtr -> C.memcpy destPtr ptr amount)))++{-|+Push a storable value into the buffer.+-}+{-# INLINE pushStorable #-}+pushStorable :: (Storable storable) => Buffer -> storable -> IO ()+pushStorable buffer storable =+ push buffer amount (\ptr -> poke (castPtr ptr) storable $> (amount, ()))+ where+ amount = sizeOf storable++{-|+Pulls a storable value, converting it into @result@,+if the buffer contains enough bytes.++In case the buffer does not contain enough bytes yet,+the second action is called instead, given the amount of required bytes missing.+You should use that action to refill the buffer accordingly and pull again.+-}+{-# INLINE pullStorable #-}+pullStorable :: (Storable storable) => Buffer -> (storable -> result) -> (Int -> IO result) -> IO result+pullStorable buffer storableResult =+ pull buffer amount (\ptr -> fmap storableResult (peek (castPtr ptr)))+ where+ amount =+ sizeOf ((undefined :: (a -> b) -> a) storableResult)++{-|+Get how much space is occupied by the buffer's data.+-}+{-# INLINE getSpace #-}+getSpace :: Buffer -> IO Int+getSpace (Buffer stateIORef) =+ do+ State fptr start end capacity <- readIORef stateIORef+ return (end - start)++{-|+Create a bytestring representation without modifying the buffer.+-}+{-# INLINE getBytes #-}+getBytes :: Buffer -> IO ByteString+getBytes (Buffer stateIORef) =+ do+ State fptr start end capacity <- readIORef stateIORef+ let size = end - start+ withForeignPtr fptr $ \ptr -> C.create size $ \destPtr -> C.memcpy destPtr ptr size
+ library/Buffer/Prelude.hs view
@@ -0,0 +1,73 @@+module Buffer.Prelude+(+ module Exports,+ forMToZero_,+ forMFromZero_,+ strictCons,+ traceEventIO,+ traceEvent,+ traceMarkerIO,+ traceMarker,+)+where+++-- base-prelude+-------------------------+import BasePrelude as Exports hiding (assert, left, right, isLeft, isRight, (<>), First(..), Last(..), ProtocolError, traceEvent, traceEventIO, traceMarker, traceMarkerIO)++-- bytestring+-------------------------+import Data.ByteString as Exports (ByteString)++-- bug+-------------------------+import Bug as Exports++-- +-------------------------++import qualified GHC.RTS.Flags as A+import qualified BasePrelude as B+++-- * Workarounds for unremoved event logging+-------------------------++{-# NOINLINE matchTraceUserEvents #-}+matchTraceUserEvents :: a -> a -> a+matchTraceUserEvents =+ case A.user (unsafeDupablePerformIO A.getTraceFlags) of+ True -> \_ x -> x+ False -> \x _ -> x++{-# NOINLINE traceEventIO #-}+!traceEventIO =+ matchTraceUserEvents (const (return ())) B.traceEventIO++{-# NOINLINE traceEvent #-}+!traceEvent =+ matchTraceUserEvents (const id) B.traceEvent++{-# NOINLINE traceMarkerIO #-}+!traceMarkerIO =+ matchTraceUserEvents (const (return ())) B.traceMarkerIO++{-# NOINLINE traceMarker #-}+!traceMarker =+ matchTraceUserEvents (const id) B.traceMarker++{-# INLINE forMToZero_ #-}+forMToZero_ :: Applicative m => Int -> (Int -> m a) -> m ()+forMToZero_ !startN f =+ ($ pred startN) $ fix $ \loop !n -> if n >= 0 then f n *> loop (pred n) else pure ()++{-# INLINE forMFromZero_ #-}+forMFromZero_ :: Applicative m => Int -> (Int -> m a) -> m ()+forMFromZero_ !endN f =+ ($ 0) $ fix $ \loop !n -> if n < endN then f n *> loop (succ n) else pure ()++{-# INLINE strictCons #-}+strictCons :: a -> [a] -> [a]+strictCons !a b =+ let !c = a : b in c
+ tests/Main.hs view
@@ -0,0 +1,50 @@+module Main where++import Prelude+import Bug+import Test.Tasty+import Test.Tasty.Runners+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck+import Test.QuickCheck.Instances+import qualified Buffer as A+import qualified Data.ByteString as D+import qualified Data.ByteString.Internal as B+++main =+ defaultMain $+ testGroup "All tests"+ [+ testProperty "Concatenation of pushed bytestrings equals the byte representation" $ \(inputs :: [ByteString]) ->+ unsafePerformIO $ do+ buffer <- A.new (2 ^ 8)+ forM_ inputs $ \input -> A.pushBytes buffer input+ let concattedInputs = mconcat inputs+ output <- A.pullBytes buffer (D.length concattedInputs) id ($bug "")+ return (concattedInputs === output)+ ,+ testProperty "Numbers" $ \(inputs :: [Word64]) ->+ unsafePerformIO $ do+ buffer <- A.new 2+ forM_ inputs $ \input -> A.pushStorable buffer input+ outputs <- (traverse (const (A.pullStorable buffer id ($bug ""))) inputs)+ return (inputs === outputs)+ ,+ testCase "Interleaving" $ do+ let (input1, input2, input3) = (1, 2, 3) :: (Word64, Word64, Word64)+ buffer <- A.new 2+ A.pushStorable buffer input1+ A.pushStorable buffer input2+ output1 <- A.pullStorable buffer id ($bug "")+ A.pushStorable buffer input3+ output2 <- A.pullStorable buffer id ($bug "")+ output3 <- A.pullStorable buffer id ($bug "")+ assertEqual (show output1) input1 output1+ assertEqual (show output2) input2 output2+ assertEqual (show output3) input3 output3+ ]++inspect :: A.Buffer -> IO ()+inspect buffer =+ print . D.unpack =<< A.getBytes buffer