diff --git a/Data/StorableVector.hs b/Data/StorableVector.hs deleted file mode 100644 --- a/Data/StorableVector.hs +++ /dev/null @@ -1,1565 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} --- --- Module : StorableVector --- Copyright : (c) The University of Glasgow 2001, --- (c) David Roundy 2003-2005, --- (c) Simon Marlow 2005 --- (c) Don Stewart 2005-2006 --- (c) Bjorn Bringert 2006 --- (c) Spencer Janssen 2006 --- (c) Henning Thielemann 2008-2013 --- --- --- License : BSD-style --- --- Maintainer : Henning Thielemann --- Stability : experimental --- Portability : portable, requires ffi and cpp --- Tested with : GHC 6.4.1 and Hugs March 2005 --- - --- --- | A time and space-efficient implementation of vectors using --- packed arrays, suitable for high performance use, both in terms --- of large data quantities, or high speed requirements. Vectors --- are encoded as strict arrays, held in a 'ForeignPtr', --- and can be passed between C and Haskell with little effort. --- --- This module is intended to be imported @qualified@, to avoid name --- clashes with "Prelude" functions. eg. --- --- > import qualified Data.StorableVector as V --- --- Original GHC implementation by Bryan O\'Sullivan. Rewritten to use --- UArray by Simon Marlow. Rewritten to support slices and use --- ForeignPtr by David Roundy. Polished and extended by Don Stewart. --- Generalized to any Storable value by Spencer Janssen. --- Chunky lazy stream, also with chunk pattern control, --- mutable access in ST monad, Builder monoid by Henning Thieleman. - -module Data.StorableVector ( - - -- * The @Vector@ type - Vector, - - -- * Introducing and eliminating 'Vector's - empty, - singleton, - pack, - unpack, - packN, - packWith, - unpackWith, - - -- * Basic interface - cons, - snoc, - append, - head, - last, - tail, - init, - null, - length, - viewL, - viewR, - switchL, - switchR, - - -- * Transforming 'Vector's - map, - reverse, - intersperse, - transpose, - - -- * Reducing 'Vector's (folds) - foldl, - foldl', - foldl1, - foldl1', - foldr, - foldr1, - - -- ** Special folds - concat, - concatMap, - monoidConcatMap, - any, - all, - maximum, - minimum, - - -- * Building 'Vector's - -- ** Scans - scanl, - scanl1, - scanr, - scanr1, - - -- ** Accumulating maps - mapAccumL, - mapAccumR, - mapIndexed, - - -- ** Unfolding 'Vector's - replicate, - iterateN, - unfoldr, - unfoldrN, - unfoldrResultN, - sample, - - -- * Substrings - - -- ** Breaking strings - take, - drop, - splitAt, - takeWhile, - dropWhile, - span, - spanEnd, - break, - breakEnd, - group, - groupBy, - inits, - tails, - - -- ** Breaking into many substrings - split, - splitWith, - tokens, - - -- ** Joining strings - join, - - -- * Predicates - isPrefixOf, - isSuffixOf, - - -- * Searching 'Vector's - - -- ** Searching by equality - elem, - notElem, - - -- ** Searching with a predicate - find, - filter, - - -- * Indexing 'Vector's - index, - elemIndex, - elemIndices, - elemIndexEnd, - findIndex, - findIndices, - count, - findIndexOrEnd, - - -- * Zipping and unzipping 'Vector's - zip, - zipWith, - zipWith3, - zipWith4, - unzip, - copy, - - -- * Interleaved 'Vector's - sieve, - deinterleave, - interleave, - - -- * IO - hGet, - hPut, - readFile, - writeFile, - appendFile, - - ) where - -import qualified Prelude as P -import Prelude hiding (reverse,head,tail,last,init,null - ,length,map,lines,foldl,foldr,unlines - ,concat,any,take,drop,splitAt,takeWhile - ,dropWhile,span,break,elem,filter,maximum - ,minimum,all,concatMap,foldl1,foldr1 - ,scanl,scanl1,scanr,scanr1 - ,readFile,writeFile,appendFile,replicate - ,getContents,getLine,putStr,putStrLn - ,zip,zipWith,zipWith3,unzip,notElem - ,pred,succ) - -import Data.StorableVector.Base - -import qualified Control.Monad.Trans.Cont as MC - -import qualified Data.List as List -import qualified Data.List.HT as ListHT -import qualified Data.Strictness.HT as Strict -import Data.Tuple.HT (mapSnd, ) -import Data.Maybe.HT (toMaybe, ) -import Data.Maybe (fromMaybe, isJust, ) -import Data.Bool.HT (if', ) - -import Control.Exception (assert, bracket, ) - -import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, ) -import Foreign.Marshal.Array (advancePtr, copyArray, withArray, ) -import Foreign.Ptr (Ptr, minusPtr, ) -import Foreign.Storable (Storable(..)) - -import Data.Monoid (Monoid, mempty, mappend, mconcat, ) -import Control.Monad (mplus, guard, when, liftM2, liftM3, liftM4, ) - -import System.IO (openBinaryFile, hClose, hFileSize, - hGetBuf, hPutBuf, - Handle, IOMode(..), ) - -import qualified System.Unsafe as Unsafe --- import GHC.IOBase - --- ----------------------------------------------------------------------------- - -instance (Storable a, Eq a) => Eq (Vector a) where - (==) = equal - -instance (Storable a) => Monoid (Vector a) where - mempty = empty - mappend = append - mconcat = concat - --- | /O(n)/ Equality on the 'Vector' type. -equal :: (Storable a, Eq a) => Vector a -> Vector a -> Bool -equal a b = - Unsafe.performIO $ - withStartPtr a $ \paf la -> - withStartPtr b $ \pbf lb -> - if la /= lb - then - return False - else - if paf == pbf - then return True - else - let go = Strict.arguments3 $ \p q l -> - if l==0 - then return True - else - do x <- peek p - y <- peek q - if x==y - then go (incPtr p) (incPtr q) (l-1) - else return False - in go paf pbf la -{-# INLINE equal #-} - --- ----------------------------------------------------------------------------- --- Introducing and eliminating 'Vector's - --- | /O(1)/ The empty 'Vector' -empty :: (Storable a) => Vector a -empty = unsafeCreate 0 $ const $ return () -{-# NOINLINE empty #-} - --- | /O(1)/ Construct a 'Vector' containing a single element -singleton :: (Storable a) => a -> Vector a -singleton c = unsafeCreate 1 $ \p -> poke p c -{-# INLINE singleton #-} - --- | /O(n)/ Convert a '[a]' into a 'Vector a'. --- -pack :: (Storable a) => [a] -> Vector a -pack str = unsafeCreate (P.length str) $ \p -> go p str - where - go = Strict.arguments2 $ \p -> - ListHT.switchL - (return ()) - (\x xs -> poke p x >> go (incPtr p) xs) - --- | /O(n)/ Convert first @n@ elements of a '[a]' into a 'Vector a'. --- -packN :: (Storable a) => Int -> [a] -> (Vector a, [a]) -packN n = - mapSnd (fromMaybe []) . unfoldrN n ListHT.viewL - --- | /O(n)/ Converts a 'Vector a' to a '[a]'. -unpack :: (Storable a) => Vector a -> [a] -unpack = foldr (:) [] -{-# INLINE unpack #-} - ------------------------------------------------------------------------- - --- | /O(n)/ Convert a list into a 'Vector' using a conversion function -packWith :: (Storable b) => (a -> b) -> [a] -> Vector b -packWith k str = unsafeCreate (P.length str) $ \p -> go p str - where - go = Strict.arguments2 $ \p -> - ListHT.switchL - (return ()) - (\x xs -> poke p (k x) >> go (incPtr p) xs) - -- less space than pokeElemOff -{-# INLINE packWith #-} - -{- -*Data.StorableVector> List.take 10 $ unpackWith id $ pack [0..10000000::Int] -[0,1,2,3,4,5,6,7,8,9] -(19.18 secs, 2327851592 bytes) --} --- | /O(n)/ Convert a 'Vector' into a list using a conversion function -unpackWith :: (Storable a) => (a -> b) -> Vector a -> [b] -unpackWith f = foldr ((:) . f) [] -{-# INLINE unpackWith #-} - -{- -That's too inefficient, since it builds the list from back to front, -that is, in a too strict manner. - --- | /O(n)/ Convert a 'Vector' into a list using a conversion function -unpackWith :: (Storable a) => (a -> b) -> Vector a -> [b] -unpackWith _ (SV _ _ 0) = [] -unpackWith k v@(SV ps s l) = inlinePerformIO $ withStartPtr v $ \p -> - go p (l - 1) [] - where - STRICT3(go) - go p 0 acc = peek p >>= \e -> return (k e : acc) - go p n acc = peekElemOff p n >>= \e -> go p (n-1) (k e : acc) -{-# INLINE unpackWith #-} - - -*Data.StorableVector> List.take 10 $ unpack $ pack [0..10000000::Int] -[0,1,2,3,4,5,6,7,8,9] -(18.57 secs, 2323959948 bytes) -*Data.StorableVector> unpack $ take 10 $ pack [0..10000000::Int] -[0,1,2,3,4,5,6,7,8,9] -(18.40 secs, 2324002120 bytes) -*Data.StorableVector> List.take 10 $ unpackWith id $ pack [0..10000000::Int] -Interrupted. --} - --- --------------------------------------------------------------------- --- Basic interface - --- | /O(1)/ Test whether a 'Vector' is empty. -null :: Vector a -> Bool -null (SV _ _ l) = assert (l >= 0) $ l <= 0 -{-# INLINE null #-} - --- --------------------------------------------------------------------- --- | /O(1)/ 'length' returns the length of a 'Vector' as an 'Int'. -length :: Vector a -> Int -length (SV _ _ l) = assert (l >= 0) $ l - --- --- length/loop fusion. When taking the length of any fuseable loop, --- rewrite it as a foldl', and thus avoid allocating the result buffer --- worth around 10% in speed testing. --- - -{-# INLINE [1] length #-} - ------------------------------------------------------------------------- - --- | /O(n)/ 'cons' is analogous to (:) for lists, but of different --- complexity, as it requires a memcpy. -cons :: (Storable a) => a -> Vector a -> Vector a -cons c v = - unsafeWithStartPtr v $ \f l -> - create (l + 1) $ \p -> do - poke p c - copyArray (incPtr p) f (fromIntegral l) -{-# INLINE cons #-} - --- | /O(n)/ Append an element to the end of a 'Vector' -snoc :: (Storable a) => Vector a -> a -> Vector a -snoc v c = - unsafeWithStartPtr v $ \f l -> - create (l + 1) $ \p -> do - copyArray p f l - pokeElemOff p l c -{-# INLINE snoc #-} - --- | /O(1)/ Extract the first element of a 'Vector', which must be non-empty. --- An exception will be thrown in the case of an empty 'Vector'. -head :: (Storable a) => Vector a -> a -head = - withNonEmptyVector "head" $ \ p s _l -> foreignPeek p s -{-# INLINE head #-} - --- | /O(1)/ Extract the elements after the head of a 'Vector', which must be non-empty. --- An exception will be thrown in the case of an empty 'Vector'. -tail :: (Storable a) => Vector a -> Vector a -tail = - withNonEmptyVector "tail" $ \ p s l -> SV p (s+1) (l-1) -{-# INLINE tail #-} - -laxTail :: (Storable a) => Vector a -> Vector a -laxTail v@(SV fp s l) = - if l<=0 - then v - else SV fp (s+1) (l-1) -{-# INLINE laxTail #-} - --- | /O(1)/ Extract the last element of a 'Vector', which must be finite and non-empty. --- An exception will be thrown in the case of an empty 'Vector'. -last :: (Storable a) => Vector a -> a -last = - withNonEmptyVector "last" $ \ p s l -> foreignPeek p (s+l-1) -{-# INLINE last #-} - --- | /O(1)/ Return all the elements of a 'Vector' except the last one. --- An exception will be thrown in the case of an empty 'Vector'. -init :: Vector a -> Vector a -init = - withNonEmptyVector "init" $ \ p s l -> SV p s (l-1) -{-# INLINE init #-} - --- | /O(n)/ Append two Vectors -append :: (Storable a) => Vector a -> Vector a -> Vector a -append xs ys = - if' (null xs) ys $ - if' (null ys) xs $ - concat [xs,ys] -{-# INLINE append #-} - --- --------------------------------------------------------------------- --- Transformations - --- | /O(n)/ 'map' @f xs@ is the 'Vector' obtained by applying @f@ to each --- element of @xs@. -map :: (Storable a, Storable b) => (a -> b) -> Vector a -> Vector b -map f v = - unsafeWithStartPtr v $ \a len -> - create len $ \p -> - let go = Strict.arguments3 $ - \ n p1 p2 -> - when (n>0) $ - do poke p2 . f =<< peek p1 - go (n-1) (incPtr p1) (incPtr p2) - in go len a p -{-# INLINE map #-} - -{- -mapByIndex :: (Storable a, Storable b) => (a -> b) -> Vector a -> Vector b -mapByIndex f v = inlinePerformIO $ withStartPtr v $ \a len -> - create len $ \p2 -> - let go = Strict.arguments1 $ \ n -> - when (n Vector a -> Vector a -reverse v = - unsafeWithStartPtr v $ \f l -> - create l $ \p -> - sequence_ [peekElemOff f i >>= pokeElemOff p (l - i - 1) - | i <- [0 .. l - 1]] - --- | /O(n)/ The 'intersperse' function takes a element and a --- 'Vector' and \`intersperses\' that element between the elements of --- the 'Vector'. It is analogous to the intersperse function on --- Lists. -intersperse :: (Storable a) => a -> Vector a -> Vector a -intersperse c = pack . List.intersperse c . unpack - --- | The 'transpose' function transposes the rows and columns of its --- 'Vector' argument. -transpose :: (Storable a) => [Vector a] -> [Vector a] -transpose ps = P.map pack (List.transpose (P.map unpack ps)) - --- --------------------------------------------------------------------- --- Reducing 'Vector's - --- | 'foldl', applied to a binary operator, a starting value (typically --- the left-identity of the operator), and a Vector, reduces the --- 'Vector' using the binary operator, from left to right. --- This function is subject to array fusion. -foldl :: (Storable a) => (b -> a -> b) -> b -> Vector a -> b -foldl f v xs = - foldr (\x k acc -> k (f acc x)) id xs v -{-# INLINE foldl #-} - --- | 'foldl\'' is like 'foldl', but strict in the accumulator. -foldl' :: (Storable a) => (b -> a -> b) -> b -> Vector a -> b -foldl' f b v = - Unsafe.performIO $ withStartPtr v $ \ptr l -> - let q = ptr `advancePtr` l - go = Strict.arguments2 $ \p z -> - if p == q - then return z - else go (incPtr p) . f z =<< peek p - in go ptr b -{-# INLINE foldl' #-} - --- | 'foldr', applied to a binary operator, a starting value --- (typically the right-identity of the operator), and a 'Vector', --- reduces the 'Vector' using the binary operator, from right to left. --- However, it is not the same as 'foldl' applied to the reversed vector. --- Actually 'foldr' starts processing with the first element, --- and thus can be used for efficiently building a singly linked list --- by @foldr (:) [] vec@. --- Unfortunately 'foldr' is quite slow for low-level loops, --- since GHC (up to 6.12.1) cannot detect the loop. -foldr :: (Storable a) => (a -> b -> b) -> b -> Vector a -> b -foldr = foldrByLoop -{-# INLINE foldr #-} - -{- -*Data.StorableVector> List.length $ foldrBySwitch (:) [] $ replicate 1000000 'a' -1000000 -(11.29 secs, 1183476300 bytes) -*Data.StorableVector> List.length $ foldrByIO (:) [] $ replicate 1000000 'a' -1000000 -(7.86 secs, 1033901140 bytes) -*Data.StorableVector> List.length $ foldrByIndex (:) [] $ replicate 1000000 'a' -1000000 -(7.86 secs, 914340420 bytes) -*Data.StorableVector> List.length $ foldrByLoop (:) [] $ replicate 1000000 'a' -1000000 -(6.38 secs, 815355460 bytes) --} -{- -We cannot simply increment the pointer, -since ForeignPtr cannot be incremented. -We also cannot convert from ForeignPtr to Ptr -and increment that instead, -because we need to keep the reference to ForeignPtr, -otherwise memory might be freed. -We can also not perform loop entirely in strict IO, -since this eat up the stack quickly -and 'foldr' might be used to build a list lazily. --} -foldrByLoop :: (Storable a) => (a -> b -> b) -> b -> Vector a -> b -foldrByLoop f z (SV fp s l) = - let end = s+l - go = Strict.arguments1 $ \k -> - if k (a -> b -> b) -> b -> Vector a -> b -foldrByIO f z v@(SV fp _ _) = - unsafeWithStartPtr v $ - let go = Strict.arguments2 $ \p l -> - Unsafe.interleaveIO $ - if l>0 - then liftM2 f (peek p) (go (incPtr p) (pred l)) - else touchForeignPtr fp >> return z - in go -{-# INLINE foldrByIO #-} - -foldrByIndex :: (Storable a) => (a -> b -> b) -> b -> Vector a -> b -foldrByIndex k z xs = - let recourse n = - if n < length xs - then k (unsafeIndex xs n) (recourse (succ n)) - else z - in recourse 0 -{-# INLINE foldrByIndex #-} - -{- -This implementation is a bit inefficient, -since switchL creates a new Vector structure -instead of just incrementing an index. --} -foldrBySwitch :: (Storable a) => (a -> b -> b) -> b -> Vector a -> b -foldrBySwitch k z = - let recourse = switchL z (\h t -> k h (recourse t)) - in recourse -{-# INLINE foldrBySwitch #-} --} - - --- | 'foldl1' is a variant of 'foldl' that has no starting value --- argument, and thus must be applied to non-empty 'Vector's. --- This function is subject to array fusion. --- An exception will be thrown in the case of an empty 'Vector'. -foldl1 :: (Storable a) => (a -> a -> a) -> Vector a -> a -foldl1 f = - switchL - (errorEmpty "foldl1") - (foldl f) -{-# INLINE foldl1 #-} - --- | 'foldl1\'' is like 'foldl1', but strict in the accumulator. --- An exception will be thrown in the case of an empty 'Vector'. -foldl1' :: (Storable a) => (a -> a -> a) -> Vector a -> a -foldl1' f = - switchL - (errorEmpty "foldl1'") - (foldl' f) -{-# INLINE foldl1' #-} - --- | 'foldr1' is a variant of 'foldr' that has no starting value argument, --- and thus must be applied to non-empty 'Vector's --- An exception will be thrown in the case of an empty 'Vector'. -foldr1 :: (Storable a) => (a -> a -> a) -> Vector a -> a -foldr1 f = - switchR - (errorEmpty "foldr1") - (flip (foldr f)) -{-# INLINE foldr1 #-} - --- --------------------------------------------------------------------- --- Special folds - --- | /O(n)/ Concatenate a list of 'Vector's. -concat :: (Storable a) => [Vector a] -> Vector a -concat [] = empty -concat [ps] = ps -concat xs = unsafeCreate len $ \ptr -> go ptr xs - where len = P.sum . P.map length $ xs - go = - Strict.arguments2 $ \ptr -> - ListHT.switchL - (return ()) - (\v ps -> do - withStartPtr v $ copyArray ptr - go (ptr `advancePtr` length v) ps) - --- | Map a function over a 'Vector' and concatenate the results -concatMap :: (Storable a, Storable b) => (a -> Vector b) -> Vector a -> Vector b -concatMap f = concat . unpackWith f -{-# INLINE concatMap #-} - --- | This is like @mconcat . map f@, --- but in many cases the result of @f@ will not be storable. -monoidConcatMap :: (Storable a, Monoid m) => (a -> m) -> Vector a -> m -monoidConcatMap f = - foldr (mappend . f) mempty -{-# INLINE monoidConcatMap #-} - --- | /O(n)/ Applied to a predicate and a 'Vector', 'any' determines if --- any element of the 'Vector' satisfies the predicate. -any :: (Storable a) => (a -> Bool) -> Vector a -> Bool -any f = foldr ((||) . f) False -{-# INLINE any #-} - --- | /O(n)/ Applied to a predicate and a 'Vector', 'all' determines --- if all elements of the 'Vector' satisfy the predicate. -all :: (Storable a) => (a -> Bool) -> Vector a -> Bool -all f = foldr ((&&) . f) True -{-# INLINE all #-} - ------------------------------------------------------------------------- - --- | /O(n)/ 'maximum' returns the maximum value from a 'Vector' --- This function will fuse. --- An exception will be thrown in the case of an empty 'Vector'. -maximum :: (Storable a, Ord a) => Vector a -> a -maximum = foldl1' max - --- | /O(n)/ 'minimum' returns the minimum value from a 'Vector' --- This function will fuse. --- An exception will be thrown in the case of an empty 'Vector'. -minimum :: (Storable a, Ord a) => Vector a -> a -minimum = foldl1' min - ------------------------------------------------------------------------- - -switchL :: Storable a => b -> (a -> Vector a -> b) -> Vector a -> b -switchL n j x = - if null x - then n - else j (unsafeHead x) (unsafeTail x) -{-# INLINE switchL #-} - -switchR :: Storable a => b -> (Vector a -> a -> b) -> Vector a -> b -switchR n j x = - if null x - then n - else j (unsafeInit x) (unsafeLast x) -{-# INLINE switchR #-} - -viewL :: Storable a => Vector a -> Maybe (a, Vector a) -viewL = switchL Nothing (curry Just) -{-# INLINE viewL #-} - -viewR :: Storable a => Vector a -> Maybe (Vector a, a) -viewR = switchR Nothing (curry Just) -{-# INLINE viewR #-} - --- | The 'mapAccumL' function behaves like a combination of 'map' and --- 'foldl'; it applies a function to each element of a 'Vector', --- passing an accumulating parameter from left to right, and returning a --- final value of this accumulator together with the new list. -mapAccumL :: (Storable a, Storable b) => (acc -> a -> (acc, b)) -> acc -> Vector a -> (acc, Vector b) -mapAccumL f acc0 as0 = - let (bs, Just (acc2, _)) = - unfoldrN (length as0) - (\(acc,as) -> - fmap - (\(asHead,asTail) -> - let (acc1,b) = f acc asHead - in (b, (acc1, asTail))) - (viewL as)) - (acc0,as0) - in (acc2, bs) -{-# INLINE mapAccumL #-} - --- | The 'mapAccumR' function behaves like a combination of 'map' and --- 'foldr'; it applies a function to each element of a 'Vector', --- passing an accumulating parameter from right to left, and returning a --- final value of this accumulator together with the new 'Vector'. -mapAccumR :: (Storable a, Storable b) => (acc -> a -> (acc, b)) -> acc -> Vector a -> (acc, Vector b) -mapAccumR f acc0 as0 = - let (bs, Just (acc2, _)) = - unfoldlN (length as0) - (\(acc,as) -> - fmap - (\(asInit,asLast) -> - let (acc1,b) = f acc asLast - in (b, (acc1, asInit))) - (viewR as)) - (acc0,as0) - in (acc2, bs) -{-# INLINE mapAccumR #-} - --- | /O(n)/ map functions, provided with the index at each position -mapIndexed :: (Storable a, Storable b) => (Int -> a -> b) -> Vector a -> Vector b -mapIndexed f = snd . mapAccumL (\i e -> (i + 1, f i e)) 0 -{-# INLINE mapIndexed #-} - --- --------------------------------------------------------------------- --- Building 'Vector's - --- | 'scanl' is similar to 'foldl', but returns a list of successive --- reduced values from the left. This function will fuse. --- --- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] --- --- Note that --- --- > last (scanl f z xs) == foldl f z xs. -scanl :: (Storable a, Storable b) => (a -> b -> a) -> a -> Vector b -> Vector a -scanl f acc0 as0 = - fst $ - unfoldrN (succ (length as0)) - (fmap $ \(acc,as) -> - (acc, - fmap - (\(asHead,asTail) -> - (f acc asHead, asTail)) - (viewL as))) - (Just (acc0, as0)) - --- less efficient but much more comprehensible --- scanl f z ps = --- cons z (snd (mapAccumL (\acc a -> let b = f acc a in (b,b)) z ps)) - - -- n.b. haskell's List scan returns a list one bigger than the - -- input, so we need to snoc here to get some extra space, however, - -- it breaks map/up fusion (i.e. scanl . map no longer fuses) -{-# INLINE scanl #-} - --- | 'scanl1' is a variant of 'scanl' that has no starting value argument. --- This function will fuse. --- --- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...] -scanl1 :: (Storable a) => (a -> a -> a) -> Vector a -> Vector a -scanl1 f = switchL empty (scanl f) -{-# INLINE scanl1 #-} - --- | scanr is the right-to-left dual of scanl. -scanr :: (Storable a, Storable b) => (a -> b -> b) -> b -> Vector a -> Vector b -scanr f acc0 as0 = - fst $ - unfoldlN (succ (length as0)) - (fmap $ \(acc,as) -> - (acc, - fmap - (\(asInit,asLast) -> - (f asLast acc, asInit)) - (viewR as))) - (Just (acc0, as0)) -{-# INLINE scanr #-} - --- | 'scanr1' is a variant of 'scanr' that has no starting value argument. -scanr1 :: (Storable a) => (a -> a -> a) -> Vector a -> Vector a -scanr1 f = switchR empty (flip (scanl f)) -{-# INLINE scanr1 #-} - --- --------------------------------------------------------------------- --- Unfolds and replicates - --- | /O(n)/ 'replicate' @n x@ is a 'Vector' of length @n@ with @x@ --- the value of every element. --- -{- nice implementation -replicate :: (Storable a) => Int -> a -> Vector a -replicate n c = - fst $ unfoldrN n (const $ Just (c, ())) () --} - -{- -fast implementation - -Maybe it could be made even faster by plainly copying the bit pattern of the first element. -Since there is no function like 'memset', -we could not warrant that the implementation is really efficient -for the actual machine we run on. --} -replicate :: (Storable a) => Int -> a -> Vector a -replicate n c = - if n <= 0 - then empty - else unsafeCreate n $ - let go = Strict.arguments2 $ \i p -> - if i == 0 - then return () - else poke p c >> go (pred i) (incPtr p) - in go n -{-# INLINE replicate #-} -{- -For 'replicate 10000000 (42::Int)' generates: - -Main_zdwa_info: - movl (%ebp),%eax - testl %eax,%eax - jne .LcfIQ - movl $ghczmprim_GHCziUnit_Z0T_closure+1,%esi - addl $8,%ebp - jmp *(%ebp) -.LcfIQ: - movl 4(%ebp),%ecx - movl $42,(%ecx) - decl %eax - addl $4,4(%ebp) - movl %eax,(%ebp) - jmp Main_zdwa_info - -that is, the inner loop consists of 9 instructions, -where I would write something like: - # counter in %ecx - testl %ecx - jz skip_loop - movl $42,%ebx -start_loop: - movl %ebx,(%edx) - addl $4,%edx - loop start_loop -skip_loop: - -and need only 3 instructions in the loop. --} - - --- | /O(n)/ 'iterateN' @n f x@ is a 'Vector' of length @n@ --- where the elements of @x@ are generated by repeated application of @f@. --- -iterateN :: (Storable a) => Int -> (a -> a) -> a -> Vector a -iterateN n f = - fst . unfoldrN n (\a -> Just (a, f a)) -{-# INLINE iterateN #-} - --- | /O(n)/, where /n/ is the length of the result. The 'unfoldr' --- function is analogous to the List \'unfoldr\'. 'unfoldr' builds a --- 'Vector' from a seed value. The function takes the element and --- returns 'Nothing' if it is done producing the 'Vector or returns --- 'Just' @(a,b)@, in which case, @a@ is the next element in the 'Vector', --- and @b@ is the seed value for further production. --- --- Examples: --- --- > unfoldr (\x -> if x <= 5 then Just (x, x + 1) else Nothing) 0 --- > == pack [0, 1, 2, 3, 4, 5] --- -unfoldr :: (Storable b) => (a -> Maybe (b, a)) -> a -> Vector b -unfoldr f = concat . unfoldChunk 32 64 - where unfoldChunk n n' x = - case unfoldrN n f x of - (s, mx) -> s : maybe [] (unfoldChunk n' (n+n')) mx -{-# INLINE unfoldr #-} - --- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a 'Vector' from a seed --- value. However, the length of the result is limited by the first --- argument to 'unfoldrN'. This function is more efficient than 'unfoldr' --- when the maximum length of the result is known. --- --- The following equation relates 'unfoldrN' and 'unfoldr': --- --- > fst (unfoldrN n f s) == take n (unfoldr f s) --- -unfoldrN :: (Storable b) => Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a) -unfoldrN n f x0 = - if n <= 0 - then (empty, Just x0) - else Unsafe.performIO $ createAndTrim' n $ \p -> go p n x0 - {- - go must not be strict in the accumulator - since otherwise packN would be too strict. - -} - where - go = Strict.arguments2 $ \p i -> \x -> - if i == 0 - then return (0, n-i, Just x) - else - case f x of - Nothing -> return (0, n-i, Nothing) - Just (w,x') -> do poke p w - go (incPtr p) (i-1) x' -{-# INLINE unfoldrN #-} - -{- -Examples: - -f i = Just (i::Char, succ i) - -f i = toMaybe (i<='p') (i::Char, succ i) - --} --- | /O(n)/ Like 'unfoldrN' this function builds a 'Vector' --- from a seed value with limited size. --- Additionally it returns a value, that depends on the state, --- but is not necessarily the state itself. --- If end of vector and end of the generator coincide, --- then the result is as if only the end of vector is reached. --- --- Example: --- --- > unfoldrResultN 30 Char.ord (\c -> if c>'z' then Left 1000 else Right (c, succ c)) 'a' --- --- The following equation relates 'unfoldrN' and 'unfoldrResultN': --- --- > unfoldrN n f s == --- > unfoldrResultN n Just --- > (maybe (Left Nothing) Right . f) s --- --- It is not possible to express 'unfoldrResultN' in terms of 'unfoldrN'. --- -unfoldrResultN :: (Storable b) => Int -> (a -> c) -> (a -> Either c (b, a)) -> a -> (Vector b, c) -unfoldrResultN i g f x0 = - if i <= 0 - then (empty, g x0) - else Unsafe.performIO $ createAndTrim' i $ \p -> go p 0 x0 - {- - go must not be strict in the accumulator - since otherwise packN would be too strict. - -} - where - go = Strict.arguments2 $ \p n -> \a0 -> - if n == i - then return (0, n, g a0) - else - case f a0 of - Left c -> return (0, n, c) - Right (b,a1) -> do poke p b - go (incPtr p) (n+1) a1 -{-# INLINE unfoldrResultN #-} - -unfoldlN :: (Storable b) => Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a) -unfoldlN i f x0 - | i < 0 = (empty, Just x0) - | otherwise = Unsafe.performIO $ createAndTrim' i $ \p -> go (p `advancePtr` i) i x0 - where go = Strict.arguments2 $ \p n -> \x -> - if n == 0 - then return (n, i, Just x) - else - case f x of - Nothing -> return (n, i, Nothing) - Just (w,x') -> - let p' = p `advancePtr` (-1) - in do poke p' w - go p' (n-1) x' -{-# INLINE unfoldlN #-} - - --- | /O(n)/, where /n/ is the length of the result. --- This function constructs a vector by evaluating a function --- that depends on the element index. --- It is a special case of 'unfoldrN' and can in principle be parallelized. --- --- Examples: --- --- > sample 26 (\x -> chr(ord 'a'+x)) --- > == pack "abcdefghijklmnopqrstuvwxyz" --- -sample :: (Storable a) => Int -> (Int -> a) -> Vector a -sample n f = - fst $ unfoldrN n (\i -> Just (f i, succ i)) 0 -{-# INLINE sample #-} - - --- --------------------------------------------------------------------- --- Substrings - --- | /O(1)/ 'take' @n@, applied to a 'Vector' @xs@, returns the prefix --- of @xs@ of length @n@, or @xs@ itself if @n > 'length' xs@. -take :: (Storable a) => Int -> Vector a -> Vector a -take n ps@(SV x s l) - | n <= 0 = empty - | n >= l = ps - | otherwise = SV x s n -{-# INLINE take #-} - --- | /O(1)/ 'drop' @n xs@ returns the suffix of @xs@ after the first @n@ --- elements, or 'empty' if @n > 'length' xs@. -drop :: (Storable a) => Int -> Vector a -> Vector a -drop n ps@(SV x s l) - | n <= 0 = ps - | n >= l = empty - | otherwise = SV x (s+n) (l-n) -{-# INLINE drop #-} - --- | /O(1)/ 'splitAt' @n xs@ is equivalent to @('take' n xs, 'drop' n xs)@. -splitAt :: (Storable a) => Int -> Vector a -> (Vector a, Vector a) -splitAt n ps@(SV x s l) - | n <= 0 = (empty, ps) - | n >= l = (ps, empty) - | otherwise = (SV x s n, SV x (s+n) (l-n)) -{-# INLINE splitAt #-} - --- | 'takeWhile', applied to a predicate @p@ and a 'Vector' @xs@, --- returns the longest prefix (possibly empty) of @xs@ of elements that --- satisfy @p@. -takeWhile :: (Storable a) => (a -> Bool) -> Vector a -> Vector a -takeWhile f ps = unsafeTake (findIndexOrEnd (not . f) ps) ps -{-# INLINE takeWhile #-} - --- | 'dropWhile' @p xs@ returns the suffix remaining after 'takeWhile' @p xs@. -dropWhile :: (Storable a) => (a -> Bool) -> Vector a -> Vector a -dropWhile f ps = unsafeDrop (findIndexOrEnd (not . f) ps) ps -{-# INLINE dropWhile #-} - --- | 'break' @p@ is equivalent to @'span' ('not' . p)@. -break :: (Storable a) => (a -> Bool) -> Vector a -> (Vector a, Vector a) -break p ps = case findIndexOrEnd p ps of n -> (unsafeTake n ps, unsafeDrop n ps) -{-# INLINE break #-} - --- | 'breakEnd' behaves like 'break' but from the end of the 'Vector' --- --- breakEnd p == spanEnd (not.p) -breakEnd :: (Storable a) => (a -> Bool) -> Vector a -> (Vector a, Vector a) -breakEnd p ps = splitAt (findFromEndUntil p ps) ps - --- | 'span' @p xs@ breaks the 'Vector' into two segments. It is --- equivalent to @('takeWhile' p xs, 'dropWhile' p xs)@ -span :: (Storable a) => (a -> Bool) -> Vector a -> (Vector a, Vector a) -span p ps = break (not . p) ps -{-# INLINE span #-} - --- | 'spanEnd' behaves like 'span' but from the end of the 'Vector'. --- We have --- --- > spanEnd (not.isSpace) "x y z" == ("x y ","z") --- --- and --- --- > spanEnd (not . isSpace) ps --- > == --- > let (x,y) = span (not.isSpace) (reverse ps) in (reverse y, reverse x) --- -spanEnd :: (Storable a) => (a -> Bool) -> Vector a -> (Vector a, Vector a) -spanEnd p ps = splitAt (findFromEndUntil (not.p) ps) ps - --- | /O(n)/ Splits a 'Vector' into components delimited by --- separators, where the predicate returns True for a separator element. --- The resulting components do not contain the separators. Two adjacent --- separators result in an empty component in the output. eg. --- --- > splitWith (=='a') "aabbaca" == ["","","bb","c",""] --- > splitWith (=='a') [] == [] --- -splitWith :: (Storable a) => (a -> Bool) -> Vector a -> [Vector a] -splitWith _ (SV _ _ 0) = [] -splitWith p ps = loop ps - where - loop = - uncurry (:) . - mapSnd (switchL [] (\ _ t -> loop t)) . - break p -{-# INLINE splitWith #-} - --- | /O(n)/ Break a 'Vector' into pieces separated by the --- argument, consuming the delimiter. I.e. --- --- > split '\n' "a\nb\nd\ne" == ["a","b","d","e"] --- > split 'a' "aXaXaXa" == ["","X","X","X"] --- > split 'x' "x" == ["",""] --- --- and --- --- > join [c] . split c == id --- > split == splitWith . (==) --- --- As for all splitting functions in this library, this function does --- not copy the substrings, it just constructs new 'Vector's that --- are slices of the original. --- -split :: (Storable a, Eq a) => a -> Vector a -> [Vector a] -split w v = splitWith (w==) v -{-# INLINE split #-} - --- | Like 'splitWith', except that sequences of adjacent separators are --- treated as a single separator. eg. --- --- > tokens (=='a') "aabbaca" == ["bb","c"] --- -tokens :: (Storable a) => (a -> Bool) -> Vector a -> [Vector a] -tokens f = P.filter (not.null) . splitWith f -{-# INLINE tokens #-} - --- | The 'group' function takes a 'Vector' and returns a list of --- 'Vector's such that the concatenation of the result is equal to the --- argument. Moreover, each sublist in the result contains only equal --- elements. For example, --- --- > group "Mississippi" = ["M","i","ss","i","ss","i","pp","i"] --- --- It is a special case of 'groupBy', which allows the programmer to --- supply their own equality test. It is about 40% faster than --- /groupBy (==)/ -group :: (Storable a, Eq a) => Vector a -> [Vector a] -group xs = - switchL [] - (\ h _ -> - let (ys, zs) = span (== h) xs - in ys : group zs) - xs - --- | The 'groupBy' function is the non-overloaded version of 'group'. -groupBy :: (Storable a) => (a -> a -> Bool) -> Vector a -> [Vector a] -groupBy k xs = - switchL [] - (\ h t -> - let n = 1 + findIndexOrEnd (not . k h) t - in unsafeTake n xs : groupBy k (unsafeDrop n xs)) - xs -{-# INLINE groupBy #-} - - --- | /O(n)/ The 'join' function takes a 'Vector' and a list of --- 'Vector's and concatenates the list after interspersing the first --- argument between each element of the list. -join :: (Storable a) => Vector a -> [Vector a] -> Vector a -join s = concat . List.intersperse s -{-# INLINE join #-} - --- --------------------------------------------------------------------- --- Indexing 'Vector's - --- | /O(1)/ 'Vector' index (subscript) operator, starting from 0. -index :: (Storable a) => Vector a -> Int -> a -index ps n - | n < 0 = moduleError "index" ("negative index: " ++ show n) - | n >= length ps = moduleError "index" ("index too large: " ++ show n - ++ ", length = " ++ show (length ps)) - | otherwise = ps `unsafeIndex` n -{-# INLINE index #-} - --- | /O(n)/ The 'elemIndex' function returns the index of the first --- element in the given 'Vector' which is equal to the query --- element, or 'Nothing' if there is no such element. -elemIndex :: (Storable a, Eq a) => a -> Vector a -> Maybe Int -elemIndex c = findIndex (c==) -{-# INLINE elemIndex #-} - --- | /O(n)/ The 'elemIndexEnd' function returns the last index of the --- element in the given 'Vector' which is equal to the query --- element, or 'Nothing' if there is no such element. The following --- holds: --- --- > elemIndexEnd c xs == --- > (-) (length xs - 1) `fmap` elemIndex c (reverse xs) --- -elemIndexEnd :: (Storable a, Eq a) => a -> Vector a -> Maybe Int -elemIndexEnd c = - fst . - foldl - (\(ri,i) x -> (if c==x then Just i else ri, succ i)) - (Nothing,0) -{-# INLINE elemIndexEnd #-} - --- | /O(n)/ The 'elemIndices' function extends 'elemIndex', by returning --- the indices of all elements equal to the query element, in ascending order. -elemIndices :: (Storable a, Eq a) => a -> Vector a -> [Int] -elemIndices c = findIndices (c==) -{-# INLINE elemIndices #-} - --- | count returns the number of times its argument appears in the 'Vector' --- --- > count = length . elemIndices --- --- But more efficiently than using length on the intermediate list. -count :: (Storable a, Eq a) => a -> Vector a -> Int -count w = - foldl (flip $ \c -> if c==w then succ else id) 0 -{- -count w sv = - List.length $ elemIndices w sv --} -{-# INLINE count #-} - --- | The 'findIndex' function takes a predicate and a 'Vector' and --- returns the index of the first element in the 'Vector' --- satisfying the predicate. -findIndex :: (Storable a) => (a -> Bool) -> Vector a -> Maybe Int -findIndex p xs = - {- The implementation is in principle the same as for findIndices, - but we use the First monoid, instead of the List/append monoid. - We could also implement findIndex in terms of monoidConcatMap. -} - foldr - (\x k n -> - toMaybe (p x) n `mplus` k (succ n)) - (const Nothing) xs 0 -{-# INLINE findIndex #-} - --- | The 'findIndices' function extends 'findIndex', by returning the --- indices of all elements satisfying the predicate, in ascending order. -findIndices :: (Storable a) => (a -> Bool) -> Vector a -> [Int] -findIndices p xs = - foldr - (\x k n -> - (if p x then (n:) else id) - (k (succ n))) - (const []) xs 0 -{-# INLINE findIndices #-} - --- | 'findIndexOrEnd' is a variant of findIndex, that returns the length --- of the string if no element is found, rather than Nothing. -findIndexOrEnd :: (Storable a) => (a -> Bool) -> Vector a -> Int -findIndexOrEnd p xs = - foldr - (\x k n -> - if p x then n else k (succ n)) - id xs 0 -{-# INLINE findIndexOrEnd #-} - --- --------------------------------------------------------------------- --- Searching Vectors - --- | /O(n)/ 'elem' is the 'Vector' membership predicate. -elem :: (Storable a, Eq a) => a -> Vector a -> Bool -elem c ps = isJust $ elemIndex c ps -{-# INLINE elem #-} - --- | /O(n)/ 'notElem' is the inverse of 'elem' -notElem :: (Storable a, Eq a) => a -> Vector a -> Bool -notElem c ps = not (elem c ps) -{-# INLINE notElem #-} - --- | /O(n)/ 'filter', applied to a predicate and a 'Vector', --- returns a 'Vector' containing those elements that satisfy the --- predicate. This function is subject to array fusion. -filter :: (Storable a) => (a -> Bool) -> Vector a -> Vector a -filter p (SV fp s l) = - let end = s+l - in fst $ - unfoldrN l - (let go = Strict.arguments1 $ \k0 -> - do guard (k0 find f p = case findIndex f p of Just n -> Just (p ! n) ; _ -> Nothing --- -find :: (Storable a) => (a -> Bool) -> Vector a -> Maybe a -find f p = fmap (unsafeIndex p) (findIndex f p) -{-# INLINE find #-} - --- --------------------------------------------------------------------- --- Searching for substrings - --- | /O(n)/ The 'isPrefixOf' function takes two 'Vector' and returns 'True' --- iff the first is a prefix of the second. -isPrefixOf :: (Storable a, Eq a) => Vector a -> Vector a -> Bool -isPrefixOf x@(SV _ _ l1) y@(SV _ _ l2) = - l1 <= l2 && x == unsafeTake l1 y - --- | /O(n)/ The 'isSuffixOf' function takes two 'Vector's and returns 'True' --- iff the first is a suffix of the second. --- --- The following holds: --- --- > isSuffixOf x y == reverse x `isPrefixOf` reverse y --- -isSuffixOf :: (Storable a, Eq a) => Vector a -> Vector a -> Bool -isSuffixOf x@(SV _ _ l1) y@(SV _ _ l2) = - l1 <= l2 && x == unsafeDrop (l2 - l1) y - --- --------------------------------------------------------------------- --- Zipping - --- | /O(n)/ 'zip' takes two 'Vector's and returns a list of --- corresponding pairs of elements. If one input 'Vector' is short, --- excess elements of the longer 'Vector' are discarded. This is --- equivalent to a pair of 'unpack' operations. -zip :: (Storable a, Storable b) => Vector a -> Vector b -> [(a, b)] -zip ps qs = - maybe [] id $ - do (ph,pt) <- viewL ps - (qh,qt) <- viewL qs - return ((ph,qh) : zip pt qt) - --- | 'zipWith' generalises 'zip' by zipping with the function given as --- the first argument, instead of a tupling function. For example, --- @'zipWith' (+)@ is applied to two 'Vector's to produce the list of --- corresponding sums. -zipWith :: (Storable a, Storable b, Storable c) => - (a -> b -> c) -> Vector a -> Vector b -> Vector c -zipWith f as bs = - unsafeWithStartPtr as $ \pa0 la -> - withStartPtr bs $ \pb0 lb -> - let len = min la lb - in create len $ \p0 -> - let go = Strict.arguments4 $ \n p pa pb -> - when (n>0) $ - liftM2 f (peek pa) (peek pb) >>= poke p >> - go (pred n) (incPtr p) (incPtr pa) (incPtr pb) - in go len p0 pa0 pb0 - - --- zipWith f ps qs = pack $ List.zipWith f (unpack ps) (unpack qs) -{-# INLINE zipWith #-} - --- | Like 'zipWith' but for three input vectors -zipWith3 :: (Storable a, Storable b, Storable c, Storable d) => - (a -> b -> c -> d) -> Vector a -> Vector b -> Vector c -> Vector d -zipWith3 f as bs cs = - unsafeWithStartPtr as $ \pa0 la -> - withStartPtr bs $ \pb0 lb -> - withStartPtr cs $ \pc0 lc -> - let len = la `min` lb `min` lc - in create len $ \p0 -> - let go = Strict.arguments5 $ \n p pa pb pc -> - when (n>0) $ - liftM3 f (peek pa) (peek pb) (peek pc) >>= poke p >> - go (pred n) (incPtr p) (incPtr pa) (incPtr pb) (incPtr pc) - in go len p0 pa0 pb0 pc0 -{-# INLINE zipWith3 #-} - --- | Like 'zipWith' but for four input vectors --- If you need even more input vectors, --- you might write a function yourselve using unfoldrN and viewL. -zipWith4 :: (Storable a, Storable b, Storable c, Storable d, Storable e) => - (a -> b -> c -> d -> e) -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e -zipWith4 f as bs cs ds = - unsafeWithStartPtr as $ \pa0 la -> - withStartPtr bs $ \pb0 lb -> - withStartPtr cs $ \pc0 lc -> - withStartPtr ds $ \pd0 ld -> - let len = la `min` lb `min` lc `min` ld - in create len $ \p0 -> - let go = - Strict.arguments2 $ \n p -> - Strict.arguments4 $ \pa pb pc pd -> - when (n>0) $ - liftM4 f (peek pa) (peek pb) (peek pc) (peek pd) >>= poke p >> - go (pred n) (incPtr p) (incPtr pa) (incPtr pb) (incPtr pc) (incPtr pd) - in go len p0 pa0 pb0 pc0 pd0 -{-# INLINE zipWith4 #-} - --- | /O(n)/ 'unzip' transforms a list of pairs of elements into a pair of --- 'Vector's. Note that this performs two 'pack' operations. -unzip :: (Storable a, Storable b) => [(a, b)] -> (Vector a, Vector b) -unzip ls = (pack (P.map fst ls), pack (P.map snd ls)) -{-# INLINE unzip #-} - --- --------------------------------------------------------------------- --- Interleaved 'Vector's - --- | /O(l/n)/ 'sieve' selects every 'n'th element. -sieve :: (Storable a) => Int -> Vector a -> Vector a -sieve n (SV fp s l) = - let end = s+l - in fst $ - unfoldrN (- div (-l) n) - (Strict.arguments1 $ \k0 -> - do guard (k0 Int -> Vector a -> [Vector a] -deinterleave n = - P.map (sieve n) . P.take n . P.iterate laxTail - --- | /O(n)/ --- Almost the inverse of deinterleave. --- Restriction is that all input vector must have equal length. --- @interleave [pack "adgj", pack "behk", pack "cfil"] = pack ['a'..'l']@ -interleave :: (Storable a) => [Vector a] -> Vector a -interleave vs = - Unsafe.performIO $ - MC.runContT - (do - pls <- mapM (\v -> MC.ContT (withStartPtr v . curry)) vs - let (ps,ls) = P.unzip pls - ptrs <- MC.ContT (withArray ps) - if and (ListHT.mapAdjacent (==) ls) - then return (ptrs, P.sum ls) - else moduleError "interleave" "all input vectors must have the same length") - (\(ptrs, totalLength) -> create totalLength $ \p -> - let n = P.length vs - pEnd = advancePtr p totalLength - go = Strict.arguments3 $ \k0 j p0 -> do - poke p0 =<< flip peekElemOff j =<< peekElemOff ptrs k0 - let p1 = advancePtr p0 1 - k1 = succ k0 - when (p1 < pEnd) $ - if k1 < n - then go k1 j p1 - else go 0 (succ j) p1 - in go 0 0 p) -{-# INLINE interleave #-} - - --- --------------------------------------------------------------------- --- Special lists - --- | /O(n)/ Return all initial segments of the given 'Vector', shortest first. -inits :: (Storable a) => Vector a -> [Vector a] -inits (SV x s l) = List.map (SV x s) [0..l] - --- | /O(n)/ Return all final segments of the given 'Vector', longest first. -tails :: (Storable a) => Vector a -> [Vector a] -tails p = - switchL [empty] (\ _ t -> p : tails t) p - --- --------------------------------------------------------------------- --- ** Ordered 'Vector's - --- --------------------------------------------------------------------- --- Low level constructors - --- | /O(n)/ Make a copy of the 'Vector' with its own storage. --- This is mainly useful to allow the rest of the data pointed --- to by the 'Vector' to be garbage collected, for example --- if a large string has been read in, and only a small part of it --- is needed in the rest of the program. -copy :: (Storable a) => Vector a -> Vector a -copy v = - unsafeWithStartPtr v $ \f l -> - create l $ \p -> - copyArray p f (fromIntegral l) - - - --- --------------------------------------------------------------------- --- IO - --- | Outputs a 'Vector' to the specified 'Handle'. -hPut :: (Storable a) => Handle -> Vector a -> IO () -hPut h v = - when (not (null v)) $ - withStartPtr v $ \ ptrS l -> - let ptrE = advancePtr ptrS l - -- use advancePtr and minusPtr in order to respect alignment - in hPutBuf h ptrS (minusPtr ptrE ptrS) - --- | Read a 'Vector' directly from the specified 'Handle'. This --- is far more efficient than reading the characters into a list --- and then using 'pack'. --- -hGet :: (Storable a) => Handle -> Int -> IO (Vector a) -hGet _ 0 = return empty -hGet h l = - createAndTrim l $ \p -> - let elemType :: Ptr a -> a - elemType _ = undefined - roundUp m n = n + mod (-n) m - sizeOfElem = - roundUp - (alignment (elemType p)) - (sizeOf (elemType p)) - in fmap (flip div sizeOfElem) $ - hGetBuf h p (l * sizeOfElem) -{- - createAndTrim l $ \p -> - fmap (flip div (incPtr p `minusPtr` p)) $ - hGetBuf h p (advancePtr p l `minusPtr` p) --} - --- | Read an entire file strictly into a 'Vector'. This is far more --- efficient than reading the characters into a 'String' and then using --- 'pack'. It also may be more efficient than opening the file and --- reading it using hGet. Files are read using 'binary mode' on Windows. --- -readFile :: (Storable a) => FilePath -> IO (Vector a) -readFile f = - bracket (openBinaryFile f ReadMode) hClose - (\h -> hGet h . fromIntegral =<< hFileSize h) - --- | Write a 'Vector' to a file. -writeFile :: (Storable a) => FilePath -> Vector a -> IO () -writeFile f txt = - bracket (openBinaryFile f WriteMode) hClose - (\h -> hPut h txt) - --- | Append a 'Vector' to a file. -appendFile :: (Storable a) => FilePath -> Vector a -> IO () -appendFile f txt = - bracket (openBinaryFile f AppendMode) hClose - (\h -> hPut h txt) - - --- --------------------------------------------------------------------- --- Internal utilities - - --- These definitions of succ and pred do not check for overflow --- and are faster than their counterparts from Enum class. -succ :: Int -> Int -succ n = n+1 -{-# INLINE succ #-} - -pred :: Int -> Int -pred n = n-1 -{-# INLINE pred #-} - -unsafeWithStartPtr :: Storable a => Vector a -> (Ptr a -> Int -> IO b) -> b -unsafeWithStartPtr v f = - Unsafe.performIO (withStartPtr v f) -{-# INLINE unsafeWithStartPtr #-} - -foreignPeek :: Storable a => ForeignPtr a -> Int -> a -foreignPeek fp k = - inlinePerformIO $ withForeignPtr fp $ flip peekElemOff k -{-# INLINE foreignPeek #-} - -withNonEmptyVector :: - String -> (ForeignPtr a -> Int -> Int -> b) -> Vector a -> b -withNonEmptyVector fun f (SV x s l) = - if l <= 0 - then errorEmpty fun - else f x s l -{-# INLINE withNonEmptyVector #-} - --- Common up near identical calls to `error' to reduce the number --- constant strings created when compiled: -errorEmpty :: String -> a -errorEmpty fun = moduleError fun "empty Vector" -{-# NOINLINE errorEmpty #-} - -moduleError :: String -> String -> a -moduleError fun msg = error ("Data.StorableVector." ++ fun ++ ':':' ':msg) -{-# NOINLINE moduleError #-} - --- Find from the end of the string using predicate -findFromEndUntil :: (Storable a) => (a -> Bool) -> Vector a -> Int -findFromEndUntil = Strict.arguments2 $ \f ps@(SV x s l) -> - if null ps then 0 - else if f (last ps) then l - else findFromEndUntil f (SV x s (l-1)) diff --git a/Data/StorableVector/Base.hs b/Data/StorableVector/Base.hs deleted file mode 100644 --- a/Data/StorableVector/Base.hs +++ /dev/null @@ -1,225 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE DeriveDataTypeable #-} --- --- Module : Data.StorableVector.Base --- License : BSD-style --- Maintainer : dons@cse.unsw.edu.au --- Stability : experimental --- Portability : portable, requires ffi and cpp --- Tested with : GHC 6.4.1 and Hugs March 2005 --- - --- | A module containing semi-public StorableVector internals. This exposes --- the StorableVector representation and low level construction functions. --- Modules which extend the StorableVector system will need to use this module --- while ideally most users will be able to make do with the public interface --- modules. --- -module Data.StorableVector.Base ( - - -- * The @Vector@ type and representation - Vector(..), -- instances: Eq, Ord, Show, Read, Data, Typeable - - -- * Unchecked access - unsafeHead, -- :: Vector a -> a - unsafeTail, -- :: Vector a -> Vector a - unsafeLast, -- :: Vector a -> a - unsafeInit, -- :: Vector a -> Vector a - unsafeIndex, -- :: Vector a -> Int -> a - unsafeTake, -- :: Int -> Vector a -> Vector a - unsafeDrop, -- :: Int -> Vector a -> Vector a - - -- * Low level introduction and elimination - create, -- :: Int -> (Ptr a -> IO ()) -> IO (Vector a) - createAndTrim, -- :: Int -> (Ptr a -> IO Int) -> IO (Vector a) - createAndTrim', -- :: Int -> (Ptr a -> IO (Int, Int, b)) -> IO (Vector a, b) - - unsafeCreate, -- :: Int -> (Ptr a -> IO ()) -> Vector a - - fromForeignPtr, -- :: ForeignPtr a -> Int -> Vector a - toForeignPtr, -- :: Vector a -> (ForeignPtr a, Int, Int) - withStartPtr, -- :: Vector a -> (Ptr a -> Int -> IO b) -> IO b - incPtr, -- :: Ptr a -> Ptr a - - inlinePerformIO - - ) where - -import Foreign.Ptr (Ptr) -import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, ) -import Foreign.Marshal.Array (advancePtr, copyArray) -import Foreign.Storable (Storable(peekElemOff)) - -import Data.StorableVector.Memory (mallocForeignPtrArray, ) - -import Control.Exception (assert) - -#if defined(__GLASGOW_HASKELL__) -import Data.Generics (Data(..), Typeable(..)) -import GHC.Base (realWorld#) -import GHC.IO (IO(IO), ) -#endif - -import qualified System.Unsafe as Unsafe - --- CFILES stuff is Hugs only -{-# CFILES cbits/fpstring.c #-} - --- ----------------------------------------------------------------------------- - --- | A space-efficient representation of a vector, supporting many efficient --- operations. --- --- Instances of Eq, Ord, Read, Show, Data, Typeable --- -data Vector a = SV {-# UNPACK #-} !(ForeignPtr a) - {-# UNPACK #-} !Int -- offset - {-# UNPACK #-} !Int -- length -#if defined(__GLASGOW_HASKELL__) - deriving (Data, Typeable) -#endif - --- --------------------------------------------------------------------- --- --- Extensions to the basic interface --- - --- | A variety of 'head' for non-empty Vectors. 'unsafeHead' omits the --- check for the empty case, so there is an obligation on the programmer --- to provide a proof that the Vector is non-empty. -unsafeHead :: (Storable a) => Vector a -> a -unsafeHead (SV x s l) = assert (l > 0) $ - inlinePerformIO $ withForeignPtr x $ \p -> peekElemOff p s -{-# INLINE unsafeHead #-} - --- | A variety of 'tail' for non-empty Vectors. 'unsafeTail' omits the --- check for the empty case. As with 'unsafeHead', the programmer must --- provide a separate proof that the Vector is non-empty. -unsafeTail :: (Storable a) => Vector a -> Vector a -unsafeTail (SV ps s l) = assert (l > 0) $ SV ps (s+1) (l-1) -{-# INLINE unsafeTail #-} - --- | A variety of 'last' for non-empty Vectors. 'unsafeLast' omits the --- check for the empty case, so there is an obligation on the programmer --- to provide a proof that the Vector is non-empty. -unsafeLast :: (Storable a) => Vector a -> a -unsafeLast (SV x s l) = assert (l > 0) $ - inlinePerformIO $ withForeignPtr x $ \p -> peekElemOff p (s+l-1) -{-# INLINE unsafeLast #-} - --- | A variety of 'init' for non-empty Vectors. 'unsafeInit' omits the --- check for the empty case. As with 'unsafeLast', the programmer must --- provide a separate proof that the Vector is non-empty. -unsafeInit :: (Storable a) => Vector a -> Vector a -unsafeInit (SV ps s l) = assert (l > 0) $ SV ps s (l-1) -{-# INLINE unsafeInit #-} - --- | Unsafe 'Vector' index (subscript) operator, starting from 0, returning a --- single element. This omits the bounds check, which means there is an --- accompanying obligation on the programmer to ensure the bounds are checked in --- some other way. -unsafeIndex :: (Storable a) => Vector a -> Int -> a -unsafeIndex (SV x s l) i = assert (i >= 0 && i < l) $ - inlinePerformIO $ withForeignPtr x $ \p -> peekElemOff p (s+i) -{-# INLINE unsafeIndex #-} - --- | A variety of 'take' which omits the checks on @n@ so there is an --- obligation on the programmer to provide a proof that @0 <= n <= 'length' xs@. -unsafeTake :: (Storable a) => Int -> Vector a -> Vector a -unsafeTake n (SV x s l) = assert (0 <= n && n <= l) $ SV x s n -{-# INLINE unsafeTake #-} - --- | A variety of 'drop' which omits the checks on @n@ so there is an --- obligation on the programmer to provide a proof that @0 <= n <= 'length' xs@. -unsafeDrop :: (Storable a) => Int -> Vector a -> Vector a -unsafeDrop n (SV x s l) = assert (0 <= n && n <= l) $ SV x (s+n) (l-n) -{-# INLINE unsafeDrop #-} - - -instance (Storable a, Show a) => Show (Vector a) where - showsPrec p xs@(SV _ _ l) = - showParen (p>=10) - (showString "Vector.pack " . - showsPrec 10 (map (unsafeIndex xs) [0..(l-1)])) - - --- --------------------------------------------------------------------- --- Low level constructors - --- | /O(1)/ Build a Vector from a ForeignPtr -fromForeignPtr :: ForeignPtr a -> Int -> Vector a -fromForeignPtr fp l = SV fp 0 l - --- | /O(1)/ Deconstruct a ForeignPtr from a Vector -toForeignPtr :: Vector a -> (ForeignPtr a, Int, Int) -toForeignPtr (SV ps s l) = (ps, s, l) - --- | Run an action that is initialized --- with a pointer to the first element to be used. -withStartPtr :: Storable a => Vector a -> (Ptr a -> Int -> IO b) -> IO b -withStartPtr (SV x s l) f = - withForeignPtr x $ \p -> f (p `advancePtr` s) l -{-# INLINE withStartPtr #-} - -incPtr :: (Storable a) => Ptr a -> Ptr a -incPtr v = advancePtr v 1 -{-# INLINE incPtr #-} - --- | A way of creating Vectors outside the IO monad. The @Int@ --- argument gives the final size of the Vector. Unlike --- 'createAndTrim' the Vector is not reallocated if the final size --- is less than the estimated size. -unsafeCreate :: (Storable a) => Int -> (Ptr a -> IO ()) -> Vector a -unsafeCreate l f = Unsafe.performIO (create l f) -{-# INLINE unsafeCreate #-} - --- | Wrapper of mallocForeignPtrArray. -create :: (Storable a) => Int -> (Ptr a -> IO ()) -> IO (Vector a) -create l f = do - fp <- mallocForeignPtrArray l - withForeignPtr fp $ \p -> f p - return $! SV fp 0 l - --- | Given the maximum size needed and a function to make the contents --- of a Vector, createAndTrim makes the 'Vector'. The generating --- function is required to return the actual final size (<= the maximum --- size), and the resulting byte array is realloced to this size. --- --- createAndTrim is the main mechanism for creating custom, efficient --- Vector functions, using Haskell or C functions to fill the space. --- -createAndTrim :: (Storable a) => Int -> (Ptr a -> IO Int) -> IO (Vector a) -createAndTrim l f = do - fp <- mallocForeignPtrArray l - withForeignPtr fp $ \p -> do - l' <- f p - if assert (l' <= l) $ l' >= l - then return $! SV fp 0 l - else create l' $ \p' -> copyArray p' p l' - -createAndTrim' :: (Storable a) => Int - -> (Ptr a -> IO (Int, Int, b)) - -> IO (Vector a, b) -createAndTrim' l f = do - fp <- mallocForeignPtrArray l - withForeignPtr fp $ \p -> do - (off, l', res) <- f p - if assert (l' <= l) $ l' >= l - then return $! (SV fp 0 l, res) - else do ps <- create l' $ \p' -> copyArray p' (p `advancePtr` off) l' - return $! (ps, res) - --- | Just like Unsafe.performIO, but we inline it. Big performance gains as --- it exposes lots of things to further inlining. /Very unsafe/. In --- particular, you should do no memory allocation inside an --- 'inlinePerformIO' block. On Hugs this is just @Unsafe.performIO@. --- -{-# INLINE inlinePerformIO #-} -inlinePerformIO :: IO a -> a -#if defined(__GLASGOW_HASKELL__) -inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r -#else -inlinePerformIO = Unsafe.performIO -#endif diff --git a/Data/StorableVector/Cursor.hs b/Data/StorableVector/Cursor.hs deleted file mode 100644 --- a/Data/StorableVector/Cursor.hs +++ /dev/null @@ -1,353 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{- | -Simulate a list with strict elements by a more efficient array structure. --} -module Data.StorableVector.Cursor where - -import Control.Exception (assert, ) -import Control.Monad.Trans.State (StateT(StateT), runStateT, ) -import Data.IORef (IORef, newIORef, readIORef, writeIORef, ) - -import Foreign.Storable (Storable(peekElemOff, pokeElemOff)) -import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, ) --- import Foreign.Ptr (Ptr) -import Data.StorableVector.Memory (mallocForeignPtrArray, ) - -import Control.Monad (when) -import Data.Maybe (isNothing) - -import qualified System.Unsafe as Unsafe - -import qualified Data.List.HT as ListHT -import Data.Tuple.HT (mapSnd, ) - -import Prelude hiding (length, foldr, zipWith, take, drop, ) - - -{- -ToDo: -I think that the state should be Storable as well -and that the IORef should be replaced by a ForeignPtr. -I hope that this is more efficient. -With this restriction @s@ cannot be e.g. a function type -but this would kill performance anyway. -Functions that need this flexibility may fall back to other data structures -(lists or chunky StorableVectors) and convert to the Cursor structure later. --} --- | Cf. StreamFusion Data.Stream -data Generator a = - forall s. -- Seq s => - Generator - !(StateT s Maybe a) -- compute next value - {-# UNPACK #-} - !(IORef (Maybe s)) -- current state - -{- | -This simulates a -@ data StrictList a = Elem !a (StrictList a) | End @ -by an array and some unsafe hacks. --} -data Buffer a = - Buffer { - memory :: {-# UNPACK #-} !(ForeignPtr a), - size :: {-# UNPACK #-} !Int, -- size of allocated memory, I think I only need it for debugging - gen :: !(Generator a), -- we need this indirection for the existential type in Generator - cursor :: {-# UNPACK #-} !(IORef Int) - } - -{- | -Vector is a part of a buffer. --} -data Vector a = - Vector { - buffer :: {-# UNPACK #-} !(Buffer a), - start :: {-# UNPACK #-} !Int, -- invariant: start <= cursor - maxLen :: {-# UNPACK #-} !Int -- invariant: start+maxLen <= size buffer - } - - --- * construction - -{-# INLINE create #-} -create :: (Storable a) => Int -> Generator a -> Buffer a -create l g = Unsafe.performIO (createIO l g) - --- | Wrapper of mallocForeignPtrArray. -createIO :: (Storable a) => Int -> Generator a -> IO (Buffer a) -createIO l g = do - fp <- mallocForeignPtrArray l - cur <- newIORef 0 - return $! Buffer fp l g cur - - -{- | -@ unfoldrNTerm 20 (\n -> Just (n, succ n)) 'a' @ --} -unfoldrNTerm :: (Storable b) => - Int -> (a -> Maybe (b, a)) -> a -> Vector b -unfoldrNTerm l f x0 = - Unsafe.performIO (unfoldrNTermIO l f x0) - -unfoldrNTermIO :: (Storable b) => - Int -> (a -> Maybe (b, a)) -> a -> IO (Vector b) -unfoldrNTermIO l f x0 = - do ref <- newIORef (Just x0) - buf <- createIO l (Generator (StateT f) ref) - return (Vector buf 0 l) - -unfoldrN :: (Storable b) => - Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a) -unfoldrN l f x0 = - Unsafe.performIO (unfoldrNIO l f x0) - -unfoldrNIO :: (Storable b) => - Int -> (a -> Maybe (b, a)) -> a -> IO (Vector b, Maybe a) -unfoldrNIO l f x0 = - do ref <- newIORef (Just x0) - buf <- createIO l (Generator (StateT f) ref) - s <- Unsafe.interleaveIO $ - do evaluateToIO l buf - readIORef ref - return (Vector buf 0 l, s) -{- -unfoldrNIO :: (Storable b) => - Int -> (a -> Maybe (b, a)) -> a -> IO (Vector b, Maybe a) -unfoldrNIO l f x0 = - do y <- unfoldrNTermIO l f x0 --- evaluateTo l y - let (Generator _ ref) = gen (buffer y) - s <- readIORef ref - return (y, s) - -Data/StorableVector/Cursor.hs:98:10: - My brain just exploded. - I can't handle pattern bindings for existentially-quantified constructors. - In the binding group - (Generator _ ref) = gen (buffer y) - In the definition of `unfoldrNIO': - unfoldrNIO l f x0 - = do - y <- unfoldrNTermIO l f x0 - let (Generator _ ref) = gen (buffer y) - s <- readIORef ref - return (y, s) --} - - -{- -unfoldrN :: (Storable b) => - Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a) -unfoldrN i f x0 = - let y = unfoldrNTerm i f x0 - in (y, getFinalState y) - -getFinalState :: (Storable b) => - Vector b -> Maybe a -getFinalState y = - Unsafe.performIO $ - ... --} - - -{-# INLINE pack #-} -pack :: (Storable a) => Int -> [a] -> Vector a -pack n = unfoldrNTerm n ListHT.viewL - - -{-# INLINE cons #-} -{- | -This is expensive and should not be used to construct lists iteratively! -A recursion-enabling 'cons' would be 'consN' -that allocates a buffer of given size, -initializes the leading cell and sets the buffer pointer to the next cell. --} -cons :: Storable a => - a -> Vector a -> Vector a -cons x xs = - unfoldrNTerm (succ (maxLen xs)) - (\(mx0,xs0) -> - fmap (mapSnd ((,) Nothing)) $ - maybe - (viewL xs0) - (\x0 -> Just (x0, xs0)) - mx0) $ - (Just x, xs) - - -{-# INLINE zipWith #-} -zipWith :: (Storable a, Storable b, Storable c) => - (a -> b -> c) -> Vector a -> Vector b -> Vector c -zipWith f ps0 qs0 = - zipNWith (min (maxLen ps0) (maxLen qs0)) f ps0 qs0 - --- zipWith f ps qs = pack $ List.zipWith f (unpack ps) (unpack qs) - -{-# INLINE zipNWith #-} -zipNWith :: (Storable a, Storable b, Storable c) => - Int -> (a -> b -> c) -> Vector a -> Vector b -> Vector c -zipNWith n f ps0 qs0 = - unfoldrNTerm n - (\(ps,qs) -> - do (ph,pt) <- viewL ps - (qh,qt) <- viewL qs - return (f ph qh, (pt,qt))) - (ps0,qs0) -{- -let f2 = zipNWith 15 (+) f0 f1; f1 = cons 1 f2; f0 = cons (0::Int) f1 in f0 - -*Data.StorableVector.Cursor> let xs = unfoldrNTerm 20 (\n -> Just (n, succ n)) (0::Int) -*Data.StorableVector.Cursor> let ys = unfoldrNTerm 20 (\n -> Just (n, 2*n)) (1::Int) -*Data.StorableVector.Cursor> zipWith (+) xs ys --} - - - - --- * inspection - --- | evaluate next value in a buffer -advanceIO :: Storable a => - Buffer a -> IO (Maybe a) -advanceIO (Buffer p sz (Generator n s) cr) = - do c <- readIORef cr - assert (c < sz) $ - do writeIORef cr (succ c) - ms <- readIORef s - case ms of - Nothing -> return Nothing - Just s0 -> - case runStateT n s0 of - Nothing -> - writeIORef s Nothing >> - return Nothing - Just (a,s1) -> - writeIORef s (Just s1) >> - withForeignPtr p (\q -> pokeElemOff q c a) >> - return (Just a) - -{- -It is tempting to turn this into a simple loop without the IORefs. -This could be compiled to an efficient strict loop, -but it would fail if the vector content depends on its own, -like in @fix (consN 1000 'a')@. --} --- | evaluate all values up to a given position -evaluateToIO :: Storable a => - Int -> Buffer a -> IO () -evaluateToIO l buf@(Buffer _p _sz _g cr) = - whileM - (fmap ( m Bool -> m a -> m () -whileM p f = - let recourse = - do b <- p - when b (f >> recourse) - in recourse - -{-# INLINE switchL #-} -switchL :: Storable a => b -> (a -> Vector a -> b) -> Vector a -> b -switchL n j v = maybe n (uncurry j) (viewL v) - - -{- -If it returns False the list can be empty anyway. --} -obviousNullIO :: Vector a -> IO Bool -obviousNullIO (Vector (Buffer _ _ (Generator _ s) _) _ ml) = - assert (ml >= 0) $ - do b <- readIORef s - return (ml == 0 || isNothing b) - -{- -obviousNullIO :: Vector a -> IO Bool -obviousNullIO (Vector (Buffer _ sz (Generator _ s) _) st _) = - do b <- readIORef s - return (st >= sz || isNothing b) --} --- assert (l >= 0) $ l <= 0 - -{-# INLINE viewL #-} -viewL :: Storable a => Vector a -> Maybe (a, Vector a) -viewL v = Unsafe.performIO (viewLIO v) - -{-# INLINE viewLIO #-} -viewLIO :: Storable a => Vector a -> IO (Maybe (a, Vector a)) -viewLIO (Vector buf st ml) = - do c <- readIORef (cursor buf) - fmap (fmap (\a -> (a, Vector buf (succ st) (pred ml)))) $ - assert (st <= c) $ - if st == c - then advanceIO buf - else fmap Just $ withForeignPtr (memory buf) (\p -> peekElemOff p st) - - -{-# INLINE foldr #-} -foldr :: (Storable a) => (a -> b -> b) -> b -> Vector a -> b -foldr k z = - let recourse = switchL z (\h t -> k h (recourse t)) - in recourse - --- | /O(n)/ Converts a 'Vector a' to a '[a]'. -{-# INLINE unpack #-} -unpack :: (Storable a) => Vector a -> [a] -unpack = foldr (:) [] - - -instance (Show a, Storable a) => Show (Vector a) where - showsPrec p x = showsPrec p (unpack x) - - -{-# INLINE null #-} -{- -This can hardly be simplified. -In order to check the list for emptiness, -we have to try to calculate the next element. -It is not enough to check whether the state is Nothing, -because when we try to compute the next value, this can be Nothing. --} -null :: Storable a => Vector a -> Bool -null = switchL True (const (const False)) - - -{- -toVector :: Storable a => Vector a -> VS.Vector a -toVector v = - VS.Cons (memory (buffer v)) () --} - --- length - -drop :: (Storable a) => Int -> Vector a -> Vector a -drop n v = Unsafe.performIO $ dropIO n v - -dropIO :: (Storable a) => Int -> Vector a -> IO (Vector a) -dropIO n v = - assert (n>=0) $ - let pos = min (maxLen v) (start v + n) - in do evaluateToIO pos (buffer v) - return (Vector (buffer v) pos (max 0 (maxLen v - n))) - -take :: (Storable a) => Int -> Vector a -> Vector a -take n v = - assert (n>=0) $ - v{maxLen = min n (maxLen v)} - -{- -let x = unfoldrNTerm 10 (\c -> Just (c,succ c)) 'a' -let x = unfoldrNTerm 10 (\c -> Just (sum [c..100000],succ c)) (0::Int) --} - - -{- | -For the sake of laziness it may allocate considerably more memory than needed, -if it filters out very much. --} -{-# INLINE filter #-} -filter :: (Storable a) => (a -> Bool) -> Vector a -> Vector a -filter p xs0 = - unfoldrNTerm (maxLen xs0) - (let recourse = switchL Nothing (\x xs -> if p x then Just (x,xs) else recourse xs) - in recourse) - xs0 diff --git a/Data/StorableVector/Lazy.hs b/Data/StorableVector/Lazy.hs deleted file mode 100644 --- a/Data/StorableVector/Lazy.hs +++ /dev/null @@ -1,1359 +0,0 @@ -{- | -Chunky signal stream build on StorableVector. - -Hints for fusion: - - Higher order functions should always be inlined in the end - in order to turn them into machine loops - instead of calling a function in an inner loop. --} -module Data.StorableVector.Lazy where - -import qualified Data.List as List -import qualified Data.StorableVector as V -import qualified Data.StorableVector.Base as VB -import qualified Data.StorableVector.Lazy.PointerPrivate as Ptr - -import qualified Numeric.NonNegative.Class as NonNeg - -import qualified Data.List.HT as ListHT -import Data.Tuple.HT (mapPair, mapFst, mapSnd, swap, ) -import Data.Maybe.HT (toMaybe, ) -import Data.Maybe (fromMaybe, ) - -import Foreign.Storable (Storable) - -import Data.Monoid (Monoid, mempty, mappend, mconcat, ) --- import Control.Arrow ((***)) -import Control.Monad (liftM, liftM2, liftM3, liftM4, {- guard, -} ) - - -import System.IO (openBinaryFile, IOMode(WriteMode, ReadMode, AppendMode), - hClose, Handle) -import Control.Exception (bracket, catch, ) - -import qualified System.IO.Error as Exc -import qualified System.Unsafe as Unsafe - -import Test.QuickCheck (Arbitrary(..)) - - -{- -import Prelude hiding - (length, (++), concat, iterate, foldl, map, repeat, replicate, null, - zip, zipWith, zipWith3, drop, take, splitAt, takeWhile, dropWhile, reverse) --} - -import qualified Prelude as P - -import Data.Either (Either(Left, Right), either, ) -import Data.Maybe (Maybe(Just, Nothing), maybe, ) -import Data.Function (const, flip, ($), (.), ) -import Data.Tuple (fst, snd, uncurry, ) -import Data.Bool (Bool(True,False), not, (&&), ) -import Data.Ord (Ord, (<), (>), (<=), (>=), min, max, ) -import Data.Eq (Eq, (==), ) -import Control.Monad (mapM_, fmap, (=<<), (>>=), (>>), return, ) -import Text.Show (Show, showsPrec, showParen, showString, show, ) -import Prelude - (IO, error, IOError, - FilePath, String, Char, - Enum, succ, pred, - Num, Int, sum, (+), (-), divMod, mod, fromInteger, ) - - - -newtype Vector a = SV {chunks :: [V.Vector a]} - - -instance (Storable a) => Monoid (Vector a) where - mempty = empty - mappend = append - mconcat = concat - -instance (Storable a, Eq a) => Eq (Vector a) where - (==) = equal - -instance (Storable a, Show a) => Show (Vector a) where - showsPrec p xs = - showParen (p>=10) - (showString "VectorLazy.fromChunks " . - showsPrec 10 (chunks xs)) - -instance (Storable a, Arbitrary a) => Arbitrary (Vector a) where - arbitrary = liftM2 pack arbitrary arbitrary - - --- for a list of chunk sizes see "Data.StorableVector.LazySize". -newtype ChunkSize = ChunkSize Int - deriving (Eq, Ord, Show) - -instance Arbitrary ChunkSize where - arbitrary = fmap (ChunkSize . max 1 . min 2048) arbitrary - -{- -ToDo: -Since non-negative-0.1 we have the Monoid superclass for NonNeg. -Maybe we do not need the Num instance anymore. --} -instance Num ChunkSize where - (ChunkSize x) + (ChunkSize y) = - ChunkSize (x+y) - (-) = moduleError "ChunkSize.-" "intentionally unimplemented" - (*) = moduleError "ChunkSize.*" "intentionally unimplemented" - abs = moduleError "ChunkSize.abs" "intentionally unimplemented" - signum = moduleError "ChunkSize.signum" "intentionally unimplemented" - fromInteger = ChunkSize . fromInteger - -instance Monoid ChunkSize where - mempty = ChunkSize 0 - mappend (ChunkSize x) (ChunkSize y) = ChunkSize (x+y) - mconcat = ChunkSize . sum . List.map (\(ChunkSize c) -> c) - -instance NonNeg.C ChunkSize where - split = NonNeg.splitDefault (\(ChunkSize c) -> c) ChunkSize - -chunkSize :: Int -> ChunkSize -chunkSize x = - ChunkSize $ - if x>0 - then x - else moduleError "chunkSize" ("no positive number: " List.++ show x) - -defaultChunkSize :: ChunkSize -defaultChunkSize = - ChunkSize 1024 - - - --- * Introducing and eliminating 'Vector's - -{-# INLINE empty #-} -empty :: (Storable a) => Vector a -empty = SV [] - -{-# INLINE singleton #-} -singleton :: (Storable a) => a -> Vector a -singleton x = SV [V.singleton x] - -fromChunks :: (Storable a) => [V.Vector a] -> Vector a -fromChunks = SV - -pack :: (Storable a) => ChunkSize -> [a] -> Vector a -pack size = unfoldr size ListHT.viewL - -unpack :: (Storable a) => Vector a -> [a] -unpack = List.concatMap V.unpack . chunks - - -{-# INLINE packWith #-} -packWith :: (Storable b) => ChunkSize -> (a -> b) -> [a] -> Vector b -packWith size f = - unfoldr size (fmap (mapFst f) . ListHT.viewL) - -{-# INLINE unpackWith #-} -unpackWith :: (Storable a) => (a -> b) -> Vector a -> [b] -unpackWith f = List.concatMap (V.unpackWith f) . chunks - - -{-# INLINE unfoldr #-} -unfoldr :: (Storable b) => - ChunkSize -> - (a -> Maybe (b,a)) -> - a -> - Vector b -unfoldr (ChunkSize size) f = - SV . - List.unfoldr (cancelNullVector . V.unfoldrN size f =<<) . - Just - -{- | -Example: - -> *Data.StorableVector.Lazy> unfoldrResult (ChunkSize 5) (\c -> if c>'z' then Left (Char.ord c) else Right (c, succ c)) 'a' -> (VectorLazy.fromChunks [Vector.pack "abcde",Vector.pack "fghij",Vector.pack "klmno",Vector.pack "pqrst",Vector.pack "uvwxy",Vector.pack "z"],123) --} -{-# INLINE unfoldrResult #-} -unfoldrResult :: (Storable b) => - ChunkSize -> - (a -> Either c (b, a)) -> - a -> - (Vector b, c) -unfoldrResult (ChunkSize size) f = - let recourse a0 = - let (chunk, a1) = - V.unfoldrResultN size Right (either (Left . Left) Right . f) a0 - in either - ((,) (if V.null chunk then [] else [chunk])) - (mapFst (chunk :) . recourse) a1 - in mapFst SV . recourse - - -{-# INLINE sample #-} -sample :: (Storable a) => ChunkSize -> (Int -> a) -> Vector a -sample size f = - unfoldr size (\i -> Just (f i, succ i)) 0 - -{-# INLINE sampleN #-} -sampleN :: (Storable a) => ChunkSize -> Int -> (Int -> a) -> Vector a -sampleN size n f = - unfoldr size (\i -> toMaybe (i ChunkSize -> (a -> a) -> a -> Vector a -iterate size f = unfoldr size (\x -> Just (x, f x)) - -repeat :: Storable a => ChunkSize -> a -> Vector a -repeat (ChunkSize size) = - SV . List.repeat . V.replicate size - -cycle :: Storable a => Vector a -> Vector a -cycle = - SV . List.cycle . chunks - -replicate :: Storable a => ChunkSize -> Int -> a -> Vector a -replicate (ChunkSize size) n x = - let (numChunks, rest) = divMod n size - in append - (SV (List.replicate numChunks (V.replicate size x))) - (fromChunk (V.replicate rest x)) - - - - --- * Basic interface - -{-# INLINE null #-} -null :: (Storable a) => Vector a -> Bool -null = List.null . chunks - -length :: Vector a -> Int -length = sum . List.map V.length . chunks - -equal :: (Storable a, Eq a) => Vector a -> Vector a -> Bool -equal (SV xs0) (SV ys0) = - let recourse (x:xs) (y:ys) = - let l = min (V.length x) (V.length y) - (xPrefix, xSuffix) = V.splitAt l x - (yPrefix, ySuffix) = V.splitAt l y - build z zs = - if V.null z then zs else z:zs - in xPrefix == yPrefix && - recourse (build xSuffix xs) (build ySuffix ys) - recourse [] [] = True - -- this requires that chunks will always be non-empty - recourse _ _ = False - in recourse xs0 ys0 - -index :: (Storable a) => Vector a -> Int -> a -index (SV xs) n = - if n < 0 - then - moduleError "index" - ("negative index: " List.++ show n) - else - List.foldr - (\x k m0 -> - let m1 = m0 - V.length x - in if m1 < 0 - then VB.unsafeIndex x m0 - else k m1) - (\m -> moduleError "index" - ("index too large: " List.++ show n - List.++ ", length = " List.++ show (n-m))) - xs n - - -{-# NOINLINE [0] cons #-} -cons :: Storable a => a -> Vector a -> Vector a -cons x = SV . (V.singleton x :) . chunks - -infixr 5 `append` - -{-# NOINLINE [0] append #-} -append :: Storable a => Vector a -> Vector a -> Vector a -append (SV xs) (SV ys) = SV (xs List.++ ys) - - -{- | -@extendL size x y@ -prepends the chunk @x@ and merges it with the first chunk of @y@ -if the total size is at most @size@. -This way you can prepend small chunks -while asserting a reasonable average size for chunks. --} -extendL :: Storable a => ChunkSize -> V.Vector a -> Vector a -> Vector a -extendL (ChunkSize size) x (SV yt) = - SV $ - maybe - [x] - (\(y,ys) -> - if V.length x + V.length y <= size - then V.append x y : ys - else x:yt) - (ListHT.viewL yt) - - -concat :: (Storable a) => [Vector a] -> Vector a -concat = SV . List.concat . List.map chunks - - --- * Transformations - -{-# INLINE map #-} -map :: (Storable x, Storable y) => - (x -> y) - -> Vector x - -> Vector y -map f = SV . List.map (V.map f) . chunks - - -reverse :: Storable a => Vector a -> Vector a -reverse = - SV . List.reverse . List.map V.reverse . chunks - - --- * Reducing 'Vector's - -{-# INLINE foldl #-} -foldl :: Storable b => (a -> b -> a) -> a -> Vector b -> a -foldl f x0 = List.foldl (V.foldl f) x0 . chunks - -{-# INLINE foldl' #-} -foldl' :: Storable b => (a -> b -> a) -> a -> Vector b -> a -foldl' f x0 = List.foldl' (V.foldl f) x0 . chunks - -{-# INLINE foldr #-} -foldr :: Storable b => (b -> a -> a) -> a -> Vector b -> a -foldr f x0 = List.foldr (flip (V.foldr f)) x0 . chunks - - -{-# INLINE monoidConcatMap #-} -monoidConcatMap :: (Storable a, Monoid m) => (a -> m) -> Vector a -> m -monoidConcatMap f = - List.foldr (mappend . V.monoidConcatMap f) mempty . chunks - -{-# INLINE any #-} -any :: (Storable a) => (a -> Bool) -> Vector a -> Bool -any p = List.any (V.any p) . chunks - -{-# INLINE all #-} -all :: (Storable a) => (a -> Bool) -> Vector a -> Bool -all p = List.all (V.all p) . chunks - -maximum :: (Storable a, Ord a) => Vector a -> a -maximum = - List.maximum . List.map V.maximum . chunks --- List.foldl1' max . List.map V.maximum . chunks - -minimum :: (Storable a, Ord a) => Vector a -> a -minimum = - List.minimum . List.map V.minimum . chunks --- List.foldl1' min . List.map V.minimum . chunks - -{- -sum :: (Storable a, Num a) => Vector a -> a -sum = - List.sum . List.map V.sum . chunks - -product :: (Storable a, Num a) => Vector a -> a -product = - List.product . List.map V.product . chunks --} - - --- * inspecting a vector - -{-# INLINE pointer #-} -pointer :: Storable a => Vector a -> Ptr.Pointer a -pointer = Ptr.cons . chunks - -{-# INLINE viewL #-} -viewL :: Storable a => Vector a -> Maybe (a, Vector a) -viewL (SV xs0) = - do (x,xs) <- ListHT.viewL xs0 - (y,ys) <- V.viewL x - return (y, append (fromChunk ys) (SV xs)) - -{-# INLINE viewR #-} -viewR :: Storable a => Vector a -> Maybe (Vector a, a) -viewR (SV xs0) = - do xsp <- ListHT.viewR xs0 - let (xs,x) = xsp -{- - do ~(xs,x) <- ListHT.viewR xs0 --} - let (ys,y) = fromMaybe (moduleError "viewR" "last chunk empty") (V.viewR x) - return (append (SV xs) (fromChunk ys), y) - -{-# INLINE switchL #-} -switchL :: Storable a => b -> (a -> Vector a -> b) -> Vector a -> b -switchL n j = - maybe n (uncurry j) . viewL - -{-# INLINE switchR #-} -switchR :: Storable a => b -> (Vector a -> a -> b) -> Vector a -> b -switchR n j = - maybe n (uncurry j) . viewR - - -{- -viewLSafe :: Storable a => Vector a -> Maybe (a, Vector a) -viewLSafe (SV xs0) = - -- dropWhile would be unnecessary if we require that all chunks are non-empty - do (x,xs) <- ListHT.viewL (List.dropWhile V.null xs0) - (y,ys) <- viewLVector x - return (y, append (fromChunk ys) (SV xs)) - -viewRSafe :: Storable a => Vector a -> Maybe (Vector a, a) -viewRSafe (SV xs0) = - -- dropWhile would be unnecessary if we require that all chunks are non-empty - do (xs,x) <- ListHT.viewR (dropWhileRev V.null xs0) - (ys,y) <- V.viewR x - return (append (SV xs) (fromChunk ys), y) --} - - -{-# INLINE scanl #-} -scanl :: (Storable a, Storable b) => - (a -> b -> a) -> a -> Vector b -> Vector a -scanl f start = - cons start . snd . - mapAccumL (\acc -> (\b -> (b,b)) . f acc) start - -{-# INLINE mapAccumL #-} -mapAccumL :: (Storable a, Storable b) => - (acc -> a -> (acc, b)) -> acc -> Vector a -> (acc, Vector b) -mapAccumL f start = - mapSnd SV . - List.mapAccumL (V.mapAccumL f) start . - chunks - -{-# INLINE mapAccumR #-} -mapAccumR :: (Storable a, Storable b) => - (acc -> a -> (acc, b)) -> acc -> Vector a -> (acc, Vector b) -mapAccumR f start = - mapSnd SV . - List.mapAccumR (V.mapAccumR f) start . - chunks - -{-# INLINE crochetLChunk #-} -crochetLChunk :: (Storable x, Storable y) => - (x -> acc -> Maybe (y, acc)) - -> acc - -> V.Vector x - -> (V.Vector y, Maybe acc) -crochetLChunk f acc0 x0 = - mapSnd (fmap fst) $ - V.unfoldrN - (V.length x0) - (\(acc,xt) -> - do (x,xs) <- V.viewL xt - (y,acc') <- f x acc - return (y, (acc',xs))) - (acc0, x0) - -{-# INLINE crochetL #-} -crochetL :: (Storable x, Storable y) => - (x -> acc -> Maybe (y, acc)) - -> acc - -> Vector x - -> Vector y -crochetL f acc0 = - SV . List.unfoldr (\(xt,acc) -> - do (x,xs) <- ListHT.viewL xt - acc' <- acc - return $ mapSnd ((,) xs) $ crochetLChunk f acc' x) . - flip (,) (Just acc0) . - chunks - - - --- * sub-vectors - -{-# INLINE take #-} -take :: (Storable a) => Int -> Vector a -> Vector a -{- this order of pattern matches is certainly the most lazy one -> take 4 (pack (chunkSize 2) $ "abcd" List.++ undefined) -VectorLazy.fromChunks [Vector.pack "ab",Vector.pack "cd"] --} -take 0 _ = empty -take _ (SV []) = empty -take n (SV (x:xs)) = - let m = V.length x - in if m<=n - then SV $ (x:) $ chunks $ take (n-m) $ SV xs - else fromChunk (V.take n x) - -{-# INLINE drop #-} -drop :: (Storable a) => Int -> Vector a -> Vector a -drop _ (SV []) = empty -drop n (SV (x:xs)) = - let m = V.length x - in if m<=n - then drop (n-m) (SV xs) - else SV (V.drop n x : xs) - -{-# INLINE splitAt #-} -splitAt :: (Storable a) => Int -> Vector a -> (Vector a, Vector a) -splitAt n0 = - {- this order of pattern matches is certainly the most lazy one - > splitAt 4 (pack (chunkSize 2) $ "abcd" List.++ undefined) - (VectorLazy.fromChunks [Vector.pack "ab",Vector.pack "cd"],VectorLazy.fromChunks *** Exception: Prelude.undefined - -} - let recourse 0 xs = ([], xs) - recourse _ [] = ([], []) - recourse n (x:xs) = - let m = V.length x - in if m<=n - then mapFst (x:) $ recourse (n-m) xs - else mapPair ((:[]), (:xs)) $ V.splitAt n x - in mapPair (SV, SV) . recourse n0 . chunks - - - -{-# INLINE dropMarginRem #-} --- I have used this in an inner loop thus I prefer inlining -{- | -@dropMarginRem n m xs@ -drops at most the first @m@ elements of @xs@ -and ensures that @xs@ still contains @n@ elements. -Additionally returns the number of elements that could not be dropped -due to the margin constraint. -That is @dropMarginRem n m xs == (k,ys)@ implies @length xs - m == length ys - k@. -Requires @length xs >= n@. --} -dropMarginRem :: (Storable a) => Int -> Int -> Vector a -> (Int, Vector a) -dropMarginRem n m xs = - List.foldl' - (\(mi,xsi) k -> (mi-k, drop k xsi)) - (m,xs) - (List.map V.length $ chunks $ take m $ drop n xs) - -{- -This implementation does only walk once through the dropped prefix. -It is maximally lazy and minimally space consuming. --} -{-# INLINE dropMargin #-} -dropMargin :: (Storable a) => Int -> Int -> Vector a -> Vector a -dropMargin n m xs = - List.foldl' (flip drop) xs - (List.map V.length $ chunks $ take m $ drop n xs) - - - -{-# INLINE dropWhile #-} -dropWhile :: (Storable a) => (a -> Bool) -> Vector a -> Vector a -dropWhile _ (SV []) = empty -dropWhile p (SV (x:xs)) = - let y = V.dropWhile p x - in if V.null y - then dropWhile p (SV xs) - else SV (y:xs) - -{-# INLINE takeWhile #-} -takeWhile :: (Storable a) => (a -> Bool) -> Vector a -> Vector a -takeWhile _ (SV []) = empty -takeWhile p (SV (x:xs)) = - let y = V.takeWhile p x - in if V.length y < V.length x - then fromChunk y - else SV (x : chunks (takeWhile p (SV xs))) - - -{-# INLINE span #-} -span :: (Storable a) => (a -> Bool) -> Vector a -> (Vector a, Vector a) -span p = - let recourse [] = ([],[]) - recourse (x:xs) = - let (y,z) = V.span p x - in if V.null z - then mapFst (x:) (recourse xs) - else (chunks $ fromChunk y, (z:xs)) - in mapPair (SV, SV) . recourse . chunks -{- -span _ (SV []) = (empty, empty) -span p (SV (x:xs)) = - let (y,z) = V.span p x - in if V.length y == 0 - then mapFst (SV . (x:) . chunks) (span p (SV xs)) - else (SV [y], SV (z:xs)) --} - - --- * other functions - - -{-# INLINE filter #-} -filter :: (Storable a) => (a -> Bool) -> Vector a -> Vector a -filter p = - SV . List.filter (not . V.null) . List.map (V.filter p) . chunks - - -{- | -Generates laziness breaks -wherever one of the input signals has a chunk boundary. --} -{-# INLINE zipWith #-} -zipWith :: (Storable a, Storable b, Storable c) => - (a -> b -> c) - -> Vector a - -> Vector b - -> Vector c -zipWith f as0 bs0 = - let recourse at@(a:_) bt@(b:_) = - let z = V.zipWith f a b - n = V.length z - in z : recourse - (chunks $ drop n $ fromChunks at) - (chunks $ drop n $ fromChunks bt) - recourse _ _ = [] - in fromChunks $ recourse (chunks as0) (chunks bs0) - -{-# INLINE zipWith3 #-} -zipWith3 :: (Storable a, Storable b, Storable c, Storable d) => - (a -> b -> c -> d) - -> Vector a - -> Vector b - -> Vector c - -> Vector d -zipWith3 f as0 bs0 cs0 = - let recourse at@(a:_) bt@(b:_) ct@(c:_) = - let z = V.zipWith3 f a b c - n = V.length z - in z : recourse - (chunks $ drop n $ fromChunks at) - (chunks $ drop n $ fromChunks bt) - (chunks $ drop n $ fromChunks ct) - recourse _ _ _ = [] - in fromChunks $ recourse (chunks as0) (chunks bs0) (chunks cs0) - -{-# INLINE zipWith4 #-} -zipWith4 :: (Storable a, Storable b, Storable c, Storable d, Storable e) => - (a -> b -> c -> d -> e) - -> Vector a - -> Vector b - -> Vector c - -> Vector d - -> Vector e -zipWith4 f as0 bs0 cs0 ds0 = - let recourse at@(a:_) bt@(b:_) ct@(c:_) dt@(d:_) = - let z = V.zipWith4 f a b c d - n = V.length z - in z : recourse - (chunks $ drop n $ fromChunks at) - (chunks $ drop n $ fromChunks bt) - (chunks $ drop n $ fromChunks ct) - (chunks $ drop n $ fromChunks dt) - recourse _ _ _ _ = [] - in fromChunks $ - recourse (chunks as0) (chunks bs0) (chunks cs0) (chunks ds0) - - -{- | -Preserves chunk pattern of the last argument. --} -{-# INLINE zipWithLastPattern #-} -zipWithLastPattern :: (Storable a, Storable b, Storable c) => - (a -> b -> c) - -> Vector a - -> Vector b - -> Vector c -zipWithLastPattern f = - crochetL (\y -> liftM (mapFst (flip f y)) . Ptr.viewL) - . pointer - -{- | -Preserves chunk pattern of the last argument. --} -{-# INLINE zipWithLastPattern3 #-} -zipWithLastPattern3 :: - (Storable a, Storable b, Storable c, Storable d) => - (a -> b -> c -> d) -> - (Vector a -> Vector b -> Vector c -> Vector d) -zipWithLastPattern3 f s0 s1 = - crochetL (\z (xt,yt) -> - liftM2 - (\(x,xs) (y,ys) -> (f x y z, (xs,ys))) - (Ptr.viewL xt) - (Ptr.viewL yt)) - (pointer s0, pointer s1) - -{- | -Preserves chunk pattern of the last argument. --} -{-# INLINE zipWithLastPattern4 #-} -zipWithLastPattern4 :: - (Storable a, Storable b, Storable c, Storable d, Storable e) => - (a -> b -> c -> d -> e) -> - (Vector a -> Vector b -> Vector c -> Vector d -> Vector e) -zipWithLastPattern4 f s0 s1 s2 = - crochetL (\w (xt,yt,zt) -> - liftM3 - (\(x,xs) (y,ys) (z,zs) -> (f x y z w, (xs,ys,zs))) - (Ptr.viewL xt) - (Ptr.viewL yt) - (Ptr.viewL zt)) - (pointer s0, pointer s1, pointer s2) - - -{-# INLINE zipWithSize #-} -zipWithSize :: (Storable a, Storable b, Storable c) => - ChunkSize - -> (a -> b -> c) - -> Vector a - -> Vector b - -> Vector c -zipWithSize size f s0 s1 = - unfoldr size (\(xt,yt) -> - liftM2 - (\(x,xs) (y,ys) -> (f x y, (xs,ys))) - (Ptr.viewL xt) - (Ptr.viewL yt)) - (pointer s0, pointer s1) - -{-# INLINE zipWithSize3 #-} -zipWithSize3 :: - (Storable a, Storable b, Storable c, Storable d) => - ChunkSize -> (a -> b -> c -> d) -> - (Vector a -> Vector b -> Vector c -> Vector d) -zipWithSize3 size f s0 s1 s2 = - unfoldr size (\(xt,yt,zt) -> - liftM3 - (\(x,xs) (y,ys) (z,zs) -> - (f x y z, (xs,ys,zs))) - (Ptr.viewL xt) - (Ptr.viewL yt) - (Ptr.viewL zt)) - (pointer s0, pointer s1, pointer s2) - -{-# INLINE zipWithSize4 #-} -zipWithSize4 :: - (Storable a, Storable b, Storable c, Storable d, Storable e) => - ChunkSize -> (a -> b -> c -> d -> e) -> - (Vector a -> Vector b -> Vector c -> Vector d -> Vector e) -zipWithSize4 size f s0 s1 s2 s3 = - unfoldr size (\(xt,yt,zt,wt) -> - liftM4 - (\(x,xs) (y,ys) (z,zs) (w,ws) -> - (f x y z w, (xs,ys,zs,ws))) - (Ptr.viewL xt) - (Ptr.viewL yt) - (Ptr.viewL zt) - (Ptr.viewL wt)) - (pointer s0, pointer s1, pointer s2, pointer s3) - - --- * interleaved vectors - -{-# INLINE sieve #-} -sieve :: (Storable a) => Int -> Vector a -> Vector a -sieve n = - fromChunks . List.filter (not . V.null) . snd . - List.mapAccumL - (\offset chunk -> - (mod (offset - V.length chunk) n, - V.sieve n $ V.drop offset chunk)) 0 . - chunks - -{-# INLINE deinterleave #-} -deinterleave :: (Storable a) => Int -> Vector a -> [Vector a] -deinterleave n = - P.map (sieve n) . P.take n . P.iterate (switchL empty (flip const)) - -{- | -Interleave lazy vectors -while maintaining the chunk pattern of the first vector. -All input vectors must have the same length. --} -{-# INLINE interleaveFirstPattern #-} -interleaveFirstPattern :: (Storable a) => [Vector a] -> Vector a -interleaveFirstPattern [] = empty -interleaveFirstPattern vss@(vs:_) = - let pattern = List.map V.length $ chunks vs - split xs = - snd $ - List.mapAccumL - (\x n -> swap $ mapFst (V.concat . chunks) $ splitAt n x) - xs pattern - in fromChunks $ List.map V.interleave $ - List.transpose $ List.map split vss - -{- -interleaveFirstPattern vss@(vs:_) = - fromChunks . snd . - List.mapAccumL - (\xss n -> - swap $ - mapFst (V.interleave . List.map (V.concat . chunks)) $ - List.unzip $ List.map (splitAt n) xss) - vss . - List.map V.length . chunks $ vs --} - - - -{- | -Ensure a minimal length of the list by appending pad values. --} -{- disabled INLINE pad -} -pad :: (Storable a) => ChunkSize -> a -> Int -> Vector a -> Vector a -pad size y n0 = - let recourse n xt = - if n<=0 - then xt - else - case xt of - [] -> chunks $ replicate size n y - x:xs -> x : recourse (n - V.length x) xs - in SV . recourse n0 . chunks - -padAlt :: (Storable a) => ChunkSize -> a -> Int -> Vector a -> Vector a -padAlt size x n xs = - append xs - (let m = length xs - in if n>m - then replicate size (n-m) x - else empty) - - - - - --- * Helper functions for StorableVector - - -{-# INLINE cancelNullVector #-} -cancelNullVector :: (V.Vector a, b) -> Maybe (V.Vector a, b) -cancelNullVector y = - toMaybe (not (V.null (fst y))) y - --- if the chunk has length zero, an empty sequence is generated -{-# INLINE fromChunk #-} -fromChunk :: (Storable a) => V.Vector a -> Vector a -fromChunk x = - if V.null x - then empty - else SV [x] - - - -{- -reduceLVector :: Storable x => - (x -> acc -> Maybe acc) -> acc -> Vector x -> (acc, Bool) -reduceLVector f acc0 x = - let recourse i acc = - if i < V.length x - then (acc, True) - else - maybe - (acc, False) - (recourse (succ i)) - (f (V.index x i) acc) - in recourse 0 acc0 - - - - -{- * Fundamental functions -} - -{- -Usage of 'unfoldr' seems to be clumsy but that covers all cases, -like different block sizes in source and destination list. --} -crochetLSize :: (Storable x, Storable y) => - ChunkSize - -> (x -> acc -> Maybe (y, acc)) - -> acc - -> T x - -> T y -crochetLSize size f = - curry (unfoldr size (\(acc,xt) -> - do (x,xs) <- viewL xt - (y,acc') <- f x acc - return (y, (acc',xs)))) - -crochetListL :: (Storable y) => - ChunkSize - -> (x -> acc -> Maybe (y, acc)) - -> acc - -> [x] - -> T y -crochetListL size f = - curry (unfoldr size (\(acc,xt) -> - do (x,xs) <- ListHT.viewL xt - (y,acc') <- f x acc - return (y, (acc',xs)))) - - - -{-# NOINLINE [0] crochetFusionListL #-} -crochetFusionListL :: (Storable y) => - ChunkSize - -> (x -> acc -> Maybe (y, acc)) - -> acc - -> FList.T x - -> T y -crochetFusionListL size f = - curry (unfoldr size (\(acc,xt) -> - do (x,xs) <- FList.viewL xt - (y,acc') <- f x acc - return (y, (acc',xs)))) - - -{-# INLINE [0] reduceL #-} -reduceL :: Storable x => - (x -> acc -> Maybe acc) -> acc -> Vector x -> acc -reduceL f acc0 = - let recourse acc xt = - case xt of - [] -> acc - (x:xs) -> - let (acc',continue) = reduceLVector f acc x - in if continue - then recourse acc' xs - else acc' - in recourse acc0 . chunks - - - -{- * Basic functions -} - - -{-# RULEZ - "Storable.append/repeat/repeat" forall size x. - append (repeat size x) (repeat size x) = repeat size x ; - - "Storable.append/repeat/replicate" forall size n x. - append (repeat size x) (replicate size n x) = repeat size x ; - - "Storable.append/replicate/repeat" forall size n x. - append (replicate size n x) (repeat size x) = repeat size x ; - - "Storable.append/replicate/replicate" forall size n m x. - append (replicate size n x) (replicate size m x) = - replicate size (n+m) x ; - - "Storable.mix/repeat/repeat" forall size x y. - mix (repeat size x) (repeat size y) = repeat size (x+y) ; - - #-} - -{-# RULES - "Storable.length/cons" forall x xs. - length (cons x xs) = 1 + length xs ; - - "Storable.length/map" forall f xs. - length (map f xs) = length xs ; - - "Storable.map/cons" forall f x xs. - map f (cons x xs) = cons (f x) (map f xs) ; - - "Storable.map/repeat" forall size f x. - map f (repeat size x) = repeat size (f x) ; - - "Storable.map/replicate" forall size f x n. - map f (replicate size n x) = replicate size n (f x) ; - - "Storable.map/repeat" forall size f x. - map f (repeat size x) = repeat size (f x) ; - - {- - This can make things worse, if 'map' is applied to replicate, - since this can use of sharing. - It can also destroy the more important map/unfoldr fusion in - take n . map f . unfoldr g - - "Storable.take/map" forall n f x. - take n (map f x) = map f (take n x) ; - -} - - "Storable.take/repeat" forall size n x. - take n (repeat size x) = replicate size n x ; - - "Storable.take/take" forall n m xs. - take n (take m xs) = take (min n m) xs ; - - "Storable.drop/drop" forall n m xs. - drop n (drop m xs) = drop (n+m) xs ; - - "Storable.drop/take" forall n m xs. - drop n (take m xs) = take (max 0 (m-n)) (drop n xs) ; - - "Storable.map/mapAccumL/snd" forall g f acc0 xs. - map g (snd (mapAccumL f acc0 xs)) = - snd (mapAccumL (\acc a -> mapSnd g (f acc a)) acc0 xs) ; - - #-} - -{- GHC says this is an orphaned rule - "Storable.map/mapAccumL/mapSnd" forall g f acc0 xs. - mapSnd (map g) (mapAccumL f acc0 xs) = - mapAccumL (\acc a -> mapSnd g (f acc a)) acc0 xs ; --} - - -{- * Fusable functions -} - -scanLCrochet :: (Storable a, Storable b) => - (a -> b -> a) -> a -> Vector b -> Vector a -scanLCrochet f start = - cons start . - crochetL (\x acc -> let y = f acc x in Just (y, y)) start - -{-# INLINE mapCrochet #-} -mapCrochet :: (Storable a, Storable b) => (a -> b) -> (Vector a -> Vector b) -mapCrochet f = crochetL (\x _ -> Just (f x, ())) () - -{-# INLINE takeCrochet #-} -takeCrochet :: Storable a => Int -> Vector a -> Vector a -takeCrochet = crochetL (\x n -> toMaybe (n>0) (x, pred n)) - -{-# INLINE repeatUnfoldr #-} -repeatUnfoldr :: Storable a => ChunkSize -> a -> Vector a -repeatUnfoldr size = iterate size id - -{-# INLINE replicateCrochet #-} -replicateCrochet :: Storable a => ChunkSize -> Int -> a -> Vector a -replicateCrochet size n = takeCrochet n . repeat size - - - - -{- -The "fromList/drop" rule is not quite accurate -because the chunk borders are moved. -Maybe 'ChunkSize' better is a list of chunks sizes. --} - -{-# RULEZ - "fromList/zipWith" - forall size f (as :: Storable a => [a]) (bs :: Storable a => [a]). - fromList size (List.zipWith f as bs) = - zipWith size f (fromList size as) (fromList size bs) ; - - "fromList/drop" forall as n size. - fromList size (List.drop n as) = - drop n (fromList size as) ; - #-} - - - -{- * Fused functions -} - -type Unfoldr s a = (s -> Maybe (a,s), s) - -{-# INLINE zipWithUnfoldr2 #-} -zipWithUnfoldr2 :: Storable z => - ChunkSize - -> (x -> y -> z) - -> Unfoldr a x - -> Unfoldr b y - -> T z -zipWithUnfoldr2 size h (f,a) (g,b) = - unfoldr size - (\(a0,b0) -> liftM2 (\(x,a1) (y,b1) -> (h x y, (a1,b1))) (f a0) (g b0)) --- (uncurry (liftM2 (\(x,a1) (y,b1) -> (h x y, (a1,b1)))) . (f *** g)) - (a,b) - -{- done by takeCrochet -{-# INLINE mapUnfoldr #-} -mapUnfoldr :: (Storable x, Storable y) => - ChunkSize - -> (x -> y) - -> Unfoldr a x - -> T y -mapUnfoldr size g (f,a) = - unfoldr size (fmap (mapFst g) . f) a --} - -{-# INLINE dropUnfoldr #-} -dropUnfoldr :: Storable x => - ChunkSize - -> Int - -> Unfoldr a x - -> T x -dropUnfoldr size n (f,a0) = - maybe - empty - (unfoldr size f) - (nest n (\a -> fmap snd . f =<< a) (Just a0)) - - -{- done by takeCrochet -{-# INLINE takeUnfoldr #-} -takeUnfoldr :: Storable x => - ChunkSize - -> Int - -> Unfoldr a x - -> T x -takeUnfoldr size n0 (f,a0) = - unfoldr size - (\(a,n) -> - do guard (n>0) - (x,a') <- f a - return (x, (a', pred n))) - (a0,n0) --} - - -lengthUnfoldr :: Storable x => - Unfoldr a x - -> Int -lengthUnfoldr (f,a0) = - let recourse n a = - maybe n (recourse (succ n) . snd) (f a) - in recourse 0 a0 - - -{-# INLINE zipWithUnfoldr #-} -zipWithUnfoldr :: - (Storable b, Storable c) => - (acc -> Maybe (a, acc)) - -> (a -> b -> c) - -> acc - -> T b -> T c -zipWithUnfoldr f h a y = - crochetL (\y0 a0 -> - do (x0,a1) <- f a0 - Just (h x0 y0, a1)) a y - -{-# INLINE zipWithCrochetL #-} -zipWithCrochetL :: - (Storable x, Storable b, Storable c) => - ChunkSize - -> (x -> acc -> Maybe (a, acc)) - -> (a -> b -> c) - -> acc - -> T x -> T b -> T c -zipWithCrochetL size f h a x y = - crochetL (\(x0,y0) a0 -> - do (z0,a1) <- f x0 a0 - Just (h z0 y0, a1)) - a (zip size x y) - - -{-# INLINE crochetLCons #-} -crochetLCons :: - (Storable a, Storable b) => - (a -> acc -> Maybe (b, acc)) - -> acc - -> a -> T a -> T b -crochetLCons f a0 x xs = - maybe - empty - (\(y,a1) -> cons y (crochetL f a1 xs)) - (f x a0) - -{-# INLINE reduceLCons #-} -reduceLCons :: - (Storable a) => - (a -> acc -> Maybe acc) - -> acc - -> a -> T a -> acc -reduceLCons f a0 x xs = - maybe a0 (flip (reduceL f) xs) (f x a0) - - - - - -{-# RULES - "Storable.zipWith/share" forall size (h :: a->a->b) (x :: T a). - zipWith size h x x = map (\xi -> h xi xi) x ; - --- "Storable.map/zipWith" forall size (f::c->d) (g::a->b->c) (x::T a) (y::T b). - "Storable.map/zipWith" forall size f g x y. - map f (zipWith size g x y) = - zipWith size (\xi yi -> f (g xi yi)) x y ; - - -- this rule lets map run on a different block structure - "Storable.zipWith/map,*" forall size f g x y. - zipWith size g (map f x) y = - zipWith size (\xi yi -> g (f xi) yi) x y ; - - "Storable.zipWith/*,map" forall size f g x y. - zipWith size g x (map f y) = - zipWith size (\xi yi -> g xi (f yi)) x y ; - - - "Storable.drop/unfoldr" forall size f a n. - drop n (unfoldr size f a) = - dropUnfoldr size n (f,a) ; - - "Storable.take/unfoldr" forall size f a n. - take n (unfoldr size f a) = --- takeUnfoldr size n (f,a) ; - takeCrochet n (unfoldr size f a) ; - - "Storable.length/unfoldr" forall size f a. - length (unfoldr size f a) = lengthUnfoldr (f,a) ; - - "Storable.map/unfoldr" forall size g f a. - map g (unfoldr size f a) = --- mapUnfoldr size g (f,a) ; - mapCrochet g (unfoldr size f a) ; - - "Storable.map/iterate" forall size g f a. - map g (iterate size f a) = - mapCrochet g (iterate size f a) ; - -{- - "Storable.zipWith/unfoldr,unfoldr" forall sizeA sizeB f g h a b n. - zipWith n h (unfoldr sizeA f a) (unfoldr sizeB g b) = - zipWithUnfoldr2 n h (f,a) (g,b) ; --} - - -- block boundaries are changed here, so it changes lazy behaviour - "Storable.zipWith/unfoldr,*" forall sizeA sizeB f h a y. - zipWith sizeA h (unfoldr sizeB f a) y = - zipWithUnfoldr f h a y ; - - -- block boundaries are changed here, so it changes lazy behaviour - "Storable.zipWith/*,unfoldr" forall sizeA sizeB f h a y. - zipWith sizeA h y (unfoldr sizeB f a) = - zipWithUnfoldr f (flip h) a y ; - - "Storable.crochetL/unfoldr" forall size f g a b. - crochetL g b (unfoldr size f a) = - unfoldr size (\(a0,b0) -> - do (y0,a1) <- f a0 - (z0,b1) <- g y0 b0 - Just (z0, (a1,b1))) (a,b) ; - - "Storable.reduceL/unfoldr" forall size f g a b. - reduceL g b (unfoldr size f a) = - snd - (FList.recourse (\(a0,b0) -> - do (y,a1) <- f a0 - b1 <- g y b0 - Just (a1, b1)) (a,b)) ; - - "Storable.crochetL/cons" forall g b x xs. - crochetL g b (cons x xs) = - crochetLCons g b x xs ; - - "Storable.reduceL/cons" forall g b x xs. - reduceL g b (cons x xs) = - reduceLCons g b x xs ; - - - - - "Storable.take/crochetL" forall f a x n. - take n (crochetL f a x) = - takeCrochet n (crochetL f a x) ; - - "Storable.length/crochetL" forall f a x. - length (crochetL f a x) = length x ; - - "Storable.map/crochetL" forall g f a x. - map g (crochetL f a x) = - mapCrochet g (crochetL f a x) ; - - "Storable.zipWith/crochetL,*" forall size f h a x y. - zipWith size h (crochetL f a x) y = - zipWithCrochetL size f h a x y ; - - "Storable.zipWith/*,crochetL" forall size f h a x y. - zipWith size h y (crochetL f a x) = - zipWithCrochetL size f (flip h) a x y ; - - "Storable.crochetL/crochetL" forall f g a b x. - crochetL g b (crochetL f a x) = - crochetL (\x0 (a0,b0) -> - do (y0,a1) <- f x0 a0 - (z0,b1) <- g y0 b0 - Just (z0, (a1,b1))) (a,b) x ; - - "Storable.reduceL/crochetL" forall f g a b x. - reduceL g b (crochetL f a x) = - snd - (reduceL (\x0 (a0,b0) -> - do (y,a1) <- f x0 a0 - b1 <- g y b0 - Just (a1, b1)) (a,b) x) ; - #-} - --} - -{- * IO -} - -{- | -Read the rest of a file lazily and -provide the reason of termination as IOError. -If IOError is EOF (check with @System.Error.isEOFError err@), -then the file was read successfully. -Only access the final IOError after you have consumed the file contents, -since finding out the terminating reason forces to read the entire file. -Make also sure you read the file completely, -because it is only closed when the file end is reached -(or an exception is encountered). - -TODO: -In ByteString.Lazy the chunk size is reduced -if data is not immediately available. -Maybe we should adapt that behaviour -but when working with realtime streams -that may mean that the chunks are very small. --} -hGetContentsAsync :: Storable a => - ChunkSize -> Handle -> IO (IOError, Vector a) -hGetContentsAsync (ChunkSize size) h = - let go = - Unsafe.interleaveIO $ - flip catch (\err -> return (err,[])) $ - do v <- V.hGet h size - if V.null v - then hClose h >> - return (Exc.mkIOError Exc.eofErrorType - "StorableVector.Lazy.hGetContentsAsync" (Just h) Nothing, []) - else fmap (mapSnd (v:)) go -{- - Unsafe.interleaveIO $ - flip catch (\err -> return (err,[])) $ - liftM2 (\ chunk ~(err,rest) -> (err,chunk:rest)) - (V.hGet h size) go --} - in fmap (mapSnd SV) go - -hGetContentsSync :: Storable a => - ChunkSize -> Handle -> IO (Vector a) -hGetContentsSync (ChunkSize size) h = - let go = - do v <- V.hGet h size - if V.null v - then return [] - else fmap (v:) go - in fmap SV go - -hPut :: Storable a => Handle -> Vector a -> IO () -hPut h = mapM_ (V.hPut h) . chunks - -{- -*Data.StorableVector.Lazy> print . mapSnd (length :: Vector Data.Int.Int16 -> Int) =<< readFileAsync (ChunkSize 1000) "dist/build/libHSstorablevector-0.1.3.a" -(dist/build/libHSstorablevector-0.1.3.a: hGetBuf: illegal operation (handle is closed),0) --} -{- | -The file can only closed after all values are consumed. -That is you must always assert that you consume all elements of the stream, -and that no values are missed due to lazy evaluation. -This requirement makes this function useless in many applications. --} -readFileAsync :: Storable a => ChunkSize -> FilePath -> IO (IOError, Vector a) -readFileAsync size path = - openBinaryFile path ReadMode >>= hGetContentsAsync size - -writeFile :: Storable a => FilePath -> Vector a -> IO () -writeFile path = - bracket (openBinaryFile path WriteMode) hClose . flip hPut - -appendFile :: Storable a => FilePath -> Vector a -> IO () -appendFile path = - bracket (openBinaryFile path AppendMode) hClose . flip hPut - - -{-# NOINLINE moduleError #-} -moduleError :: String -> String -> a -moduleError fun msg = - error ("Data.StorableVector.Lazy." List.++ fun List.++ ':':' ':msg) diff --git a/Data/StorableVector/Lazy/Builder.hs b/Data/StorableVector/Lazy/Builder.hs deleted file mode 100644 --- a/Data/StorableVector/Lazy/Builder.hs +++ /dev/null @@ -1,159 +0,0 @@ -{-# LANGUAGE Rank2Types #-} -{- | -Build a lazy storable vector by incrementally adding an element. -This is analogous to Data.Binary.Builder for Data.ByteString.Lazy. - -Attention: -This implementation is still almost 3 times slower -than constructing a lazy storable vector using unfoldr -in our Chorus speed test. --} -module Data.StorableVector.Lazy.Builder ( - Builder, - toLazyStorableVector, - put, - flush, - ) where - -import qualified Data.StorableVector as SV -import qualified Data.StorableVector.Lazy as SVL -import qualified Data.StorableVector.ST.Strict as STV --- import qualified Data.StorableVector.ST.Lazy as STVL - -import Data.StorableVector.Lazy (ChunkSize, ) -import Control.Monad (liftM2, ) -import Control.Monad.ST.Strict (ST, runST, ) -import Data.Monoid (Monoid(mempty, mappend), ) - -import Foreign.Storable (Storable, ) - -import qualified System.Unsafe as Unsafe - - -{- -Given an initial buffer and a function that generates the rest of the vector, -a 'Builder' generates the whole vector. -The idea is inspired by Data.Binary.Builder. - -We use the strict ST monad by default -and only rare 'Unsafe.interleaveST', -since this is more efficient than using lazy ST everywhere. - -Before that approach I tried to achieve this with a lazy State monad. -I found this more comprehensible but it was very slow -and had a space leak, when the last chunk shall be handled correctly. --} -newtype Builder a = - Builder {run :: forall s. - ChunkSize -> - (Buffer s a -> ST s [SV.Vector a]) -> - (Buffer s a -> ST s [SV.Vector a]) - } - -type Buffer s a = (STV.Vector s a, Int) - - --- instance Monoid (Builder a) where -{- -Storable constraint not needed in the current implementation, -but who knows what will be in future ... --} -instance Storable a => Monoid (Builder a) where - {-# INLINE mempty #-} - {-# INLINE mappend #-} - mempty = Builder (\_ -> id) - mappend x y = Builder (\cs -> run x cs . run y cs) - - -{- | -> toLazyStorableVector (ChunkSize 7) $ Data.Monoid.mconcat $ map put ['a'..'z'] --} -{-# INLINE toLazyStorableVector #-} -toLazyStorableVector :: Storable a => - ChunkSize -> Builder a -> SVL.Vector a -toLazyStorableVector cs bld = - SVL.fromChunks $ - runST (run bld cs (fmap (:[]) . fixVector) =<< newChunk cs) - - -{-# INLINE put #-} -put :: Storable a => a -> Builder a -put a = - Builder (\cs cont (v0,i0) -> - do STV.unsafeWrite v0 i0 a - let i1 = succ i0 - if i1 < STV.length v0 - then - cont (v0, i1) - else - liftM2 (:) - -- we could call 'flush' here, but this requires an extra 'SV.take' - (STV.unsafeFreeze v0) - (Unsafe.interleaveST $ - cont =<< newChunk cs) - ) - -{- -put :: Storable a => a -> Builder a -put a = - Builder (\cs cont (v0,i0) -> - if i0 < STV.length v0 - then - do STV.write v0 i0 a - cont (v0, succ i0) - else - liftM2 (:) - -- we could call 'flush' here, but this requires an extra 'SV.take' - (STV.unsafeFreeze v0) - (Unsafe.interleaveST $ - do (v1,i1) <- newChunk cs - STV.write v1 i1 a - cont (v1, succ i1)) - ) --} - -{- - lazyToStrictST $ - liftM2 (:) - -- we could call 'flush' here, but this requires an extra 'SV.take' - (STVL.unsafeFreeze v0) - (strictToLazyST $ - do (v1,i1) <- newChunk cs - STV.write v1 i1 a - cont (v1, succ i1)) --} - -{- -Prelude Control.Monad.ST.Lazy> Control.Monad.ST.runST (lazyToStrictST $ Monad.liftM2 (,) (strictToLazyST $ return 'a') (strictToLazyST (undefined::Monad m => m Char))) -*** Exception: Prelude.undefined --} - -{- | -Set a laziness break. --} -{-# INLINE flush #-} -flush :: Storable a => Builder a -flush = - Builder (\cs cont vi0 -> - liftM2 (:) - (fixVector vi0) - (Unsafe.interleaveST $ cont =<< newChunk cs) -{- - lazyToStrictST $ - liftM2 (:) - (strictToLazyST $ fixVector vi0) - (strictToLazyST $ cont =<< newChunk cs) --} - ) - -{-# INLINE newChunk #-} -newChunk :: (Storable a) => - ChunkSize -> ST s (Buffer s a) -newChunk (SVL.ChunkSize size) = - fmap (flip (,) 0) $ STV.new_ size - -{-# INLINE fixVector #-} -fixVector :: (Storable a) => - Buffer s a -> ST s (SV.Vector a) -fixVector ~(v1,i1) = - fmap (SV.take i1) $ STV.unsafeFreeze v1 diff --git a/Data/StorableVector/Lazy/Pattern.hs b/Data/StorableVector/Lazy/Pattern.hs deleted file mode 100644 --- a/Data/StorableVector/Lazy/Pattern.hs +++ /dev/null @@ -1,371 +0,0 @@ -{- | -Functions for 'StorableVector' that allow control of the size of individual chunks. - -This is import for an application like the following: -You want to mix audio signals that are relatively shifted. -The structure of chunks of three streams may be illustrated as: - -> [____] [____] [____] [____] ... -> [____] [____] [____] [____] ... -> [____] [____] [____] [____] ... - -When we mix the streams (@zipWith3 (\x y z -> x+y+z)@) -with respect to the chunk structure of the first signal, -computing the first chunk requires full evaluation of all leading chunks of the stream. -However the last value of the third leading chunk -is much later in time than the last value of the first leading chunk. -We like to reduce these dependencies using a different chunk structure, -say - -> [____] [____] [____] [____] ... -> [__] [____] [____] [____] ... -> [] [____] [____] [____] ... - --} -module Data.StorableVector.Lazy.Pattern ( - Vector, - ChunkSize, - chunkSize, - defaultChunkSize, - LazySize, - - empty, - singleton, - pack, - unpack, - packWith, - unpackWith, - unfoldrN, - iterateN, - cycle, - replicate, - null, - length, - cons, - append, - concat, - map, - reverse, - foldl, - foldl', - any, - all, - maximum, - minimum, - viewL, - viewR, - switchL, - switchR, - scanl, - mapAccumL, - mapAccumR, - crochetL, - take, - drop, - splitAt, - takeVectorPattern, - splitAtVectorPattern, - dropMarginRem, - dropMargin, - dropWhile, - takeWhile, - span, - filter, - zipWith, - zipWith3, - zipWith4, - zipWithSize, - zipWithSize3, - zipWithSize4, -{- - pad, - cancelNullVector, --} - ) where - -import Numeric.NonNegative.Class ((-|)) -import qualified Numeric.NonNegative.Chunky as LS -import qualified Data.StorableVector.Lazy as LSV -import qualified Data.StorableVector as V - -import Data.StorableVector.Lazy (Vector(SV), ChunkSize(ChunkSize)) - -import Data.StorableVector.Lazy ( - chunkSize, defaultChunkSize, - empty, singleton, unpack, unpackWith, cycle, - null, cons, append, concat, map, reverse, - foldl, foldl', any, all, maximum, minimum, - viewL, viewR, switchL, switchR, - scanl, mapAccumL, mapAccumR, crochetL, - dropMarginRem, dropMargin, - dropWhile, takeWhile, span, filter, - zipWith, zipWith3, zipWith4, - ) - -import qualified Data.List as List - -import qualified Data.List.HT as ListHT -import Data.Tuple.HT (mapPair, mapFst, forcePair, swap, ) - -import Control.Monad (liftM2, liftM3, liftM4, guard, ) - -import Foreign.Storable (Storable) - -import Prelude hiding - (length, (++), iterate, foldl, map, repeat, replicate, null, - zip, zipWith, zipWith3, drop, take, splitAt, takeWhile, dropWhile, reverse, - any, all, concat, cycle, filter, maximum, minimum, scanl, span, ) -{- -import Data.Maybe (Maybe(Just, Nothing), ) -import Prelude (Int, (.), ($), fst, snd, (<=), flip, curry, return, fmap, not, uncurry, ) --} - - -type LazySize = LS.T ChunkSize - --- * Introducing and eliminating 'Vector's - -{- -Actually, this is lazy enough: - -> LSV.unpack $ pack (LS.fromChunks [10,15]) (['a'..'y'] List.++ Prelude.undefined) -"abcdefghijklmnopqrstuvwxy" --} -pack :: (Storable a) => LazySize -> [a] -> Vector a -pack size = - fst . unfoldrN size ListHT.viewL - - -{-# INLINE packWith #-} -packWith :: (Storable b) => LazySize -> (a -> b) -> [a] -> Vector b -packWith size f = - fst . unfoldrN size (fmap (mapFst f) . ListHT.viewL) - - -{- -{-# INLINE unfoldrNAlt #-} -unfoldrNAlt :: (Storable b) => - LazySize - -> (a -> Maybe (b,a)) - -> a - -> (Vector b, Maybe a) -unfoldrNAlt (LS.Cons size) f x = - let go sz y = - case sz of - [] -> ([], y) - (ChunkSize s : ss) -> - maybe - ([], Nothing) - ((\(c,a1) -> mapFst (c:) $ go ss a1) . - V.unfoldrN s (fmap (mapSnd f))) - (f y) - in mapFst SV $ go size (Just x) --} - -{-# INLINE unfoldrN #-} -unfoldrN :: (Storable b) => - LazySize - -> (a -> Maybe (b,a)) - -> a - -> (Vector b, Maybe a) -unfoldrN size f = - let go sz y = - forcePair $ - case sz of - [] -> ([], y) - (ChunkSize s : ss) -> - let m = - do a0 <- y - let p = V.unfoldrN s f a0 - guard (not (V.null (fst p))) - return p - in case m of - Nothing -> ([], Nothing) - Just (c,a1) -> mapFst (c:) $ go ss a1 - in mapFst SV . go (LS.toChunks size) . Just - - -{-# INLINE iterateN #-} -iterateN :: Storable a => LazySize -> (a -> a) -> a -> Vector a -iterateN size f = - fst . unfoldrN size (\x -> Just (x, f x)) - -{- -Tries to be time and memory efficient -by reusing subvectors of a chunk -until a larger chunk is needed. -However, it can be a memory leak -if a huge chunk is followed by many little ones. --} -replicate :: Storable a => LazySize -> a -> Vector a -replicate size x = - SV $ snd $ - List.mapAccumL - (\v (ChunkSize m) -> - if m <= V.length v - then (v, V.take m v) - else let v1 = V.replicate m x - in (v1,v1)) - V.empty $ - LS.toChunks size - -{- -replicate :: Storable a => LazySize -> a -> Vector a -replicate size x = - SV $ List.map (\(ChunkSize m) -> V.replicate m x) (LS.toChunks size) --} - - --- * Basic interface - -length :: Vector a -> LazySize -length = LS.fromChunks . List.map chunkLength . LSV.chunks - -chunkLength :: V.Vector a -> ChunkSize -chunkLength = ChunkSize . V.length - -decrementLimit :: V.Vector a -> LazySize -> LazySize -decrementLimit x y = - y -| LS.fromNumber (chunkLength x) - -intFromChunkSize :: ChunkSize -> Int -intFromChunkSize (ChunkSize x) = x - -intFromLazySize :: LazySize -> Int -intFromLazySize = - List.sum . List.map intFromChunkSize . LS.toChunks - - - --- * sub-vectors - -{- | -Generates laziness breaks -wherever either the lazy length number or the vector has a chunk boundary. --} -{-# INLINE take #-} -take :: (Storable a) => LazySize -> Vector a -> Vector a -take n = fst . splitAt n - -{- | -Preserves the chunk pattern of the lazy vector. --} -{-# INLINE takeVectorPattern #-} -takeVectorPattern :: (Storable a) => LazySize -> Vector a -> Vector a -takeVectorPattern _ (SV []) = empty -takeVectorPattern n (SV (x:xs)) = - if List.null (LS.toChunks n) - then empty - else - let remain = decrementLimit x n - in SV $ uncurry (:) $ - if LS.isNull remain - then (V.take (intFromLazySize n) x, []) - else - (x, LSV.chunks $ take remain $ LSV.fromChunks xs) - -{-# INLINE drop #-} -drop :: (Storable a) => LazySize -> Vector a -> Vector a -drop size xs = - List.foldl (flip (LSV.drop . intFromChunkSize)) xs (LS.toChunks size) - -{-# INLINE splitAt #-} -splitAt :: - (Storable a) => LazySize -> Vector a -> (Vector a, Vector a) -splitAt size xs = - mapFst LSV.concat $ swap $ - List.mapAccumL - (\xs0 n -> - swap $ LSV.splitAt (intFromChunkSize n) xs0) - xs (LS.toChunks size) - -{-# INLINE splitAtVectorPattern #-} -splitAtVectorPattern :: - (Storable a) => LazySize -> Vector a -> (Vector a, Vector a) -splitAtVectorPattern n0 = - forcePair . - if List.null (LS.toChunks n0) - then (,) empty - else - let recourse n xt = - forcePair $ - case xt of - [] -> ([], []) - (x:xs) -> - let remain = decrementLimit x n - in if LS.isNull remain - then mapPair ((:[]), (:xs)) $ - V.splitAt (intFromLazySize n) x - else mapFst (x:) $ recourse remain xs - in mapPair (SV, SV) . recourse n0 . LSV.chunks - - -{-# INLINE [0] zipWithSize #-} -zipWithSize :: (Storable a, Storable b, Storable c) => - LazySize - -> (a -> b -> c) - -> Vector a - -> Vector b - -> Vector c -zipWithSize size f = - curry (fst . unfoldrN size (\(xt,yt) -> - liftM2 - (\(x,xs) (y,ys) -> (f x y, (xs,ys))) - (viewL xt) - (viewL yt))) - -{-# INLINE zipWithSize3 #-} -zipWithSize3 :: - (Storable a, Storable b, Storable c, Storable d) => - LazySize -> (a -> b -> c -> d) -> - (Vector a -> Vector b -> Vector c -> Vector d) -zipWithSize3 size f s0 s1 s2 = - fst $ unfoldrN size (\(xt,yt,zt) -> - liftM3 - (\(x,xs) (y,ys) (z,zs) -> - (f x y z, (xs,ys,zs))) - (viewL xt) - (viewL yt) - (viewL zt)) - (s0,s1,s2) - -{-# INLINE zipWithSize4 #-} -zipWithSize4 :: - (Storable a, Storable b, Storable c, Storable d, Storable e) => - LazySize -> (a -> b -> c -> d -> e) -> - (Vector a -> Vector b -> Vector c -> Vector d -> Vector e) -zipWithSize4 size f s0 s1 s2 s3 = - fst $ unfoldrN size (\(xt,yt,zt,wt) -> - liftM4 - (\(x,xs) (y,ys) (z,zs) (w,ws) -> - (f x y z w, (xs,ys,zs,ws))) - (viewL xt) - (viewL yt) - (viewL zt) - (viewL wt)) - (s0,s1,s2,s3) - -{- -{- | -Ensure a minimal length of the list by appending pad values. --} -{-# ONLINE pad #-} -pad :: (Storable a) => ChunkSize -> a -> Int -> Vector a -> Vector a -pad size y n0 = - let recourse n xt = - if n<=0 - then xt - else - case xt of - [] -> chunks $ replicate size n y - x:xs -> x : recourse (n - V.length x) xs - in SV . recourse n0 . chunks - -padAlt :: (Storable a) => ChunkSize -> a -> Int -> Vector a -> Vector a -padAlt size x n xs = - append xs - (let m = length xs - in if n>m - then replicate size (n-m) x - else empty) --} diff --git a/Data/StorableVector/Lazy/Pointer.hs b/Data/StorableVector/Lazy/Pointer.hs deleted file mode 100644 --- a/Data/StorableVector/Lazy/Pointer.hs +++ /dev/null @@ -1,20 +0,0 @@ -{- | -In principle you can traverse through a lazy storable vector -using repeated calls to @viewL@. -However this needs a bit of pointer arrangement and allocation. -This data structure makes the inner loop faster, -that consists of traversing through a chunk. --} -module Data.StorableVector.Lazy.Pointer ( - Pointer, cons, viewL, switchL, - ) where - -import Data.StorableVector.Lazy.PointerPrivate (Pointer(..), viewL, switchL, ) -import qualified Data.StorableVector.Lazy as VL - -import Foreign.Storable (Storable) - - -{-# INLINE cons #-} -cons :: Storable a => VL.Vector a -> Pointer a -cons = VL.pointer diff --git a/Data/StorableVector/Lazy/PointerPrivate.hs b/Data/StorableVector/Lazy/PointerPrivate.hs deleted file mode 100644 --- a/Data/StorableVector/Lazy/PointerPrivate.hs +++ /dev/null @@ -1,42 +0,0 @@ -module Data.StorableVector.Lazy.PointerPrivate where - -import qualified Data.StorableVector.Pointer as VP -import qualified Data.StorableVector as V -import qualified Data.StorableVector.Base as VB - -import Foreign.Storable (Storable) - - -data Pointer a = - Pointer { - chunks :: [VB.Vector a], - ptr :: {-# UNPACK #-} !(VP.Pointer a) - } - - -empty :: Storable a => Pointer a -empty = - Pointer [] (VP.cons V.empty) - -{-# INLINE cons #-} -cons :: Storable a => [VB.Vector a] -> Pointer a -cons [] = empty -cons (c:cs) = Pointer cs (VP.cons c) - -{-# INLINE viewL #-} -viewL :: Storable a => Pointer a -> Maybe (a, Pointer a) -viewL = switchL Nothing (curry Just) - -{-# INLINE switchL #-} -switchL :: Storable a => - b -> (a -> Pointer a -> b) -> Pointer a -> b -switchL n j = - let recourse p = - let ct = chunks p - in VP.switchL - (case ct of - [] -> n - (c:cs) -> recourse (Pointer cs (VP.cons c))) - (\a cp -> j a (Pointer ct cp)) - (ptr p) - in recourse diff --git a/Data/StorableVector/Lazy/PointerPrivateIndex.hs b/Data/StorableVector/Lazy/PointerPrivateIndex.hs deleted file mode 100644 --- a/Data/StorableVector/Lazy/PointerPrivateIndex.hs +++ /dev/null @@ -1,38 +0,0 @@ -{- -Alternative to PointerPrivate implemented at a higher level. --} -module Data.StorableVector.Lazy.PointerPrivateIndex where - -import qualified Data.StorableVector as V -import qualified Data.StorableVector.Base as VB - -import Foreign.Storable (Storable) - - -data Pointer a = - Pointer {chunks :: ![VB.Vector a], index :: !Int} - - -{-# INLINE cons #-} -cons :: Storable a => [VB.Vector a] -> Pointer a -cons = flip Pointer 0 - -{-# INLINE viewL #-} -viewL :: Storable a => Pointer a -> Maybe (a, Pointer a) -viewL = switchL Nothing (curry Just) - -{-# INLINE switchL #-} -switchL :: Storable a => - b -> (a -> Pointer a -> b) -> Pointer a -> b -switchL n j = - let recourse p = - let s = chunks p - in case s of - [] -> n - (c:cs) -> - let i = index p - d = i - V.length c - in if d < 0 - then j (VB.unsafeIndex c i) (Pointer s (i+1)) - else recourse (Pointer cs d) - in recourse diff --git a/Data/StorableVector/Pointer.hs b/Data/StorableVector/Pointer.hs deleted file mode 100644 --- a/Data/StorableVector/Pointer.hs +++ /dev/null @@ -1,52 +0,0 @@ -{- | -In principle you can traverse through a storable vector -using repeated calls to @viewL@ or using @index@. -However this needs a bit of pointer arrangement and allocation. -This data structure should make loops optimally fast. --} -module Data.StorableVector.Pointer where - --- import qualified Data.StorableVector as V -import qualified Data.StorableVector.Base as VB - -import qualified Foreign.ForeignPtr as FPtr -import Foreign.Marshal.Array (advancePtr, ) -import Foreign.Storable (Storable, peek, ) -import Foreign (Ptr, ) -import qualified System.Unsafe as Unsafe - - -{- -The reference to the ForeignPtr asserts, -that the array is maintained and thus is not garbage collected. -The Ptr we use for traversing would not achieve this. --} -{- | -We might have name the data type iterator. --} -data Pointer a = - Pointer { - fptr :: {-# UNPACK #-} !(FPtr.ForeignPtr a), - ptr :: {-# UNPACK #-} !(Ptr a), - left :: {-# UNPACK #-} !Int - } - - -{-# INLINE cons #-} -cons :: Storable a => VB.Vector a -> Pointer a -cons (VB.SV fp s l) = - Pointer fp (advancePtr (Unsafe.foreignPtrToPtr fp) s) l - - -{-# INLINE viewL #-} -viewL :: Storable a => Pointer a -> Maybe (a, Pointer a) -viewL = switchL Nothing (curry Just) - -{-# INLINE switchL #-} -switchL :: Storable a => - b -> (a -> Pointer a -> b) -> Pointer a -> b -switchL n j (Pointer fp p l) = - if l<=0 - then n - else j (VB.inlinePerformIO (peek p)) (Pointer fp (advancePtr p 1) (l-1)) --- Unsafe.performIO at this place would make SpeedPointer test 0.5 s slower diff --git a/Data/StorableVector/Private.hs b/Data/StorableVector/Private.hs deleted file mode 100644 --- a/Data/StorableVector/Private.hs +++ /dev/null @@ -1,151 +0,0 @@ -{- | -Functions that may be useful, but I'm uncertain. --} -module Data.StorableVector.Private where - - -import Data.StorableVector (empty, unfoldrN, viewL, length, ) -import Data.StorableVector.Base - -import qualified Data.Strictness.HT as Strict - -import Foreign.Storable (Storable(..)) - -import qualified System.Unsafe as Unsafe - -import Control.DeepSeq (NFData, rnf, deepseq, ) - -import Prelude hiding (length, ) - - - -{- | -This implementation is based on viewL -and thus not as fast as possible. --} -zipWithViewL :: (Storable a, Storable b, Storable c) => - (a -> b -> c) -> Vector a -> Vector b -> Vector c -zipWithViewL f ps0 qs0 = - fst $ unfoldrN - (min (length ps0) (length qs0)) - (\(ps,qs) -> - do (ph,pt) <- viewL ps - (qh,qt) <- viewL qs - return (f ph qh, (pt,qt))) - (ps0,qs0) - - -zipWithIndex :: (Storable a, Storable b, Storable c) => - (a -> b -> c) -> Vector a -> Vector b -> Vector c -zipWithIndex f ps qs = - fst $ unfoldrN - (min (length ps) (length qs)) - (\i -> Just (f (unsafeIndex ps i) (unsafeIndex qs i), succ i)) - 0 - - -unfoldrStrictN :: (Storable b, NFData a) => Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a) --- unfoldrStrictN :: (Storable b) => Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a) -unfoldrStrictN i f x0 = - if i <= 0 - then (empty, Just x0) - else Unsafe.performIO $ createAndTrim' i $ \p -> go p 0 x0 - {- - go must not be strict in the accumulator - since otherwise packN would be too strict. - -} - where - go = Strict.arguments3 $ \p n -> \x -> - if n == i - then return (0, n, Just x) - else - case f x of - Nothing -> return (0, n, Nothing) - Just (w,x') -> do poke p w --- go (incPtr p) (n+1) $! x' - go (incPtr p) (n+1) (x' `deepseq` x') --- seq (rnf x') (((go $! incPtr p) $! n+1) $! x') -{-# INLINE unfoldrStrictN #-} - -unfoldrTransitionN :: (Storable b) => Int -> (a -> a) -> (a -> Maybe b) -> a -> (Vector b, a) -unfoldrTransitionN n trans emit x = - if n <= 0 - then (empty, x) - else Unsafe.performIO $ createAndTrim' n $ \p -> - case emit x of - Nothing -> return (0, n, x) - Just y0 -> poke p y0 >> - {- - go must not be strict in the accumulator - since otherwise packN would be too strict. - -} - let go = Strict.arguments2 $ \p0 i0 -> \x0 -> - {- - We run 'emit' in order to evaluate the new state. - We need to return this new state - also in case the array is full. - The drawback is, that the whole vector becomes undefined - if only the state after the last element is undefined. - This is the same situation as in an unfoldr with strict state. - -} - let i1 = i0-1 - x1 = trans x0 - in case emit x1 of - Nothing -> return (0, n-i1, x1) - Just y1 -> - if i1 == 0 - then return (0, n, x1) - else - let p1 = incPtr p0 - in do poke p1 y1 - go p1 i1 x1 -{- - let i1 = i0-1 - in if i1 == 0 - then return (0, n, x0) - else - let x1 = trans x0 - p1 = incPtr p0 - in case emit x1 of - Nothing -> return (0, n-i1, x1) - Just y1 -> do poke p1 y1 - go p1 i1 x1 --} - in go p n x -{-# INLINE unfoldrTransitionN #-} - --- | /O(n)/ Like 'unfoldrN' this function builds a 'Vector' from a seed --- value. However, it does always return a state value. --- The vector construction can be aborted either by reaching --- the given maximum size or by returning 'Nothing' as element. --- --- The following equation relates 'unfoldrN' and 'unfoldrStateN': --- --- > unfoldrN n f s == --- > unfoldrStateN n --- > (maybe (error "state will be always Just") --- > ((\a -> (fmap fst a, fmap snd a)) . f)) --- > (Just s) --- --- It is not possible to express 'unfoldrNState' in terms of 'unfoldrN'. --- -unfoldrStateN :: (Storable b) => Int -> (a -> (Maybe b, a)) -> a -> (Vector b, a) -unfoldrStateN i f x0 = - if i <= 0 - then (empty, x0) - else Unsafe.performIO $ createAndTrim' i $ \p -> go p 0 x0 - {- - go must not be strict in the accumulator - since otherwise packN would be too strict. - -} - where - go = Strict.arguments2 $ \p n -> \x -> - if n == i - then return (0, n, x) - else - let (my,x') = f x - in case my of - Nothing -> return (0, n, x) - Just w -> do poke p w - go (incPtr p) (n+1) x' -{-# INLINE unfoldrStateN #-} diff --git a/Data/StorableVector/ST/Lazy.hs b/Data/StorableVector/ST/Lazy.hs deleted file mode 100644 --- a/Data/StorableVector/ST/Lazy.hs +++ /dev/null @@ -1,152 +0,0 @@ -{-# LANGUAGE Rank2Types #-} -{- | -Module : Data.StorableVector.ST.Strict -License : BSD-style -Maintainer : haskell@henning-thielemann.de -Stability : experimental -Portability : portable, requires ffi -Tested with : GHC 6.4.1 - -Interface for access to a mutable StorableVector. --} -module Data.StorableVector.ST.Lazy ( - Vector, - new, - new_, - read, - write, - modify, - unsafeRead, - unsafeWrite, - unsafeModify, - freeze, - unsafeFreeze, - thaw, - VST.length, - runSTVector, - mapST, - mapSTLazy, - ) where - --- import qualified Data.StorableVector.Base as V -import qualified Data.StorableVector as VS -import qualified Data.StorableVector.Lazy as VL - -import qualified Data.StorableVector.ST.Strict as VST - -import Data.StorableVector.ST.Strict (Vector) - - -import qualified Control.Monad.ST.Lazy as ST -import Control.Monad.ST.Lazy (ST) - -import Foreign.Storable (Storable) - --- import Prelude (Int, ($), (+), return, const, ) -import Prelude hiding (read, length, ) - - - --- * access to mutable storable vector - -{-# INLINE new #-} -new :: (Storable e) => - Int -> e -> ST s (Vector s e) -new n x = ST.strictToLazyST (VST.new n x) - -{-# INLINE new_ #-} -new_ :: (Storable e) => - Int -> ST s (Vector s e) -new_ n = ST.strictToLazyST (VST.new_ n) - -{- | -> Control.Monad.ST.runST (do arr <- new_ 10; Monad.zipWithM_ (write arr) [9,8..0] ['a'..]; read arr 3) --} -{-# INLINE read #-} -read :: (Storable e) => - Vector s e -> Int -> ST s e -read xs n = ST.strictToLazyST (VST.read xs n) - -{- | -> VS.unpack $ runSTVector (do arr <- new_ 10; Monad.zipWithM_ (write arr) [9,8..0] ['a'..]; return arr) --} -{-# INLINE write #-} -write :: (Storable e) => - Vector s e -> Int -> e -> ST s () -write xs n x = ST.strictToLazyST (VST.write xs n x) - -{-# INLINE modify #-} -modify :: (Storable e) => - Vector s e -> Int -> (e -> e) -> ST s () -modify xs n f = ST.strictToLazyST (VST.modify xs n f) - - -{-# INLINE unsafeRead #-} -unsafeRead :: (Storable e) => - Vector s e -> Int -> ST s e -unsafeRead xs n = ST.strictToLazyST (VST.unsafeRead xs n) - -{-# INLINE unsafeWrite #-} -unsafeWrite :: (Storable e) => - Vector s e -> Int -> e -> ST s () -unsafeWrite xs n x = ST.strictToLazyST (VST.unsafeWrite xs n x) - -{-# INLINE unsafeModify #-} -unsafeModify :: (Storable e) => - Vector s e -> Int -> (e -> e) -> ST s () -unsafeModify xs n f = ST.strictToLazyST (VST.unsafeModify xs n f) - - -{-# INLINE freeze #-} -freeze :: (Storable e) => - Vector s e -> ST s (VS.Vector e) -freeze xs = ST.strictToLazyST (VST.freeze xs) - -{-# INLINE unsafeFreeze #-} -unsafeFreeze :: (Storable e) => - Vector s e -> ST s (VS.Vector e) -unsafeFreeze xs = ST.strictToLazyST (VST.unsafeFreeze xs) - -{-# INLINE thaw #-} -thaw :: (Storable e) => - VS.Vector e -> ST s (Vector s e) -thaw xs = ST.strictToLazyST (VST.thaw xs) - - - -{-# INLINE runSTVector #-} -runSTVector :: (Storable e) => - (forall s. ST s (Vector s e)) -> VS.Vector e -runSTVector m = VST.runSTVector (ST.lazyToStrictST m) - - - --- * operations on immutable storable vector within ST monad - -{- | -> :module + Data.STRef -> VS.unpack $ Control.Monad.ST.runST (do ref <- newSTRef 'a'; mapST (\ _n -> do c <- readSTRef ref; modifySTRef ref succ; return c) (VS.pack [1,2,3,4::Data.Int.Int16])) --} -{-# INLINE mapST #-} -mapST :: (Storable a, Storable b) => - (a -> ST s b) -> VS.Vector a -> ST s (VS.Vector b) -mapST f xs = - ST.strictToLazyST (VST.mapST (ST.lazyToStrictST . f) xs) - - -{- | -> *Data.StorableVector.ST.Strict Data.STRef> VL.unpack $ Control.Monad.ST.runST (do ref <- newSTRef 'a'; mapSTLazy (\ _n -> do c <- readSTRef ref; modifySTRef ref succ; return c) (VL.pack VL.defaultChunkSize [1,2,3,4::Data.Int.Int16])) -> "abcd" - -The following should not work on infinite streams, -since we are in 'ST' with strict '>>='. -But it works. Why? - -> *Data.StorableVector.ST.Strict Data.STRef.Lazy> VL.unpack $ Control.Monad.ST.Lazy.runST (do ref <- newSTRef 'a'; mapSTLazy (\ _n -> do c <- readSTRef ref; modifySTRef ref succ; return c) (VL.pack VL.defaultChunkSize [0::Data.Int.Int16 ..])) -> "Interrupted. --} -{-# INLINE mapSTLazy #-} -mapSTLazy :: (Storable a, Storable b) => - (a -> ST s b) -> VL.Vector a -> ST s (VL.Vector b) -mapSTLazy f (VL.SV xs) = - fmap VL.SV $ mapM (mapST f) xs diff --git a/Data/StorableVector/ST/Private.hs b/Data/StorableVector/ST/Private.hs deleted file mode 100644 --- a/Data/StorableVector/ST/Private.hs +++ /dev/null @@ -1,54 +0,0 @@ -{- | -Module : Data.StorableVector.ST.Strict -License : BSD-style -Maintainer : haskell@henning-thielemann.de -Stability : experimental -Portability : portable, requires ffi -Tested with : GHC 6.4.1 - --} -module Data.StorableVector.ST.Private where - -import qualified Data.StorableVector.Base as V - -import Data.StorableVector.Memory (mallocForeignPtrArray, ) - -import Control.Monad.ST.Strict (ST, ) - -import Foreign.Ptr (Ptr, ) -import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, ) -import Foreign.Storable (Storable, ) - -import qualified System.Unsafe as Unsafe - --- import Prelude (Int, ($), (+), return, const, ) -import Prelude hiding (read, length, ) - - -data Vector s a = - SV {-# UNPACK #-} !(ForeignPtr a) - {-# UNPACK #-} !Int -- length - - --- | Wrapper of mallocForeignPtrArray. -create :: (Storable a) => Int -> (Ptr a -> IO ()) -> IO (Vector s a) -create l f = do - fp <- mallocForeignPtrArray l - withForeignPtr fp f - return $! SV fp l - -{-# INLINE unsafeCreate #-} -unsafeCreate :: (Storable a) => Int -> (Ptr a -> IO ()) -> ST s (Vector s a) -unsafeCreate l f = Unsafe.ioToST $ create l f - -{- -This function must be in ST monad, -since it is usually called -as termination of a series of write accesses to the vector. -We must assert that no read access to the V.Vector can happen -before the end of the write accesses. -(And the caller must assert, that he actually never writes again into that vector.) --} -{-# INLINE unsafeToVector #-} -unsafeToVector :: Vector s a -> ST s (V.Vector a) -unsafeToVector (SV x l) = return (V.SV x 0 l) diff --git a/Data/StorableVector/ST/Strict.hs b/Data/StorableVector/ST/Strict.hs deleted file mode 100644 --- a/Data/StorableVector/ST/Strict.hs +++ /dev/null @@ -1,287 +0,0 @@ -{-# LANGUAGE Rank2Types #-} -{- | -Module : Data.StorableVector.ST.Strict -License : BSD-style -Maintainer : haskell@henning-thielemann.de -Stability : experimental -Portability : portable, requires ffi -Tested with : GHC 6.4.1 - -Interface for access to a mutable StorableVector. --} -module Data.StorableVector.ST.Strict ( - Vector, - new, - new_, - read, - write, - modify, - maybeRead, - maybeWrite, - maybeModify, - unsafeRead, - unsafeWrite, - unsafeModify, - freeze, - unsafeFreeze, - thaw, - length, - runSTVector, - mapST, - mapSTLazy, - ) where - -import Data.StorableVector.ST.Private - (Vector(SV), create, unsafeCreate, unsafeToVector, ) -import qualified Data.StorableVector.Base as V -import qualified Data.StorableVector as VS -import qualified Data.StorableVector.Lazy as VL - -import Control.Monad.ST.Strict (ST, runST, ) - -import Foreign.Ptr (Ptr, ) -import Foreign.ForeignPtr (withForeignPtr, ) -import Foreign.Storable (Storable(peek, poke)) -import Foreign.Marshal.Array (advancePtr, copyArray, ) -import qualified System.Unsafe as Unsafe - -import qualified Data.Traversable as Traversable -import Data.Maybe.HT (toMaybe, ) -import Data.Maybe (isJust, ) - --- import Prelude (Int, ($), (+), return, const, ) -import Prelude hiding (read, length, ) - - --- * access to mutable storable vector - -{-# INLINE new #-} -new :: (Storable e) => - Int -> e -> ST s (Vector s e) -new n x = - unsafeCreate n $ - let {-# INLINE go #-} - go m p = - if m>0 - then poke p x >> go (pred m) (V.incPtr p) - else return () - in go n - -{-# INLINE new_ #-} -new_ :: (Storable e) => - Int -> ST s (Vector s e) -new_ n = - unsafeCreate n (const (return ())) - - -{- | -> Control.Monad.ST.runST (do arr <- new_ 10; Monad.zipWithM_ (write arr) [9,8..0] ['a'..]; read arr 3) --} -{-# INLINE read #-} -read :: (Storable e) => - Vector s e -> Int -> ST s e -read v n = - access "read" v n $ unsafeRead v n - -{- | -> VS.unpack $ runSTVector (do arr <- new_ 10; Monad.zipWithM_ (write arr) [9,8..0] ['a'..]; return arr) --} -{-# INLINE write #-} -write :: (Storable e) => - Vector s e -> Int -> e -> ST s () -write v n x = - access "write" v n $ unsafeWrite v n x - -{- | -> VS.unpack $ runSTVector (do arr <- new 10 'a'; Monad.mapM_ (\n -> modify arr (mod n 8) succ) [0..10]; return arr) --} -{-# INLINE modify #-} -modify :: (Storable e) => - Vector s e -> Int -> (e -> e) -> ST s () -modify v n f = - access "modify" v n $ unsafeModify v n f - -{-# INLINE access #-} -access :: (Storable e) => - String -> Vector s e -> Int -> ST s a -> ST s a -access name (SV _v l) n act = - if 0<=n && n Control.Monad.ST.runST (do arr <- new_ 10; Monad.zipWithM_ (write arr) [9,8..0] ['a'..]; read arr 3) - -In future 'maybeRead' will replace 'read'. --} -{-# INLINE maybeRead #-} -maybeRead :: (Storable e) => - Vector s e -> Int -> ST s (Maybe e) -maybeRead v n = - maybeAccess v n $ unsafeRead v n - -{- | -Returns 'True' if the element could be written -and 'False' if the index was out of range. - -> runSTVector (do arr <- new_ 10; foldr (\c go i -> maybeWrite arr i c >>= \cont -> if cont then go (succ i) else return arr) (error "unreachable") ['a'..] 0) - -In future 'maybeWrite' will replace 'write'. --} -{-# INLINE maybeWrite #-} -maybeWrite :: (Storable e) => - Vector s e -> Int -> e -> ST s Bool -maybeWrite v n x = - fmap isJust $ maybeAccess v n $ unsafeWrite v n x - -{- | -Similar to 'maybeWrite'. - -In future 'maybeModify' will replace 'modify'. --} -{-# INLINE maybeModify #-} -maybeModify :: (Storable e) => - Vector s e -> Int -> (e -> e) -> ST s Bool -maybeModify v n f = - fmap isJust $ maybeAccess v n $ unsafeModify v n f - -{-# INLINE maybeAccess #-} -maybeAccess :: (Storable e) => - Vector s e -> Int -> ST s a -> ST s (Maybe a) -maybeAccess (SV _v l) n act = - Traversable.sequence $ toMaybe (0<=n && n - Vector s e -> Int -> ST s e -unsafeRead v n = - unsafeAccess v n $ peek - -{-# INLINE unsafeWrite #-} -unsafeWrite :: (Storable e) => - Vector s e -> Int -> e -> ST s () -unsafeWrite v n x = - unsafeAccess v n $ \p -> poke p x - -{-# INLINE unsafeModify #-} -unsafeModify :: (Storable e) => - Vector s e -> Int -> (e -> e) -> ST s () -unsafeModify v n f = - unsafeAccess v n $ \p -> poke p . f =<< peek p - -{-# INLINE unsafeAccess #-} -unsafeAccess :: (Storable e) => - Vector s e -> Int -> (Ptr e -> IO a) -> ST s a -unsafeAccess (SV v _l) n act = - Unsafe.ioToST (withForeignPtr v $ \p -> act (advancePtr p n)) - - -{-# INLINE freeze #-} -freeze :: (Storable e) => - Vector s e -> ST s (VS.Vector e) -freeze (SV x l) = - Unsafe.ioToST $ - V.create l $ \p -> - withForeignPtr x $ \f -> - copyArray p f (fromIntegral l) - -{- | -This is like 'freeze' but it does not copy the vector. -You must make sure that you never write again to the array. -It is best to use 'unsafeFreeze' only at the end of a block, -that is run by 'runST'. --} -{-# INLINE unsafeFreeze #-} -unsafeFreeze :: (Storable e) => - Vector s e -> ST s (VS.Vector e) -unsafeFreeze = unsafeToVector - - -{-# INLINE thaw #-} -thaw :: (Storable e) => - VS.Vector e -> ST s (Vector s e) -thaw v = - Unsafe.ioToST $ - V.withStartPtr v $ \f l -> - create l $ \p -> - copyArray p f (fromIntegral l) - - -{-# INLINE length #-} -length :: - Vector s e -> Int -length (SV _v l) = l - - -{-# INLINE runSTVector #-} -runSTVector :: (Storable e) => - (forall s. ST s (Vector s e)) -> VS.Vector e -runSTVector m = - runST (unsafeToVector =<< m) - - - --- * operations on immutable storable vector within ST monad - -{- | -> :module + Data.STRef -> VS.unpack $ Control.Monad.ST.runST (do ref <- newSTRef 'a'; mapST (\ _n -> do c <- readSTRef ref; modifySTRef ref succ; return c) (VS.pack [1,2,3,4::Data.Int.Int16])) --} -{-# INLINE mapST #-} -mapST :: (Storable a, Storable b) => - (a -> ST s b) -> VS.Vector a -> ST s (VS.Vector b) -mapST f (V.SV px sx n) = - let {-# INLINE go #-} - go l q p = - if l>0 - then - do Unsafe.ioToST . poke p =<< f =<< Unsafe.ioToST (peek q) - go (pred l) (advancePtr q 1) (advancePtr p 1) - else return () - in do ys@(SV py _) <- new_ n - go n - (Unsafe.foreignPtrToPtr px `advancePtr` sx) - (Unsafe.foreignPtrToPtr py) - unsafeToVector ys - -{- -mapST f xs@(V.SV v s l) = - let go l q p = - if l>0 - then - do poke p =<< stToIO . f =<< peek q - go (pred l) (advancePtr q 1) (advancePtr p 1) - else return () - n = VS.length xs - in return $ V.unsafeCreate n $ \p -> - withForeignPtr v $ \q -> go n (advancePtr q s) p --} - - -{- | -> *Data.StorableVector.ST.Strict Data.STRef> VL.unpack $ Control.Monad.ST.runST (do ref <- newSTRef 'a'; mapSTLazy (\ _n -> do c <- readSTRef ref; modifySTRef ref succ; return c) (VL.pack VL.defaultChunkSize [1,2,3,4::Data.Int.Int16])) -> "abcd" - -The following should not work on infinite streams, -since we are in 'ST' with strict '>>='. -But it works. Why? - -> *Data.StorableVector.ST.Strict Data.STRef> VL.unpack $ Control.Monad.ST.runST (do ref <- newSTRef 'a'; mapSTLazy (\ _n -> do c <- readSTRef ref; modifySTRef ref succ; return c) (VL.pack VL.defaultChunkSize [0::Data.Int.Int16 ..])) -> "Interrupted. --} -{-# INLINE mapSTLazy #-} -mapSTLazy :: (Storable a, Storable b) => - (a -> ST s b) -> VL.Vector a -> ST s (VL.Vector b) -mapSTLazy f (VL.SV xs) = - fmap VL.SV $ mapM (mapST f) xs diff --git a/speedtest/Data/StorableVector/Private.hs b/speedtest/Data/StorableVector/Private.hs new file mode 100644 --- /dev/null +++ b/speedtest/Data/StorableVector/Private.hs @@ -0,0 +1,151 @@ +{- | +Functions that may be useful, but I'm uncertain. +-} +module Data.StorableVector.Private where + + +import Data.StorableVector (empty, unfoldrN, viewL, length, ) +import Data.StorableVector.Base + +import qualified Data.Strictness.HT as Strict + +import Foreign.Storable (Storable(..)) + +import qualified System.Unsafe as Unsafe + +import Control.DeepSeq (NFData, rnf, deepseq, ) + +import Prelude hiding (length, ) + + + +{- | +This implementation is based on viewL +and thus not as fast as possible. +-} +zipWithViewL :: (Storable a, Storable b, Storable c) => + (a -> b -> c) -> Vector a -> Vector b -> Vector c +zipWithViewL f ps0 qs0 = + fst $ unfoldrN + (min (length ps0) (length qs0)) + (\(ps,qs) -> + do (ph,pt) <- viewL ps + (qh,qt) <- viewL qs + return (f ph qh, (pt,qt))) + (ps0,qs0) + + +zipWithIndex :: (Storable a, Storable b, Storable c) => + (a -> b -> c) -> Vector a -> Vector b -> Vector c +zipWithIndex f ps qs = + fst $ unfoldrN + (min (length ps) (length qs)) + (\i -> Just (f (unsafeIndex ps i) (unsafeIndex qs i), succ i)) + 0 + + +unfoldrStrictN :: (Storable b, NFData a) => Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a) +-- unfoldrStrictN :: (Storable b) => Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a) +unfoldrStrictN i f x0 = + if i <= 0 + then (empty, Just x0) + else Unsafe.performIO $ createAndTrim' i $ \p -> go p 0 x0 + {- + go must not be strict in the accumulator + since otherwise packN would be too strict. + -} + where + go = Strict.arguments3 $ \p n -> \x -> + if n == i + then return (0, n, Just x) + else + case f x of + Nothing -> return (0, n, Nothing) + Just (w,x') -> do poke p w +-- go (incPtr p) (n+1) $! x' + go (incPtr p) (n+1) (x' `deepseq` x') +-- seq (rnf x') (((go $! incPtr p) $! n+1) $! x') +{-# INLINE unfoldrStrictN #-} + +unfoldrTransitionN :: (Storable b) => Int -> (a -> a) -> (a -> Maybe b) -> a -> (Vector b, a) +unfoldrTransitionN n trans emit x = + if n <= 0 + then (empty, x) + else Unsafe.performIO $ createAndTrim' n $ \p -> + case emit x of + Nothing -> return (0, n, x) + Just y0 -> poke p y0 >> + {- + go must not be strict in the accumulator + since otherwise packN would be too strict. + -} + let go = Strict.arguments2 $ \p0 i0 -> \x0 -> + {- + We run 'emit' in order to evaluate the new state. + We need to return this new state + also in case the array is full. + The drawback is, that the whole vector becomes undefined + if only the state after the last element is undefined. + This is the same situation as in an unfoldr with strict state. + -} + let i1 = i0-1 + x1 = trans x0 + in case emit x1 of + Nothing -> return (0, n-i1, x1) + Just y1 -> + if i1 == 0 + then return (0, n, x1) + else + let p1 = incPtr p0 + in do poke p1 y1 + go p1 i1 x1 +{- + let i1 = i0-1 + in if i1 == 0 + then return (0, n, x0) + else + let x1 = trans x0 + p1 = incPtr p0 + in case emit x1 of + Nothing -> return (0, n-i1, x1) + Just y1 -> do poke p1 y1 + go p1 i1 x1 +-} + in go p n x +{-# INLINE unfoldrTransitionN #-} + +-- | /O(n)/ Like 'unfoldrN' this function builds a 'Vector' from a seed +-- value. However, it does always return a state value. +-- The vector construction can be aborted either by reaching +-- the given maximum size or by returning 'Nothing' as element. +-- +-- The following equation relates 'unfoldrN' and 'unfoldrStateN': +-- +-- > unfoldrN n f s == +-- > unfoldrStateN n +-- > (maybe (error "state will be always Just") +-- > ((\a -> (fmap fst a, fmap snd a)) . f)) +-- > (Just s) +-- +-- It is not possible to express 'unfoldrNState' in terms of 'unfoldrN'. +-- +unfoldrStateN :: (Storable b) => Int -> (a -> (Maybe b, a)) -> a -> (Vector b, a) +unfoldrStateN i f x0 = + if i <= 0 + then (empty, x0) + else Unsafe.performIO $ createAndTrim' i $ \p -> go p 0 x0 + {- + go must not be strict in the accumulator + since otherwise packN would be too strict. + -} + where + go = Strict.arguments2 $ \p n -> \x -> + if n == i + then return (0, n, x) + else + let (my,x') = f x + in case my of + Nothing -> return (0, n, x) + Just w -> do poke p w + go (incPtr p) (n+1) x' +{-# INLINE unfoldrStateN #-} diff --git a/src/Data/StorableVector.hs b/src/Data/StorableVector.hs new file mode 100644 --- /dev/null +++ b/src/Data/StorableVector.hs @@ -0,0 +1,1571 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- +-- Module : StorableVector +-- Copyright : (c) The University of Glasgow 2001, +-- (c) David Roundy 2003-2005, +-- (c) Simon Marlow 2005 +-- (c) Don Stewart 2005-2006 +-- (c) Bjorn Bringert 2006 +-- (c) Spencer Janssen 2006 +-- (c) Henning Thielemann 2008-2013 +-- +-- +-- License : BSD-style +-- +-- Maintainer : Henning Thielemann +-- Stability : experimental +-- Portability : portable, requires ffi and cpp +-- Tested with : GHC 6.4.1 and Hugs March 2005 +-- + +-- +-- | A time and space-efficient implementation of vectors using +-- packed arrays, suitable for high performance use, both in terms +-- of large data quantities, or high speed requirements. Vectors +-- are encoded as strict arrays, held in a 'ForeignPtr', +-- and can be passed between C and Haskell with little effort. +-- +-- This module is intended to be imported @qualified@, to avoid name +-- clashes with "Prelude" functions. eg. +-- +-- > import qualified Data.StorableVector as V +-- +-- Original GHC implementation by Bryan O\'Sullivan. Rewritten to use +-- UArray by Simon Marlow. Rewritten to support slices and use +-- ForeignPtr by David Roundy. Polished and extended by Don Stewart. +-- Generalized to any Storable value by Spencer Janssen. +-- Chunky lazy stream, also with chunk pattern control, +-- mutable access in ST monad, Builder monoid by Henning Thieleman. + +module Data.StorableVector ( + + -- * The @Vector@ type + Vector, + + -- * Introducing and eliminating 'Vector's + empty, + singleton, + pack, + unpack, + packN, + packWith, + unpackWith, + + -- * Basic interface + cons, + snoc, + append, + head, + last, + tail, + init, + null, + length, + viewL, + viewR, + switchL, + switchR, + + -- * Transforming 'Vector's + map, + reverse, + intersperse, + transpose, + + -- * Reducing 'Vector's (folds) + foldl, + foldl', + foldl1, + foldl1', + foldr, + foldr1, + + -- ** Special folds + concat, + concatMap, + monoidConcatMap, + any, + all, + maximum, + minimum, + + -- * Building 'Vector's + -- ** Scans + scanl, + scanl1, + scanr, + scanr1, + + -- ** Accumulating maps + mapAccumL, + mapAccumR, + mapIndexed, + + -- ** Unfolding 'Vector's + replicate, + iterateN, + unfoldr, + unfoldrN, + unfoldrResultN, + sample, + + -- * Substrings + + -- ** Breaking strings + take, + drop, + splitAt, + takeWhile, + dropWhile, + span, + spanEnd, + break, + breakEnd, + group, + groupBy, + inits, + tails, + + -- ** Breaking into many substrings + split, + splitWith, + tokens, + + -- ** Joining strings + join, + + -- * Predicates + isPrefixOf, + isSuffixOf, + + -- * Searching 'Vector's + + -- ** Searching by equality + elem, + notElem, + + -- ** Searching with a predicate + find, + filter, + + -- * Indexing 'Vector's + index, + elemIndex, + elemIndices, + elemIndexEnd, + findIndex, + findIndices, + count, + findIndexOrEnd, + + -- * Zipping and unzipping 'Vector's + zip, + zipWith, + zipWith3, + zipWith4, + unzip, + copy, + + -- * Interleaved 'Vector's + sieve, + deinterleave, + interleave, + + -- * IO + hGet, + hPut, + readFile, + writeFile, + appendFile, + + ) where + +import Data.StorableVector.Base + +import qualified System.Unsafe as Unsafe + +import Control.Exception (assert, bracket, ) +import System.IO (IO, FilePath, Handle, IOMode(..), + openBinaryFile, hClose, hFileSize, + hGetBuf, hPutBuf, ) + +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, ) +import Foreign.Marshal.Array (advancePtr, copyArray, withArray, ) +import Foreign.Ptr (Ptr, minusPtr, ) +import Foreign.Storable (Storable(..)) + +import qualified Test.QuickCheck as QC + +import qualified Control.Monad.Trans.Cont as MC +import Control.Monad (mplus, guard, when, liftM2, liftM3, liftM4, + mapM, sequence_, return, (=<<), (>>=), (>>), ) +import Data.Functor (fmap, ) +import Data.Monoid (Monoid, mempty, mappend, mconcat, ) + +import qualified Data.List as List +import qualified Data.List.HT as ListHT +import qualified Data.Strictness.HT as Strict +import Text.Show (show, ) +import Data.Function (flip, id, const, ($), (.), ) +import Data.List (and, (++), ) +import Data.Tuple.HT (mapSnd, ) +import Data.Tuple (uncurry, curry, fst, snd, ) +import Data.Either (Either(Left, Right), ) +import Data.Maybe.HT (toMaybe, ) +import Data.Maybe (Maybe(Just, Nothing), maybe, fromMaybe, isJust, ) +import Data.Bool.HT (if', ) +import Data.Bool (Bool(False, True), not, otherwise, (&&), (||), ) +import Data.Ord (Ord, min, max, (<), (<=), (>), (>=), ) +import Data.Eq (Eq, (==), (/=), ) + +import qualified Prelude as P +import Prelude + (String, Int, (*), (-), (+), div, mod, + fromIntegral, error, undefined, ) + + +-- ----------------------------------------------------------------------------- + +instance (Storable a, Eq a) => Eq (Vector a) where + (==) = equal + +instance (Storable a) => Monoid (Vector a) where + mempty = empty + mappend = append + mconcat = concat + +instance (Storable a, QC.Arbitrary a) => QC.Arbitrary (Vector a) where + arbitrary = pack `fmap` QC.arbitrary + +-- | /O(n)/ Equality on the 'Vector' type. +equal :: (Storable a, Eq a) => Vector a -> Vector a -> Bool +equal a b = + Unsafe.performIO $ + withStartPtr a $ \paf la -> + withStartPtr b $ \pbf lb -> + if la /= lb + then + return False + else + if paf == pbf + then return True + else + let go = Strict.arguments3 $ \p q l -> + if l==0 + then return True + else + do x <- peek p + y <- peek q + if x==y + then go (incPtr p) (incPtr q) (l-1) + else return False + in go paf pbf la +{-# INLINE equal #-} + +-- ----------------------------------------------------------------------------- +-- Introducing and eliminating 'Vector's + +-- | /O(1)/ The empty 'Vector' +empty :: (Storable a) => Vector a +empty = unsafeCreate 0 $ const $ return () +{-# NOINLINE empty #-} + +-- | /O(1)/ Construct a 'Vector' containing a single element +singleton :: (Storable a) => a -> Vector a +singleton c = unsafeCreate 1 $ \p -> poke p c +{-# INLINE singleton #-} + +-- | /O(n)/ Convert a '[a]' into a 'Vector a'. +-- +pack :: (Storable a) => [a] -> Vector a +pack str = unsafeCreate (P.length str) $ \p -> go p str + where + go = Strict.arguments2 $ \p -> + ListHT.switchL + (return ()) + (\x xs -> poke p x >> go (incPtr p) xs) + +-- | /O(n)/ Convert first @n@ elements of a '[a]' into a 'Vector a'. +-- +packN :: (Storable a) => Int -> [a] -> (Vector a, [a]) +packN n = + mapSnd (fromMaybe []) . unfoldrN n ListHT.viewL + +-- | /O(n)/ Converts a 'Vector a' to a '[a]'. +unpack :: (Storable a) => Vector a -> [a] +unpack = foldr (:) [] +{-# INLINE unpack #-} + +------------------------------------------------------------------------ + +-- | /O(n)/ Convert a list into a 'Vector' using a conversion function +packWith :: (Storable b) => (a -> b) -> [a] -> Vector b +packWith k str = unsafeCreate (P.length str) $ \p -> go p str + where + go = Strict.arguments2 $ \p -> + ListHT.switchL + (return ()) + (\x xs -> poke p (k x) >> go (incPtr p) xs) + -- less space than pokeElemOff +{-# INLINE packWith #-} + +{- +*Data.StorableVector> List.take 10 $ unpackWith id $ pack [0..10000000::Int] +[0,1,2,3,4,5,6,7,8,9] +(19.18 secs, 2327851592 bytes) +-} +-- | /O(n)/ Convert a 'Vector' into a list using a conversion function +unpackWith :: (Storable a) => (a -> b) -> Vector a -> [b] +unpackWith f = foldr ((:) . f) [] +{-# INLINE unpackWith #-} + +{- +That's too inefficient, since it builds the list from back to front, +that is, in a too strict manner. + +-- | /O(n)/ Convert a 'Vector' into a list using a conversion function +unpackWith :: (Storable a) => (a -> b) -> Vector a -> [b] +unpackWith _ (SV _ _ 0) = [] +unpackWith k v@(SV ps s l) = inlinePerformIO $ withStartPtr v $ \p -> + go p (l - 1) [] + where + STRICT3(go) + go p 0 acc = peek p >>= \e -> return (k e : acc) + go p n acc = peekElemOff p n >>= \e -> go p (n-1) (k e : acc) +{-# INLINE unpackWith #-} + + +*Data.StorableVector> List.take 10 $ unpack $ pack [0..10000000::Int] +[0,1,2,3,4,5,6,7,8,9] +(18.57 secs, 2323959948 bytes) +*Data.StorableVector> unpack $ take 10 $ pack [0..10000000::Int] +[0,1,2,3,4,5,6,7,8,9] +(18.40 secs, 2324002120 bytes) +*Data.StorableVector> List.take 10 $ unpackWith id $ pack [0..10000000::Int] +Interrupted. +-} + +-- --------------------------------------------------------------------- +-- Basic interface + +-- | /O(1)/ Test whether a 'Vector' is empty. +null :: Vector a -> Bool +null (SV _ _ l) = assert (l >= 0) $ l <= 0 +{-# INLINE null #-} + +-- --------------------------------------------------------------------- +-- | /O(1)/ 'length' returns the length of a 'Vector' as an 'Int'. +length :: Vector a -> Int +length (SV _ _ l) = assert (l >= 0) $ l + +-- +-- length/loop fusion. When taking the length of any fuseable loop, +-- rewrite it as a foldl', and thus avoid allocating the result buffer +-- worth around 10% in speed testing. +-- + +{-# INLINE [1] length #-} + +------------------------------------------------------------------------ + +-- | /O(n)/ 'cons' is analogous to (:) for lists, but of different +-- complexity, as it requires a memcpy. +cons :: (Storable a) => a -> Vector a -> Vector a +cons c v = + unsafeWithStartPtr v $ \f l -> + create (l + 1) $ \p -> do + poke p c + copyArray (incPtr p) f (fromIntegral l) +{-# INLINE cons #-} + +-- | /O(n)/ Append an element to the end of a 'Vector' +snoc :: (Storable a) => Vector a -> a -> Vector a +snoc v c = + unsafeWithStartPtr v $ \f l -> + create (l + 1) $ \p -> do + copyArray p f l + pokeElemOff p l c +{-# INLINE snoc #-} + +-- | /O(1)/ Extract the first element of a 'Vector', which must be non-empty. +-- An exception will be thrown in the case of an empty 'Vector'. +head :: (Storable a) => Vector a -> a +head = + withNonEmptyVector "head" $ \ p s _l -> foreignPeek p s +{-# INLINE head #-} + +-- | /O(1)/ Extract the elements after the head of a 'Vector', which must be non-empty. +-- An exception will be thrown in the case of an empty 'Vector'. +tail :: (Storable a) => Vector a -> Vector a +tail = + withNonEmptyVector "tail" $ \ p s l -> SV p (s+1) (l-1) +{-# INLINE tail #-} + +laxTail :: (Storable a) => Vector a -> Vector a +laxTail v@(SV fp s l) = + if l<=0 + then v + else SV fp (s+1) (l-1) +{-# INLINE laxTail #-} + +-- | /O(1)/ Extract the last element of a 'Vector', which must be finite and non-empty. +-- An exception will be thrown in the case of an empty 'Vector'. +last :: (Storable a) => Vector a -> a +last = + withNonEmptyVector "last" $ \ p s l -> foreignPeek p (s+l-1) +{-# INLINE last #-} + +-- | /O(1)/ Return all the elements of a 'Vector' except the last one. +-- An exception will be thrown in the case of an empty 'Vector'. +init :: Vector a -> Vector a +init = + withNonEmptyVector "init" $ \ p s l -> SV p s (l-1) +{-# INLINE init #-} + +-- | /O(n)/ Append two Vectors +append :: (Storable a) => Vector a -> Vector a -> Vector a +append xs ys = + if' (null xs) ys $ + if' (null ys) xs $ + concat [xs,ys] +{-# INLINE append #-} + +-- --------------------------------------------------------------------- +-- Transformations + +-- | /O(n)/ 'map' @f xs@ is the 'Vector' obtained by applying @f@ to each +-- element of @xs@. +map :: (Storable a, Storable b) => (a -> b) -> Vector a -> Vector b +map f v = + unsafeWithStartPtr v $ \a len -> + create len $ \p -> + let go = Strict.arguments3 $ + \ n p1 p2 -> + when (n>0) $ + do poke p2 . f =<< peek p1 + go (n-1) (incPtr p1) (incPtr p2) + in go len a p +{-# INLINE map #-} + +{- +mapByIndex :: (Storable a, Storable b) => (a -> b) -> Vector a -> Vector b +mapByIndex f v = inlinePerformIO $ withStartPtr v $ \a len -> + create len $ \p2 -> + let go = Strict.arguments1 $ \ n -> + when (n Vector a -> Vector a +reverse v = + unsafeWithStartPtr v $ \f l -> + create l $ \p -> + sequence_ [peekElemOff f i >>= pokeElemOff p (l - i - 1) + | i <- [0 .. l - 1]] + +-- | /O(n)/ The 'intersperse' function takes a element and a +-- 'Vector' and \`intersperses\' that element between the elements of +-- the 'Vector'. It is analogous to the intersperse function on +-- Lists. +intersperse :: (Storable a) => a -> Vector a -> Vector a +intersperse c = pack . List.intersperse c . unpack + +-- | The 'transpose' function transposes the rows and columns of its +-- 'Vector' argument. +transpose :: (Storable a) => [Vector a] -> [Vector a] +transpose ps = P.map pack (List.transpose (P.map unpack ps)) + +-- --------------------------------------------------------------------- +-- Reducing 'Vector's + +-- | 'foldl', applied to a binary operator, a starting value (typically +-- the left-identity of the operator), and a Vector, reduces the +-- 'Vector' using the binary operator, from left to right. +-- This function is subject to array fusion. +foldl :: (Storable a) => (b -> a -> b) -> b -> Vector a -> b +foldl f v xs = + foldr (\x k acc -> k (f acc x)) id xs v +{-# INLINE foldl #-} + +-- | 'foldl\'' is like 'foldl', but strict in the accumulator. +foldl' :: (Storable a) => (b -> a -> b) -> b -> Vector a -> b +foldl' f b v = + Unsafe.performIO $ withStartPtr v $ \ptr l -> + let q = ptr `advancePtr` l + go = Strict.arguments2 $ \p z -> + if p == q + then return z + else go (incPtr p) . f z =<< peek p + in go ptr b +{-# INLINE foldl' #-} + +-- | 'foldr', applied to a binary operator, a starting value +-- (typically the right-identity of the operator), and a 'Vector', +-- reduces the 'Vector' using the binary operator, from right to left. +-- However, it is not the same as 'foldl' applied to the reversed vector. +-- Actually 'foldr' starts processing with the first element, +-- and thus can be used for efficiently building a singly linked list +-- by @foldr (:) [] vec@. +-- Unfortunately 'foldr' is quite slow for low-level loops, +-- since GHC (up to 6.12.1) cannot detect the loop. +foldr :: (Storable a) => (a -> b -> b) -> b -> Vector a -> b +foldr = foldrByLoop +{-# INLINE foldr #-} + +{- +*Data.StorableVector> List.length $ foldrBySwitch (:) [] $ replicate 1000000 'a' +1000000 +(11.29 secs, 1183476300 bytes) +*Data.StorableVector> List.length $ foldrByIO (:) [] $ replicate 1000000 'a' +1000000 +(7.86 secs, 1033901140 bytes) +*Data.StorableVector> List.length $ foldrByIndex (:) [] $ replicate 1000000 'a' +1000000 +(7.86 secs, 914340420 bytes) +*Data.StorableVector> List.length $ foldrByLoop (:) [] $ replicate 1000000 'a' +1000000 +(6.38 secs, 815355460 bytes) +-} +{- +We cannot simply increment the pointer, +since ForeignPtr cannot be incremented. +We also cannot convert from ForeignPtr to Ptr +and increment that instead, +because we need to keep the reference to ForeignPtr, +otherwise memory might be freed. +We can also not perform loop entirely in strict IO, +since this eat up the stack quickly +and 'foldr' might be used to build a list lazily. +-} +foldrByLoop :: (Storable a) => (a -> b -> b) -> b -> Vector a -> b +foldrByLoop f z (SV fp s l) = + let end = s+l + go = Strict.arguments1 $ \k -> + if k (a -> b -> b) -> b -> Vector a -> b +foldrByIO f z v@(SV fp _ _) = + unsafeWithStartPtr v $ + let go = Strict.arguments2 $ \p l -> + Unsafe.interleaveIO $ + if l>0 + then liftM2 f (peek p) (go (incPtr p) (pred l)) + else touchForeignPtr fp >> return z + in go +{-# INLINE foldrByIO #-} + +foldrByIndex :: (Storable a) => (a -> b -> b) -> b -> Vector a -> b +foldrByIndex k z xs = + let recourse n = + if n < length xs + then k (unsafeIndex xs n) (recourse (succ n)) + else z + in recourse 0 +{-# INLINE foldrByIndex #-} + +{- +This implementation is a bit inefficient, +since switchL creates a new Vector structure +instead of just incrementing an index. +-} +foldrBySwitch :: (Storable a) => (a -> b -> b) -> b -> Vector a -> b +foldrBySwitch k z = + let recourse = switchL z (\h t -> k h (recourse t)) + in recourse +{-# INLINE foldrBySwitch #-} +-} + + +-- | 'foldl1' is a variant of 'foldl' that has no starting value +-- argument, and thus must be applied to non-empty 'Vector's. +-- This function is subject to array fusion. +-- An exception will be thrown in the case of an empty 'Vector'. +foldl1 :: (Storable a) => (a -> a -> a) -> Vector a -> a +foldl1 f = + switchL + (errorEmpty "foldl1") + (foldl f) +{-# INLINE foldl1 #-} + +-- | 'foldl1\'' is like 'foldl1', but strict in the accumulator. +-- An exception will be thrown in the case of an empty 'Vector'. +foldl1' :: (Storable a) => (a -> a -> a) -> Vector a -> a +foldl1' f = + switchL + (errorEmpty "foldl1'") + (foldl' f) +{-# INLINE foldl1' #-} + +-- | 'foldr1' is a variant of 'foldr' that has no starting value argument, +-- and thus must be applied to non-empty 'Vector's +-- An exception will be thrown in the case of an empty 'Vector'. +foldr1 :: (Storable a) => (a -> a -> a) -> Vector a -> a +foldr1 f = + switchR + (errorEmpty "foldr1") + (flip (foldr f)) +{-# INLINE foldr1 #-} + +-- --------------------------------------------------------------------- +-- Special folds + +-- | /O(n)/ Concatenate a list of 'Vector's. +concat :: (Storable a) => [Vector a] -> Vector a +concat [] = empty +concat [ps] = ps +concat xs = unsafeCreate len $ \ptr -> go ptr xs + where len = P.sum . P.map length $ xs + go = + Strict.arguments2 $ \ptr -> + ListHT.switchL + (return ()) + (\v ps -> do + withStartPtr v $ copyArray ptr + go (ptr `advancePtr` length v) ps) + +-- | Map a function over a 'Vector' and concatenate the results +concatMap :: (Storable a, Storable b) => (a -> Vector b) -> Vector a -> Vector b +concatMap f = concat . unpackWith f +{-# INLINE concatMap #-} + +-- | This is like @mconcat . map f@, +-- but in many cases the result of @f@ will not be storable. +monoidConcatMap :: (Storable a, Monoid m) => (a -> m) -> Vector a -> m +monoidConcatMap f = + foldr (mappend . f) mempty +{-# INLINE monoidConcatMap #-} + +-- | /O(n)/ Applied to a predicate and a 'Vector', 'any' determines if +-- any element of the 'Vector' satisfies the predicate. +any :: (Storable a) => (a -> Bool) -> Vector a -> Bool +any f = foldr ((||) . f) False +{-# INLINE any #-} + +-- | /O(n)/ Applied to a predicate and a 'Vector', 'all' determines +-- if all elements of the 'Vector' satisfy the predicate. +all :: (Storable a) => (a -> Bool) -> Vector a -> Bool +all f = foldr ((&&) . f) True +{-# INLINE all #-} + +------------------------------------------------------------------------ + +-- | /O(n)/ 'maximum' returns the maximum value from a 'Vector' +-- This function will fuse. +-- An exception will be thrown in the case of an empty 'Vector'. +maximum :: (Storable a, Ord a) => Vector a -> a +maximum = foldl1' max + +-- | /O(n)/ 'minimum' returns the minimum value from a 'Vector' +-- This function will fuse. +-- An exception will be thrown in the case of an empty 'Vector'. +minimum :: (Storable a, Ord a) => Vector a -> a +minimum = foldl1' min + +------------------------------------------------------------------------ + +switchL :: Storable a => b -> (a -> Vector a -> b) -> Vector a -> b +switchL n j x = + if null x + then n + else j (unsafeHead x) (unsafeTail x) +{-# INLINE switchL #-} + +switchR :: Storable a => b -> (Vector a -> a -> b) -> Vector a -> b +switchR n j x = + if null x + then n + else j (unsafeInit x) (unsafeLast x) +{-# INLINE switchR #-} + +viewL :: Storable a => Vector a -> Maybe (a, Vector a) +viewL = switchL Nothing (curry Just) +{-# INLINE viewL #-} + +viewR :: Storable a => Vector a -> Maybe (Vector a, a) +viewR = switchR Nothing (curry Just) +{-# INLINE viewR #-} + +-- | The 'mapAccumL' function behaves like a combination of 'map' and +-- 'foldl'; it applies a function to each element of a 'Vector', +-- passing an accumulating parameter from left to right, and returning a +-- final value of this accumulator together with the new list. +mapAccumL :: (Storable a, Storable b) => (acc -> a -> (acc, b)) -> acc -> Vector a -> (acc, Vector b) +mapAccumL f acc0 as0 = + let (bs, Just (acc2, _)) = + unfoldrN (length as0) + (\(acc,as) -> + fmap + (\(asHead,asTail) -> + let (acc1,b) = f acc asHead + in (b, (acc1, asTail))) + (viewL as)) + (acc0,as0) + in (acc2, bs) +{-# INLINE mapAccumL #-} + +-- | The 'mapAccumR' function behaves like a combination of 'map' and +-- 'foldr'; it applies a function to each element of a 'Vector', +-- passing an accumulating parameter from right to left, and returning a +-- final value of this accumulator together with the new 'Vector'. +mapAccumR :: (Storable a, Storable b) => (acc -> a -> (acc, b)) -> acc -> Vector a -> (acc, Vector b) +mapAccumR f acc0 as0 = + let (bs, Just (acc2, _)) = + unfoldlN (length as0) + (\(acc,as) -> + fmap + (\(asInit,asLast) -> + let (acc1,b) = f acc asLast + in (b, (acc1, asInit))) + (viewR as)) + (acc0,as0) + in (acc2, bs) +{-# INLINE mapAccumR #-} + +-- | /O(n)/ map functions, provided with the index at each position +mapIndexed :: (Storable a, Storable b) => (Int -> a -> b) -> Vector a -> Vector b +mapIndexed f = snd . mapAccumL (\i e -> (i + 1, f i e)) 0 +{-# INLINE mapIndexed #-} + +-- --------------------------------------------------------------------- +-- Building 'Vector's + +-- | 'scanl' is similar to 'foldl', but returns a list of successive +-- reduced values from the left. This function will fuse. +-- +-- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] +-- +-- Note that +-- +-- > last (scanl f z xs) == foldl f z xs. +scanl :: (Storable a, Storable b) => (a -> b -> a) -> a -> Vector b -> Vector a +scanl f acc0 as0 = + fst $ + unfoldrN (succ (length as0)) + (fmap $ \(acc,as) -> + (acc, + fmap + (\(asHead,asTail) -> + (f acc asHead, asTail)) + (viewL as))) + (Just (acc0, as0)) + +-- less efficient but much more comprehensible +-- scanl f z ps = +-- cons z (snd (mapAccumL (\acc a -> let b = f acc a in (b,b)) z ps)) + + -- n.b. haskell's List scan returns a list one bigger than the + -- input, so we need to snoc here to get some extra space, however, + -- it breaks map/up fusion (i.e. scanl . map no longer fuses) +{-# INLINE scanl #-} + +-- | 'scanl1' is a variant of 'scanl' that has no starting value argument. +-- This function will fuse. +-- +-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...] +scanl1 :: (Storable a) => (a -> a -> a) -> Vector a -> Vector a +scanl1 f = switchL empty (scanl f) +{-# INLINE scanl1 #-} + +-- | scanr is the right-to-left dual of scanl. +scanr :: (Storable a, Storable b) => (a -> b -> b) -> b -> Vector a -> Vector b +scanr f acc0 as0 = + fst $ + unfoldlN (succ (length as0)) + (fmap $ \(acc,as) -> + (acc, + fmap + (\(asInit,asLast) -> + (f asLast acc, asInit)) + (viewR as))) + (Just (acc0, as0)) +{-# INLINE scanr #-} + +-- | 'scanr1' is a variant of 'scanr' that has no starting value argument. +scanr1 :: (Storable a) => (a -> a -> a) -> Vector a -> Vector a +scanr1 f = switchR empty (flip (scanl f)) +{-# INLINE scanr1 #-} + +-- --------------------------------------------------------------------- +-- Unfolds and replicates + +-- | /O(n)/ 'replicate' @n x@ is a 'Vector' of length @n@ with @x@ +-- the value of every element. +-- +{- nice implementation +replicate :: (Storable a) => Int -> a -> Vector a +replicate n c = + fst $ unfoldrN n (const $ Just (c, ())) () +-} + +{- +fast implementation + +Maybe it could be made even faster by plainly copying the bit pattern of the first element. +Since there is no function like 'memset', +we could not warrant that the implementation is really efficient +for the actual machine we run on. +-} +replicate :: (Storable a) => Int -> a -> Vector a +replicate n c = + if n <= 0 + then empty + else unsafeCreate n $ + let go = Strict.arguments2 $ \i p -> + if i == 0 + then return () + else poke p c >> go (pred i) (incPtr p) + in go n +{-# INLINE replicate #-} +{- +For 'replicate 10000000 (42::Int)' generates: + +Main_zdwa_info: + movl (%ebp),%eax + testl %eax,%eax + jne .LcfIQ + movl $ghczmprim_GHCziUnit_Z0T_closure+1,%esi + addl $8,%ebp + jmp *(%ebp) +.LcfIQ: + movl 4(%ebp),%ecx + movl $42,(%ecx) + decl %eax + addl $4,4(%ebp) + movl %eax,(%ebp) + jmp Main_zdwa_info + +that is, the inner loop consists of 9 instructions, +where I would write something like: + # counter in %ecx + testl %ecx + jz skip_loop + movl $42,%ebx +start_loop: + movl %ebx,(%edx) + addl $4,%edx + loop start_loop +skip_loop: + +and need only 3 instructions in the loop. +-} + + +-- | /O(n)/ 'iterateN' @n f x@ is a 'Vector' of length @n@ +-- where the elements of @x@ are generated by repeated application of @f@. +-- +iterateN :: (Storable a) => Int -> (a -> a) -> a -> Vector a +iterateN n f = + fst . unfoldrN n (\a -> Just (a, f a)) +{-# INLINE iterateN #-} + +-- | /O(n)/, where /n/ is the length of the result. The 'unfoldr' +-- function is analogous to the List \'unfoldr\'. 'unfoldr' builds a +-- 'Vector' from a seed value. The function takes the element and +-- returns 'Nothing' if it is done producing the 'Vector or returns +-- 'Just' @(a,b)@, in which case, @a@ is the next element in the 'Vector', +-- and @b@ is the seed value for further production. +-- +-- Examples: +-- +-- > unfoldr (\x -> if x <= 5 then Just (x, x + 1) else Nothing) 0 +-- > == pack [0, 1, 2, 3, 4, 5] +-- +unfoldr :: (Storable b) => (a -> Maybe (b, a)) -> a -> Vector b +unfoldr f = concat . unfoldChunk 32 64 + where unfoldChunk n n' x = + case unfoldrN n f x of + (s, mx) -> s : maybe [] (unfoldChunk n' (n+n')) mx +{-# INLINE unfoldr #-} + +-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a 'Vector' from a seed +-- value. However, the length of the result is limited by the first +-- argument to 'unfoldrN'. This function is more efficient than 'unfoldr' +-- when the maximum length of the result is known. +-- +-- The following equation relates 'unfoldrN' and 'unfoldr': +-- +-- > fst (unfoldrN n f s) == take n (unfoldr f s) +-- +unfoldrN :: (Storable b) => Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a) +unfoldrN n f x0 = + if n <= 0 + then (empty, Just x0) + else Unsafe.performIO $ createAndTrim' n $ \p -> go p n x0 + {- + go must not be strict in the accumulator + since otherwise packN would be too strict. + -} + where + go = Strict.arguments2 $ \p i -> \x -> + if i == 0 + then return (0, n-i, Just x) + else + case f x of + Nothing -> return (0, n-i, Nothing) + Just (w,x') -> do poke p w + go (incPtr p) (i-1) x' +{-# INLINE unfoldrN #-} + +{- +Examples: + +f i = Just (i::Char, succ i) + +f i = toMaybe (i<='p') (i::Char, succ i) + +-} +-- | /O(n)/ Like 'unfoldrN' this function builds a 'Vector' +-- from a seed value with limited size. +-- Additionally it returns a value, that depends on the state, +-- but is not necessarily the state itself. +-- If end of vector and end of the generator coincide, +-- then the result is as if only the end of vector is reached. +-- +-- Example: +-- +-- > unfoldrResultN 30 Char.ord (\c -> if c>'z' then Left 1000 else Right (c, succ c)) 'a' +-- +-- The following equation relates 'unfoldrN' and 'unfoldrResultN': +-- +-- > unfoldrN n f s == +-- > unfoldrResultN n Just +-- > (maybe (Left Nothing) Right . f) s +-- +-- It is not possible to express 'unfoldrResultN' in terms of 'unfoldrN'. +-- +unfoldrResultN :: (Storable b) => Int -> (a -> c) -> (a -> Either c (b, a)) -> a -> (Vector b, c) +unfoldrResultN i g f x0 = + if i <= 0 + then (empty, g x0) + else Unsafe.performIO $ createAndTrim' i $ \p -> go p 0 x0 + {- + go must not be strict in the accumulator + since otherwise packN would be too strict. + -} + where + go = Strict.arguments2 $ \p n -> \a0 -> + if n == i + then return (0, n, g a0) + else + case f a0 of + Left c -> return (0, n, c) + Right (b,a1) -> do poke p b + go (incPtr p) (n+1) a1 +{-# INLINE unfoldrResultN #-} + +unfoldlN :: (Storable b) => Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a) +unfoldlN i f x0 + | i < 0 = (empty, Just x0) + | otherwise = Unsafe.performIO $ createAndTrim' i $ \p -> go (p `advancePtr` i) i x0 + where go = Strict.arguments2 $ \p n -> \x -> + if n == 0 + then return (n, i, Just x) + else + case f x of + Nothing -> return (n, i, Nothing) + Just (w,x') -> + let p' = p `advancePtr` (-1) + in do poke p' w + go p' (n-1) x' +{-# INLINE unfoldlN #-} + + +-- | /O(n)/, where /n/ is the length of the result. +-- This function constructs a vector by evaluating a function +-- that depends on the element index. +-- It is a special case of 'unfoldrN' and can in principle be parallelized. +-- +-- Examples: +-- +-- > sample 26 (\x -> chr(ord 'a'+x)) +-- > == pack "abcdefghijklmnopqrstuvwxyz" +-- +sample :: (Storable a) => Int -> (Int -> a) -> Vector a +sample n f = + fst $ unfoldrN n (\i -> Just (f i, succ i)) 0 +{-# INLINE sample #-} + + +-- --------------------------------------------------------------------- +-- Substrings + +-- | /O(1)/ 'take' @n@, applied to a 'Vector' @xs@, returns the prefix +-- of @xs@ of length @n@, or @xs@ itself if @n > 'length' xs@. +take :: (Storable a) => Int -> Vector a -> Vector a +take n ps@(SV x s l) + | n <= 0 = empty + | n >= l = ps + | otherwise = SV x s n +{-# INLINE take #-} + +-- | /O(1)/ 'drop' @n xs@ returns the suffix of @xs@ after the first @n@ +-- elements, or 'empty' if @n > 'length' xs@. +drop :: (Storable a) => Int -> Vector a -> Vector a +drop n ps@(SV x s l) + | n <= 0 = ps + | n >= l = empty + | otherwise = SV x (s+n) (l-n) +{-# INLINE drop #-} + +-- | /O(1)/ 'splitAt' @n xs@ is equivalent to @('take' n xs, 'drop' n xs)@. +splitAt :: (Storable a) => Int -> Vector a -> (Vector a, Vector a) +splitAt n ps@(SV x s l) + | n <= 0 = (empty, ps) + | n >= l = (ps, empty) + | otherwise = (SV x s n, SV x (s+n) (l-n)) +{-# INLINE splitAt #-} + +-- | 'takeWhile', applied to a predicate @p@ and a 'Vector' @xs@, +-- returns the longest prefix (possibly empty) of @xs@ of elements that +-- satisfy @p@. +takeWhile :: (Storable a) => (a -> Bool) -> Vector a -> Vector a +takeWhile f ps = unsafeTake (findIndexOrEnd (not . f) ps) ps +{-# INLINE takeWhile #-} + +-- | 'dropWhile' @p xs@ returns the suffix remaining after 'takeWhile' @p xs@. +dropWhile :: (Storable a) => (a -> Bool) -> Vector a -> Vector a +dropWhile f ps = unsafeDrop (findIndexOrEnd (not . f) ps) ps +{-# INLINE dropWhile #-} + +-- | 'break' @p@ is equivalent to @'span' ('not' . p)@. +break :: (Storable a) => (a -> Bool) -> Vector a -> (Vector a, Vector a) +break p ps = case findIndexOrEnd p ps of n -> (unsafeTake n ps, unsafeDrop n ps) +{-# INLINE break #-} + +-- | 'breakEnd' behaves like 'break' but from the end of the 'Vector' +-- +-- breakEnd p == spanEnd (not.p) +breakEnd :: (Storable a) => (a -> Bool) -> Vector a -> (Vector a, Vector a) +breakEnd p ps = splitAt (findFromEndUntil p ps) ps + +-- | 'span' @p xs@ breaks the 'Vector' into two segments. It is +-- equivalent to @('takeWhile' p xs, 'dropWhile' p xs)@ +span :: (Storable a) => (a -> Bool) -> Vector a -> (Vector a, Vector a) +span p ps = break (not . p) ps +{-# INLINE span #-} + +-- | 'spanEnd' behaves like 'span' but from the end of the 'Vector'. +-- We have +-- +-- > spanEnd (not.isSpace) "x y z" == ("x y ","z") +-- +-- and +-- +-- > spanEnd (not . isSpace) ps +-- > == +-- > let (x,y) = span (not.isSpace) (reverse ps) in (reverse y, reverse x) +-- +spanEnd :: (Storable a) => (a -> Bool) -> Vector a -> (Vector a, Vector a) +spanEnd p ps = splitAt (findFromEndUntil (not.p) ps) ps + +-- | /O(n)/ Splits a 'Vector' into components delimited by +-- separators, where the predicate returns True for a separator element. +-- The resulting components do not contain the separators. Two adjacent +-- separators result in an empty component in the output. eg. +-- +-- > splitWith (=='a') "aabbaca" == ["","","bb","c",""] +-- > splitWith (=='a') [] == [] +-- +splitWith :: (Storable a) => (a -> Bool) -> Vector a -> [Vector a] +splitWith _ (SV _ _ 0) = [] +splitWith p ps = loop ps + where + loop = + uncurry (:) . + mapSnd (switchL [] (\ _ t -> loop t)) . + break p +{-# INLINE splitWith #-} + +-- | /O(n)/ Break a 'Vector' into pieces separated by the +-- argument, consuming the delimiter. I.e. +-- +-- > split '\n' "a\nb\nd\ne" == ["a","b","d","e"] +-- > split 'a' "aXaXaXa" == ["","X","X","X"] +-- > split 'x' "x" == ["",""] +-- +-- and +-- +-- > join [c] . split c == id +-- > split == splitWith . (==) +-- +-- As for all splitting functions in this library, this function does +-- not copy the substrings, it just constructs new 'Vector's that +-- are slices of the original. +-- +split :: (Storable a, Eq a) => a -> Vector a -> [Vector a] +split w v = splitWith (w==) v +{-# INLINE split #-} + +-- | Like 'splitWith', except that sequences of adjacent separators are +-- treated as a single separator. eg. +-- +-- > tokens (=='a') "aabbaca" == ["bb","c"] +-- +tokens :: (Storable a) => (a -> Bool) -> Vector a -> [Vector a] +tokens f = P.filter (not.null) . splitWith f +{-# INLINE tokens #-} + +-- | The 'group' function takes a 'Vector' and returns a list of +-- 'Vector's such that the concatenation of the result is equal to the +-- argument. Moreover, each sublist in the result contains only equal +-- elements. For example, +-- +-- > group "Mississippi" = ["M","i","ss","i","ss","i","pp","i"] +-- +-- It is a special case of 'groupBy', which allows the programmer to +-- supply their own equality test. It is about 40% faster than +-- /groupBy (==)/ +group :: (Storable a, Eq a) => Vector a -> [Vector a] +group xs = + switchL [] + (\ h _ -> + let (ys, zs) = span (== h) xs + in ys : group zs) + xs + +-- | The 'groupBy' function is the non-overloaded version of 'group'. +groupBy :: (Storable a) => (a -> a -> Bool) -> Vector a -> [Vector a] +groupBy k xs = + switchL [] + (\ h t -> + let n = 1 + findIndexOrEnd (not . k h) t + in unsafeTake n xs : groupBy k (unsafeDrop n xs)) + xs +{-# INLINE groupBy #-} + + +-- | /O(n)/ The 'join' function takes a 'Vector' and a list of +-- 'Vector's and concatenates the list after interspersing the first +-- argument between each element of the list. +join :: (Storable a) => Vector a -> [Vector a] -> Vector a +join s = concat . List.intersperse s +{-# INLINE join #-} + +-- --------------------------------------------------------------------- +-- Indexing 'Vector's + +-- | /O(1)/ 'Vector' index (subscript) operator, starting from 0. +index :: (Storable a) => Vector a -> Int -> a +index ps n + | n < 0 = moduleError "index" ("negative index: " ++ show n) + | n >= length ps = moduleError "index" ("index too large: " ++ show n + ++ ", length = " ++ show (length ps)) + | otherwise = ps `unsafeIndex` n +{-# INLINE index #-} + +-- | /O(n)/ The 'elemIndex' function returns the index of the first +-- element in the given 'Vector' which is equal to the query +-- element, or 'Nothing' if there is no such element. +elemIndex :: (Storable a, Eq a) => a -> Vector a -> Maybe Int +elemIndex c = findIndex (c==) +{-# INLINE elemIndex #-} + +-- | /O(n)/ The 'elemIndexEnd' function returns the last index of the +-- element in the given 'Vector' which is equal to the query +-- element, or 'Nothing' if there is no such element. The following +-- holds: +-- +-- > elemIndexEnd c xs == +-- > (-) (length xs - 1) `fmap` elemIndex c (reverse xs) +-- +elemIndexEnd :: (Storable a, Eq a) => a -> Vector a -> Maybe Int +elemIndexEnd c = + fst . + foldl + (\(ri,i) x -> (if c==x then Just i else ri, succ i)) + (Nothing,0) +{-# INLINE elemIndexEnd #-} + +-- | /O(n)/ The 'elemIndices' function extends 'elemIndex', by returning +-- the indices of all elements equal to the query element, in ascending order. +elemIndices :: (Storable a, Eq a) => a -> Vector a -> [Int] +elemIndices c = findIndices (c==) +{-# INLINE elemIndices #-} + +-- | count returns the number of times its argument appears in the 'Vector' +-- +-- > count = length . elemIndices +-- +-- But more efficiently than using length on the intermediate list. +count :: (Storable a, Eq a) => a -> Vector a -> Int +count w = + foldl (flip $ \c -> if c==w then succ else id) 0 +{- +count w sv = + List.length $ elemIndices w sv +-} +{-# INLINE count #-} + +-- | The 'findIndex' function takes a predicate and a 'Vector' and +-- returns the index of the first element in the 'Vector' +-- satisfying the predicate. +findIndex :: (Storable a) => (a -> Bool) -> Vector a -> Maybe Int +findIndex p xs = + {- The implementation is in principle the same as for findIndices, + but we use the First monoid, instead of the List/append monoid. + We could also implement findIndex in terms of monoidConcatMap. -} + foldr + (\x k n -> + toMaybe (p x) n `mplus` k (succ n)) + (const Nothing) xs 0 +{-# INLINE findIndex #-} + +-- | The 'findIndices' function extends 'findIndex', by returning the +-- indices of all elements satisfying the predicate, in ascending order. +findIndices :: (Storable a) => (a -> Bool) -> Vector a -> [Int] +findIndices p xs = + foldr + (\x k n -> + (if p x then (n:) else id) + (k (succ n))) + (const []) xs 0 +{-# INLINE findIndices #-} + +-- | 'findIndexOrEnd' is a variant of findIndex, that returns the length +-- of the string if no element is found, rather than Nothing. +findIndexOrEnd :: (Storable a) => (a -> Bool) -> Vector a -> Int +findIndexOrEnd p xs = + foldr + (\x k n -> + if p x then n else k (succ n)) + id xs 0 +{-# INLINE findIndexOrEnd #-} + +-- --------------------------------------------------------------------- +-- Searching Vectors + +-- | /O(n)/ 'elem' is the 'Vector' membership predicate. +elem :: (Storable a, Eq a) => a -> Vector a -> Bool +elem c ps = isJust $ elemIndex c ps +{-# INLINE elem #-} + +-- | /O(n)/ 'notElem' is the inverse of 'elem' +notElem :: (Storable a, Eq a) => a -> Vector a -> Bool +notElem c ps = not (elem c ps) +{-# INLINE notElem #-} + +-- | /O(n)/ 'filter', applied to a predicate and a 'Vector', +-- returns a 'Vector' containing those elements that satisfy the +-- predicate. This function is subject to array fusion. +filter :: (Storable a) => (a -> Bool) -> Vector a -> Vector a +filter p (SV fp s l) = + let end = s+l + in fst $ + unfoldrN l + (let go = Strict.arguments1 $ \k0 -> + do guard (k0 find f p = case findIndex f p of Just n -> Just (p ! n) ; _ -> Nothing +-- +find :: (Storable a) => (a -> Bool) -> Vector a -> Maybe a +find f p = fmap (unsafeIndex p) (findIndex f p) +{-# INLINE find #-} + +-- --------------------------------------------------------------------- +-- Searching for substrings + +-- | /O(n)/ The 'isPrefixOf' function takes two 'Vector' and returns 'True' +-- iff the first is a prefix of the second. +isPrefixOf :: (Storable a, Eq a) => Vector a -> Vector a -> Bool +isPrefixOf x@(SV _ _ l1) y@(SV _ _ l2) = + l1 <= l2 && x == unsafeTake l1 y + +-- | /O(n)/ The 'isSuffixOf' function takes two 'Vector's and returns 'True' +-- iff the first is a suffix of the second. +-- +-- The following holds: +-- +-- > isSuffixOf x y == reverse x `isPrefixOf` reverse y +-- +isSuffixOf :: (Storable a, Eq a) => Vector a -> Vector a -> Bool +isSuffixOf x@(SV _ _ l1) y@(SV _ _ l2) = + l1 <= l2 && x == unsafeDrop (l2 - l1) y + +-- --------------------------------------------------------------------- +-- Zipping + +-- | /O(n)/ 'zip' takes two 'Vector's and returns a list of +-- corresponding pairs of elements. If one input 'Vector' is short, +-- excess elements of the longer 'Vector' are discarded. This is +-- equivalent to a pair of 'unpack' operations. +zip :: (Storable a, Storable b) => Vector a -> Vector b -> [(a, b)] +zip ps qs = + maybe [] id $ + do (ph,pt) <- viewL ps + (qh,qt) <- viewL qs + return ((ph,qh) : zip pt qt) + +-- | 'zipWith' generalises 'zip' by zipping with the function given as +-- the first argument, instead of a tupling function. For example, +-- @'zipWith' (+)@ is applied to two 'Vector's to produce the list of +-- corresponding sums. +zipWith :: (Storable a, Storable b, Storable c) => + (a -> b -> c) -> Vector a -> Vector b -> Vector c +zipWith f as bs = + unsafeWithStartPtr as $ \pa0 la -> + withStartPtr bs $ \pb0 lb -> + let len = min la lb + in create len $ \p0 -> + let go = Strict.arguments4 $ \n p pa pb -> + when (n>0) $ + liftM2 f (peek pa) (peek pb) >>= poke p >> + go (pred n) (incPtr p) (incPtr pa) (incPtr pb) + in go len p0 pa0 pb0 + + +-- zipWith f ps qs = pack $ List.zipWith f (unpack ps) (unpack qs) +{-# INLINE zipWith #-} + +-- | Like 'zipWith' but for three input vectors +zipWith3 :: (Storable a, Storable b, Storable c, Storable d) => + (a -> b -> c -> d) -> Vector a -> Vector b -> Vector c -> Vector d +zipWith3 f as bs cs = + unsafeWithStartPtr as $ \pa0 la -> + withStartPtr bs $ \pb0 lb -> + withStartPtr cs $ \pc0 lc -> + let len = la `min` lb `min` lc + in create len $ \p0 -> + let go = Strict.arguments5 $ \n p pa pb pc -> + when (n>0) $ + liftM3 f (peek pa) (peek pb) (peek pc) >>= poke p >> + go (pred n) (incPtr p) (incPtr pa) (incPtr pb) (incPtr pc) + in go len p0 pa0 pb0 pc0 +{-# INLINE zipWith3 #-} + +-- | Like 'zipWith' but for four input vectors +-- If you need even more input vectors, +-- you might write a function yourselve using unfoldrN and viewL. +zipWith4 :: (Storable a, Storable b, Storable c, Storable d, Storable e) => + (a -> b -> c -> d -> e) -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e +zipWith4 f as bs cs ds = + unsafeWithStartPtr as $ \pa0 la -> + withStartPtr bs $ \pb0 lb -> + withStartPtr cs $ \pc0 lc -> + withStartPtr ds $ \pd0 ld -> + let len = la `min` lb `min` lc `min` ld + in create len $ \p0 -> + let go = + Strict.arguments2 $ \n p -> + Strict.arguments4 $ \pa pb pc pd -> + when (n>0) $ + liftM4 f (peek pa) (peek pb) (peek pc) (peek pd) >>= poke p >> + go (pred n) (incPtr p) (incPtr pa) (incPtr pb) (incPtr pc) (incPtr pd) + in go len p0 pa0 pb0 pc0 pd0 +{-# INLINE zipWith4 #-} + +-- | /O(n)/ 'unzip' transforms a list of pairs of elements into a pair of +-- 'Vector's. Note that this performs two 'pack' operations. +unzip :: (Storable a, Storable b) => [(a, b)] -> (Vector a, Vector b) +unzip ls = (pack (P.map fst ls), pack (P.map snd ls)) +{-# INLINE unzip #-} + +-- --------------------------------------------------------------------- +-- Interleaved 'Vector's + +-- | /O(l/n)/ 'sieve' selects every 'n'th element. +sieve :: (Storable a) => Int -> Vector a -> Vector a +sieve n (SV fp s l) = + let end = s+l + in fst $ + unfoldrN (- div (-l) n) + (Strict.arguments1 $ \k0 -> + do guard (k0 Int -> Vector a -> [Vector a] +deinterleave n = + P.map (sieve n) . P.take n . P.iterate laxTail + +-- | /O(n)/ +-- Almost the inverse of deinterleave. +-- Restriction is that all input vector must have equal length. +-- @interleave [pack "adgj", pack "behk", pack "cfil"] = pack ['a'..'l']@ +interleave :: (Storable a) => [Vector a] -> Vector a +interleave vs = + Unsafe.performIO $ + MC.runContT + (do + pls <- mapM (\v -> MC.ContT (withStartPtr v . curry)) vs + let (ps,ls) = P.unzip pls + ptrs <- MC.ContT (withArray ps) + if and (ListHT.mapAdjacent (==) ls) + then return (ptrs, P.sum ls) + else moduleError "interleave" "all input vectors must have the same length") + (\(ptrs, totalLength) -> create totalLength $ \p -> + let n = P.length vs + pEnd = advancePtr p totalLength + go = Strict.arguments3 $ \k0 j p0 -> do + poke p0 =<< flip peekElemOff j =<< peekElemOff ptrs k0 + let p1 = advancePtr p0 1 + k1 = succ k0 + when (p1 < pEnd) $ + if k1 < n + then go k1 j p1 + else go 0 (succ j) p1 + in go 0 0 p) +{-# INLINE interleave #-} + + +-- --------------------------------------------------------------------- +-- Special lists + +-- | /O(n)/ Return all initial segments of the given 'Vector', shortest first. +inits :: (Storable a) => Vector a -> [Vector a] +inits (SV x s l) = List.map (SV x s) [0..l] + +-- | /O(n)/ Return all final segments of the given 'Vector', longest first. +tails :: (Storable a) => Vector a -> [Vector a] +tails p = + switchL [empty] (\ _ t -> p : tails t) p + +-- --------------------------------------------------------------------- +-- ** Ordered 'Vector's + +-- --------------------------------------------------------------------- +-- Low level constructors + +-- | /O(n)/ Make a copy of the 'Vector' with its own storage. +-- This is mainly useful to allow the rest of the data pointed +-- to by the 'Vector' to be garbage collected, for example +-- if a large string has been read in, and only a small part of it +-- is needed in the rest of the program. +copy :: (Storable a) => Vector a -> Vector a +copy v = + unsafeWithStartPtr v $ \f l -> + create l $ \p -> + copyArray p f (fromIntegral l) + + + +-- --------------------------------------------------------------------- +-- IO + +-- | Outputs a 'Vector' to the specified 'Handle'. +hPut :: (Storable a) => Handle -> Vector a -> IO () +hPut h v = + when (not (null v)) $ + withStartPtr v $ \ ptrS l -> + let ptrE = advancePtr ptrS l + -- use advancePtr and minusPtr in order to respect alignment + in hPutBuf h ptrS (minusPtr ptrE ptrS) + +-- | Read a 'Vector' directly from the specified 'Handle'. This +-- is far more efficient than reading the characters into a list +-- and then using 'pack'. +-- +hGet :: (Storable a) => Handle -> Int -> IO (Vector a) +hGet _ 0 = return empty +hGet h l = + createAndTrim l $ \p -> + let elemType :: Ptr a -> a + elemType _ = undefined + roundUp m n = n + mod (-n) m + sizeOfElem = + roundUp + (alignment (elemType p)) + (sizeOf (elemType p)) + in fmap (flip div sizeOfElem) $ + hGetBuf h p (l * sizeOfElem) +{- + createAndTrim l $ \p -> + fmap (flip div (incPtr p `minusPtr` p)) $ + hGetBuf h p (advancePtr p l `minusPtr` p) +-} + +-- | Read an entire file strictly into a 'Vector'. This is far more +-- efficient than reading the characters into a 'String' and then using +-- 'pack'. It also may be more efficient than opening the file and +-- reading it using hGet. Files are read using 'binary mode' on Windows. +-- +readFile :: (Storable a) => FilePath -> IO (Vector a) +readFile f = + bracket (openBinaryFile f ReadMode) hClose + (\h -> hGet h . fromIntegral =<< hFileSize h) + +-- | Write a 'Vector' to a file. +writeFile :: (Storable a) => FilePath -> Vector a -> IO () +writeFile f txt = + bracket (openBinaryFile f WriteMode) hClose + (\h -> hPut h txt) + +-- | Append a 'Vector' to a file. +appendFile :: (Storable a) => FilePath -> Vector a -> IO () +appendFile f txt = + bracket (openBinaryFile f AppendMode) hClose + (\h -> hPut h txt) + + +-- --------------------------------------------------------------------- +-- Internal utilities + + +-- These definitions of succ and pred do not check for overflow +-- and are faster than their counterparts from Enum class. +succ :: Int -> Int +succ n = n+1 +{-# INLINE succ #-} + +pred :: Int -> Int +pred n = n-1 +{-# INLINE pred #-} + +unsafeWithStartPtr :: Storable a => Vector a -> (Ptr a -> Int -> IO b) -> b +unsafeWithStartPtr v f = + Unsafe.performIO (withStartPtr v f) +{-# INLINE unsafeWithStartPtr #-} + +foreignPeek :: Storable a => ForeignPtr a -> Int -> a +foreignPeek fp k = + inlinePerformIO $ withForeignPtr fp $ flip peekElemOff k +{-# INLINE foreignPeek #-} + +withNonEmptyVector :: + String -> (ForeignPtr a -> Int -> Int -> b) -> Vector a -> b +withNonEmptyVector fun f (SV x s l) = + if l <= 0 + then errorEmpty fun + else f x s l +{-# INLINE withNonEmptyVector #-} + +-- Common up near identical calls to `error' to reduce the number +-- constant strings created when compiled: +errorEmpty :: String -> a +errorEmpty fun = moduleError fun "empty Vector" +{-# NOINLINE errorEmpty #-} + +moduleError :: String -> String -> a +moduleError fun msg = error ("Data.StorableVector." ++ fun ++ ':':' ':msg) +{-# NOINLINE moduleError #-} + +-- Find from the end of the string using predicate +findFromEndUntil :: (Storable a) => (a -> Bool) -> Vector a -> Int +findFromEndUntil = Strict.arguments2 $ \f ps@(SV x s l) -> + if null ps then 0 + else if f (last ps) then l + else findFromEndUntil f (SV x s (l-1)) diff --git a/src/Data/StorableVector/Base.hs b/src/Data/StorableVector/Base.hs new file mode 100644 --- /dev/null +++ b/src/Data/StorableVector/Base.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE DeriveDataTypeable #-} +-- +-- Module : Data.StorableVector.Base +-- License : BSD-style +-- Maintainer : dons@cse.unsw.edu.au +-- Stability : experimental +-- Portability : portable, requires ffi and cpp +-- Tested with : GHC 6.4.1 and Hugs March 2005 +-- + +-- | A module containing semi-public StorableVector internals. This exposes +-- the StorableVector representation and low level construction functions. +-- Modules which extend the StorableVector system will need to use this module +-- while ideally most users will be able to make do with the public interface +-- modules. +-- +module Data.StorableVector.Base ( + + -- * The @Vector@ type and representation + Vector(..), -- instances: Eq, Ord, Show, Read, Data, Typeable + + -- * Unchecked access + unsafeHead, -- :: Vector a -> a + unsafeTail, -- :: Vector a -> Vector a + unsafeLast, -- :: Vector a -> a + unsafeInit, -- :: Vector a -> Vector a + unsafeIndex, -- :: Vector a -> Int -> a + unsafeTake, -- :: Int -> Vector a -> Vector a + unsafeDrop, -- :: Int -> Vector a -> Vector a + + -- * Low level introduction and elimination + create, -- :: Int -> (Ptr a -> IO ()) -> IO (Vector a) + createAndTrim, -- :: Int -> (Ptr a -> IO Int) -> IO (Vector a) + createAndTrim', -- :: Int -> (Ptr a -> IO (Int, Int, b)) -> IO (Vector a, b) + + unsafeCreate, -- :: Int -> (Ptr a -> IO ()) -> Vector a + + fromForeignPtr, -- :: ForeignPtr a -> Int -> Vector a + toForeignPtr, -- :: Vector a -> (ForeignPtr a, Int, Int) + withStartPtr, -- :: Vector a -> (Ptr a -> Int -> IO b) -> IO b + incPtr, -- :: Ptr a -> Ptr a + + inlinePerformIO + + ) where + +import Foreign.Ptr (Ptr) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, ) +import Foreign.Marshal.Array (advancePtr, copyArray) +import Foreign.Storable (Storable(peekElemOff)) + +import Data.StorableVector.Memory (mallocForeignPtrArray, ) + +import Control.Exception (assert) + +#if defined(__GLASGOW_HASKELL__) +import Data.Generics (Data, Typeable) +import GHC.Base (realWorld#) +import GHC.IO (IO(IO), ) +#endif + +import qualified System.Unsafe as Unsafe + +-- CFILES stuff is Hugs only +{-# CFILES cbits/fpstring.c #-} + +-- ----------------------------------------------------------------------------- + +-- | A space-efficient representation of a vector, supporting many efficient +-- operations. +-- +-- Instances of Eq, Ord, Read, Show, Data, Typeable +-- +data Vector a = SV {-# UNPACK #-} !(ForeignPtr a) + {-# UNPACK #-} !Int -- offset + {-# UNPACK #-} !Int -- length +#if defined(__GLASGOW_HASKELL__) + deriving (Data, Typeable) +#endif + +-- --------------------------------------------------------------------- +-- +-- Extensions to the basic interface +-- + +-- | A variety of 'head' for non-empty Vectors. 'unsafeHead' omits the +-- check for the empty case, so there is an obligation on the programmer +-- to provide a proof that the Vector is non-empty. +unsafeHead :: (Storable a) => Vector a -> a +unsafeHead (SV x s l) = assert (l > 0) $ + inlinePerformIO $ withForeignPtr x $ \p -> peekElemOff p s +{-# INLINE unsafeHead #-} + +-- | A variety of 'tail' for non-empty Vectors. 'unsafeTail' omits the +-- check for the empty case. As with 'unsafeHead', the programmer must +-- provide a separate proof that the Vector is non-empty. +unsafeTail :: (Storable a) => Vector a -> Vector a +unsafeTail (SV ps s l) = assert (l > 0) $ SV ps (s+1) (l-1) +{-# INLINE unsafeTail #-} + +-- | A variety of 'last' for non-empty Vectors. 'unsafeLast' omits the +-- check for the empty case, so there is an obligation on the programmer +-- to provide a proof that the Vector is non-empty. +unsafeLast :: (Storable a) => Vector a -> a +unsafeLast (SV x s l) = assert (l > 0) $ + inlinePerformIO $ withForeignPtr x $ \p -> peekElemOff p (s+l-1) +{-# INLINE unsafeLast #-} + +-- | A variety of 'init' for non-empty Vectors. 'unsafeInit' omits the +-- check for the empty case. As with 'unsafeLast', the programmer must +-- provide a separate proof that the Vector is non-empty. +unsafeInit :: (Storable a) => Vector a -> Vector a +unsafeInit (SV ps s l) = assert (l > 0) $ SV ps s (l-1) +{-# INLINE unsafeInit #-} + +-- | Unsafe 'Vector' index (subscript) operator, starting from 0, returning a +-- single element. This omits the bounds check, which means there is an +-- accompanying obligation on the programmer to ensure the bounds are checked in +-- some other way. +unsafeIndex :: (Storable a) => Vector a -> Int -> a +unsafeIndex (SV x s l) i = assert (i >= 0 && i < l) $ + inlinePerformIO $ withForeignPtr x $ \p -> peekElemOff p (s+i) +{-# INLINE unsafeIndex #-} + +-- | A variety of 'take' which omits the checks on @n@ so there is an +-- obligation on the programmer to provide a proof that @0 <= n <= 'length' xs@. +unsafeTake :: (Storable a) => Int -> Vector a -> Vector a +unsafeTake n (SV x s l) = assert (0 <= n && n <= l) $ SV x s n +{-# INLINE unsafeTake #-} + +-- | A variety of 'drop' which omits the checks on @n@ so there is an +-- obligation on the programmer to provide a proof that @0 <= n <= 'length' xs@. +unsafeDrop :: (Storable a) => Int -> Vector a -> Vector a +unsafeDrop n (SV x s l) = assert (0 <= n && n <= l) $ SV x (s+n) (l-n) +{-# INLINE unsafeDrop #-} + + +instance (Storable a, Show a) => Show (Vector a) where + showsPrec p xs@(SV _ _ l) = + showParen (p>=10) + (showString "Vector.pack " . + showsPrec 10 (map (unsafeIndex xs) [0..(l-1)])) + + +-- --------------------------------------------------------------------- +-- Low level constructors + +-- | /O(1)/ Build a Vector from a ForeignPtr +fromForeignPtr :: ForeignPtr a -> Int -> Vector a +fromForeignPtr fp l = SV fp 0 l + +-- | /O(1)/ Deconstruct a ForeignPtr from a Vector +toForeignPtr :: Vector a -> (ForeignPtr a, Int, Int) +toForeignPtr (SV ps s l) = (ps, s, l) + +-- | Run an action that is initialized +-- with a pointer to the first element to be used. +withStartPtr :: Storable a => Vector a -> (Ptr a -> Int -> IO b) -> IO b +withStartPtr (SV x s l) f = + withForeignPtr x $ \p -> f (p `advancePtr` s) l +{-# INLINE withStartPtr #-} + +incPtr :: (Storable a) => Ptr a -> Ptr a +incPtr v = advancePtr v 1 +{-# INLINE incPtr #-} + +-- | A way of creating Vectors outside the IO monad. The @Int@ +-- argument gives the final size of the Vector. Unlike +-- 'createAndTrim' the Vector is not reallocated if the final size +-- is less than the estimated size. +unsafeCreate :: (Storable a) => Int -> (Ptr a -> IO ()) -> Vector a +unsafeCreate l f = Unsafe.performIO (create l f) +{-# INLINE unsafeCreate #-} + +-- | Wrapper of mallocForeignPtrArray. +create :: (Storable a) => Int -> (Ptr a -> IO ()) -> IO (Vector a) +create l f = do + fp <- mallocForeignPtrArray l + withForeignPtr fp $ \p -> f p + return $! SV fp 0 l + +-- | Given the maximum size needed and a function to make the contents +-- of a Vector, createAndTrim makes the 'Vector'. The generating +-- function is required to return the actual final size (<= the maximum +-- size), and the resulting byte array is realloced to this size. +-- +-- createAndTrim is the main mechanism for creating custom, efficient +-- Vector functions, using Haskell or C functions to fill the space. +-- +createAndTrim :: (Storable a) => Int -> (Ptr a -> IO Int) -> IO (Vector a) +createAndTrim l f = do + fp <- mallocForeignPtrArray l + withForeignPtr fp $ \p -> do + l' <- f p + if assert (l' <= l) $ l' >= l + then return $! SV fp 0 l + else create l' $ \p' -> copyArray p' p l' + +createAndTrim' :: (Storable a) => Int + -> (Ptr a -> IO (Int, Int, b)) + -> IO (Vector a, b) +createAndTrim' l f = do + fp <- mallocForeignPtrArray l + withForeignPtr fp $ \p -> do + (off, l', res) <- f p + if assert (l' <= l) $ l' >= l + then return $! (SV fp 0 l, res) + else do ps <- create l' $ \p' -> copyArray p' (p `advancePtr` off) l' + return $! (ps, res) + +-- | Just like Unsafe.performIO, but we inline it. Big performance gains as +-- it exposes lots of things to further inlining. /Very unsafe/. In +-- particular, you should do no memory allocation inside an +-- 'inlinePerformIO' block. On Hugs this is just @Unsafe.performIO@. +-- +{-# INLINE inlinePerformIO #-} +inlinePerformIO :: IO a -> a +#if defined(__GLASGOW_HASKELL__) +inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r +#else +inlinePerformIO = Unsafe.performIO +#endif diff --git a/src/Data/StorableVector/Cursor.hs b/src/Data/StorableVector/Cursor.hs new file mode 100644 --- /dev/null +++ b/src/Data/StorableVector/Cursor.hs @@ -0,0 +1,353 @@ +{-# LANGUAGE ExistentialQuantification #-} +{- | +Simulate a list with strict elements by a more efficient array structure. +-} +module Data.StorableVector.Cursor where + +import Control.Exception (assert, ) +import Control.Monad.Trans.State (StateT(StateT), runStateT, ) +import Data.IORef (IORef, newIORef, readIORef, writeIORef, ) + +import Foreign.Storable (Storable(peekElemOff, pokeElemOff)) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, ) +-- import Foreign.Ptr (Ptr) +import Data.StorableVector.Memory (mallocForeignPtrArray, ) + +import Control.Monad (when) +import Data.Maybe (isNothing) + +import qualified System.Unsafe as Unsafe + +import qualified Data.List.HT as ListHT +import Data.Tuple.HT (mapSnd, ) + +import Prelude hiding (length, foldr, zipWith, take, drop, ) + + +{- +ToDo: +I think that the state should be Storable as well +and that the IORef should be replaced by a ForeignPtr. +I hope that this is more efficient. +With this restriction @s@ cannot be e.g. a function type +but this would kill performance anyway. +Functions that need this flexibility may fall back to other data structures +(lists or chunky StorableVectors) and convert to the Cursor structure later. +-} +-- | Cf. StreamFusion Data.Stream +data Generator a = + forall s. -- Seq s => + Generator + !(StateT s Maybe a) -- compute next value + {-# UNPACK #-} + !(IORef (Maybe s)) -- current state + +{- | +This simulates a +@ data StrictList a = Elem !a (StrictList a) | End @ +by an array and some unsafe hacks. +-} +data Buffer a = + Buffer { + memory :: {-# UNPACK #-} !(ForeignPtr a), + size :: {-# UNPACK #-} !Int, -- size of allocated memory, I think I only need it for debugging + gen :: !(Generator a), -- we need this indirection for the existential type in Generator + cursor :: {-# UNPACK #-} !(IORef Int) + } + +{- | +Vector is a part of a buffer. +-} +data Vector a = + Vector { + buffer :: {-# UNPACK #-} !(Buffer a), + start :: {-# UNPACK #-} !Int, -- invariant: start <= cursor + maxLen :: {-# UNPACK #-} !Int -- invariant: start+maxLen <= size buffer + } + + +-- * construction + +{-# INLINE create #-} +create :: (Storable a) => Int -> Generator a -> Buffer a +create l g = Unsafe.performIO (createIO l g) + +-- | Wrapper of mallocForeignPtrArray. +createIO :: (Storable a) => Int -> Generator a -> IO (Buffer a) +createIO l g = do + fp <- mallocForeignPtrArray l + cur <- newIORef 0 + return $! Buffer fp l g cur + + +{- | +@ unfoldrNTerm 20 (\n -> Just (n, succ n)) 'a' @ +-} +unfoldrNTerm :: (Storable b) => + Int -> (a -> Maybe (b, a)) -> a -> Vector b +unfoldrNTerm l f x0 = + Unsafe.performIO (unfoldrNTermIO l f x0) + +unfoldrNTermIO :: (Storable b) => + Int -> (a -> Maybe (b, a)) -> a -> IO (Vector b) +unfoldrNTermIO l f x0 = + do ref <- newIORef (Just x0) + buf <- createIO l (Generator (StateT f) ref) + return (Vector buf 0 l) + +unfoldrN :: (Storable b) => + Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a) +unfoldrN l f x0 = + Unsafe.performIO (unfoldrNIO l f x0) + +unfoldrNIO :: (Storable b) => + Int -> (a -> Maybe (b, a)) -> a -> IO (Vector b, Maybe a) +unfoldrNIO l f x0 = + do ref <- newIORef (Just x0) + buf <- createIO l (Generator (StateT f) ref) + s <- Unsafe.interleaveIO $ + do evaluateToIO l buf + readIORef ref + return (Vector buf 0 l, s) +{- +unfoldrNIO :: (Storable b) => + Int -> (a -> Maybe (b, a)) -> a -> IO (Vector b, Maybe a) +unfoldrNIO l f x0 = + do y <- unfoldrNTermIO l f x0 +-- evaluateTo l y + let (Generator _ ref) = gen (buffer y) + s <- readIORef ref + return (y, s) + +Data/StorableVector/Cursor.hs:98:10: + My brain just exploded. + I can't handle pattern bindings for existentially-quantified constructors. + In the binding group + (Generator _ ref) = gen (buffer y) + In the definition of `unfoldrNIO': + unfoldrNIO l f x0 + = do + y <- unfoldrNTermIO l f x0 + let (Generator _ ref) = gen (buffer y) + s <- readIORef ref + return (y, s) +-} + + +{- +unfoldrN :: (Storable b) => + Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a) +unfoldrN i f x0 = + let y = unfoldrNTerm i f x0 + in (y, getFinalState y) + +getFinalState :: (Storable b) => + Vector b -> Maybe a +getFinalState y = + Unsafe.performIO $ + ... +-} + + +{-# INLINE pack #-} +pack :: (Storable a) => Int -> [a] -> Vector a +pack n = unfoldrNTerm n ListHT.viewL + + +{-# INLINE cons #-} +{- | +This is expensive and should not be used to construct lists iteratively! +A recursion-enabling 'cons' would be 'consN' +that allocates a buffer of given size, +initializes the leading cell and sets the buffer pointer to the next cell. +-} +cons :: Storable a => + a -> Vector a -> Vector a +cons x xs = + unfoldrNTerm (succ (maxLen xs)) + (\(mx0,xs0) -> + fmap (mapSnd ((,) Nothing)) $ + maybe + (viewL xs0) + (\x0 -> Just (x0, xs0)) + mx0) $ + (Just x, xs) + + +{-# INLINE zipWith #-} +zipWith :: (Storable a, Storable b, Storable c) => + (a -> b -> c) -> Vector a -> Vector b -> Vector c +zipWith f ps0 qs0 = + zipNWith (min (maxLen ps0) (maxLen qs0)) f ps0 qs0 + +-- zipWith f ps qs = pack $ List.zipWith f (unpack ps) (unpack qs) + +{-# INLINE zipNWith #-} +zipNWith :: (Storable a, Storable b, Storable c) => + Int -> (a -> b -> c) -> Vector a -> Vector b -> Vector c +zipNWith n f ps0 qs0 = + unfoldrNTerm n + (\(ps,qs) -> + do (ph,pt) <- viewL ps + (qh,qt) <- viewL qs + return (f ph qh, (pt,qt))) + (ps0,qs0) +{- +let f2 = zipNWith 15 (+) f0 f1; f1 = cons 1 f2; f0 = cons (0::Int) f1 in f0 + +*Data.StorableVector.Cursor> let xs = unfoldrNTerm 20 (\n -> Just (n, succ n)) (0::Int) +*Data.StorableVector.Cursor> let ys = unfoldrNTerm 20 (\n -> Just (n, 2*n)) (1::Int) +*Data.StorableVector.Cursor> zipWith (+) xs ys +-} + + + + +-- * inspection + +-- | evaluate next value in a buffer +advanceIO :: Storable a => + Buffer a -> IO (Maybe a) +advanceIO (Buffer p sz (Generator n s) cr) = + do c <- readIORef cr + assert (c < sz) $ + do writeIORef cr (succ c) + ms <- readIORef s + case ms of + Nothing -> return Nothing + Just s0 -> + case runStateT n s0 of + Nothing -> + writeIORef s Nothing >> + return Nothing + Just (a,s1) -> + writeIORef s (Just s1) >> + withForeignPtr p (\q -> pokeElemOff q c a) >> + return (Just a) + +{- +It is tempting to turn this into a simple loop without the IORefs. +This could be compiled to an efficient strict loop, +but it would fail if the vector content depends on its own, +like in @fix (consN 1000 'a')@. +-} +-- | evaluate all values up to a given position +evaluateToIO :: Storable a => + Int -> Buffer a -> IO () +evaluateToIO l buf@(Buffer _p _sz _g cr) = + whileM + (fmap ( m Bool -> m a -> m () +whileM p f = + let recourse = + do b <- p + when b (f >> recourse) + in recourse + +{-# INLINE switchL #-} +switchL :: Storable a => b -> (a -> Vector a -> b) -> Vector a -> b +switchL n j v = maybe n (uncurry j) (viewL v) + + +{- +If it returns False the list can be empty anyway. +-} +obviousNullIO :: Vector a -> IO Bool +obviousNullIO (Vector (Buffer _ _ (Generator _ s) _) _ ml) = + assert (ml >= 0) $ + do b <- readIORef s + return (ml == 0 || isNothing b) + +{- +obviousNullIO :: Vector a -> IO Bool +obviousNullIO (Vector (Buffer _ sz (Generator _ s) _) st _) = + do b <- readIORef s + return (st >= sz || isNothing b) +-} +-- assert (l >= 0) $ l <= 0 + +{-# INLINE viewL #-} +viewL :: Storable a => Vector a -> Maybe (a, Vector a) +viewL v = Unsafe.performIO (viewLIO v) + +{-# INLINE viewLIO #-} +viewLIO :: Storable a => Vector a -> IO (Maybe (a, Vector a)) +viewLIO (Vector buf st ml) = + do c <- readIORef (cursor buf) + fmap (fmap (\a -> (a, Vector buf (succ st) (pred ml)))) $ + assert (st <= c) $ + if st == c + then advanceIO buf + else fmap Just $ withForeignPtr (memory buf) (\p -> peekElemOff p st) + + +{-# INLINE foldr #-} +foldr :: (Storable a) => (a -> b -> b) -> b -> Vector a -> b +foldr k z = + let recourse = switchL z (\h t -> k h (recourse t)) + in recourse + +-- | /O(n)/ Converts a 'Vector a' to a '[a]'. +{-# INLINE unpack #-} +unpack :: (Storable a) => Vector a -> [a] +unpack = foldr (:) [] + + +instance (Show a, Storable a) => Show (Vector a) where + showsPrec p x = showsPrec p (unpack x) + + +{-# INLINE null #-} +{- +This can hardly be simplified. +In order to check the list for emptiness, +we have to try to calculate the next element. +It is not enough to check whether the state is Nothing, +because when we try to compute the next value, this can be Nothing. +-} +null :: Storable a => Vector a -> Bool +null = switchL True (const (const False)) + + +{- +toVector :: Storable a => Vector a -> VS.Vector a +toVector v = + VS.Cons (memory (buffer v)) () +-} + +-- length + +drop :: (Storable a) => Int -> Vector a -> Vector a +drop n v = Unsafe.performIO $ dropIO n v + +dropIO :: (Storable a) => Int -> Vector a -> IO (Vector a) +dropIO n v = + assert (n>=0) $ + let pos = min (maxLen v) (start v + n) + in do evaluateToIO pos (buffer v) + return (Vector (buffer v) pos (max 0 (maxLen v - n))) + +take :: (Storable a) => Int -> Vector a -> Vector a +take n v = + assert (n>=0) $ + v{maxLen = min n (maxLen v)} + +{- +let x = unfoldrNTerm 10 (\c -> Just (c,succ c)) 'a' +let x = unfoldrNTerm 10 (\c -> Just (sum [c..100000],succ c)) (0::Int) +-} + + +{- | +For the sake of laziness it may allocate considerably more memory than needed, +if it filters out very much. +-} +{-# INLINE filter #-} +filter :: (Storable a) => (a -> Bool) -> Vector a -> Vector a +filter p xs0 = + unfoldrNTerm (maxLen xs0) + (let recourse = switchL Nothing (\x xs -> if p x then Just (x,xs) else recourse xs) + in recourse) + xs0 diff --git a/src/Data/StorableVector/Lazy.hs b/src/Data/StorableVector/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/Data/StorableVector/Lazy.hs @@ -0,0 +1,1371 @@ +{- | +Chunky signal stream build on StorableVector. + +Hints for fusion: + - Higher order functions should always be inlined in the end + in order to turn them into machine loops + instead of calling a function in an inner loop. +-} +module Data.StorableVector.Lazy where + +import qualified Data.List as List +import qualified Data.StorableVector as V +import qualified Data.StorableVector.Base as VB +import qualified Data.StorableVector.Lazy.PointerPrivate as Ptr + +import qualified Numeric.NonNegative.Class as NonNeg + +import qualified Data.List.HT as ListHT +import Data.Tuple.HT (mapPair, mapFst, mapSnd, swap, ) +import Data.Maybe.HT (toMaybe, ) +import Data.Maybe (fromMaybe, ) + +import Foreign.Storable (Storable) + +import Data.Monoid (Monoid, mempty, mappend, mconcat, ) +-- import Control.Arrow ((***)) +import Control.Monad (liftM, liftM2, liftM3, liftM4, {- guard, -} ) + + +import System.IO (openBinaryFile, IOMode(WriteMode, ReadMode, AppendMode), + hClose, Handle) +import Control.Exception (bracket, catch, ) + +import qualified System.IO.Error as Exc +import qualified System.Unsafe as Unsafe + +import Test.QuickCheck (Arbitrary(..)) + + +{- +import Prelude hiding + (length, (++), concat, iterate, foldl, map, repeat, replicate, null, + zip, zipWith, zipWith3, drop, take, splitAt, takeWhile, dropWhile, reverse) +-} + +import qualified Prelude as P + +import Data.Either (Either(Left, Right), either, ) +import Data.Maybe (Maybe(Just, Nothing), maybe, ) +import Data.Function (const, flip, ($), (.), ) +import Data.Tuple (fst, snd, uncurry, ) +import Data.Bool (Bool(True,False), not, (&&), ) +import Data.Ord (Ord, (<), (>), (<=), (>=), min, max, ) +import Data.Eq (Eq, (==), ) +import Control.Monad (mapM_, fmap, (=<<), (>>=), (>>), return, ) +import Text.Show (Show, showsPrec, showParen, showString, show, ) +import Prelude + (IO, error, IOError, + FilePath, String, succ, + Num, Int, sum, (+), (-), divMod, mod, fromInteger, ) + + + +newtype Vector a = SV {chunks :: [V.Vector a]} + + +instance (Storable a) => Monoid (Vector a) where + mempty = empty + mappend = append + mconcat = concat + +instance (Storable a, Eq a) => Eq (Vector a) where + (==) = equal + +instance (Storable a, Show a) => Show (Vector a) where + showsPrec p xs = + showParen (p>=10) + (showString "VectorLazy.fromChunks " . + showsPrec 10 (chunks xs)) + +instance (Storable a, Arbitrary a) => Arbitrary (Vector a) where + arbitrary = liftM2 pack arbitrary arbitrary + + +-- for a list of chunk sizes see "Data.StorableVector.LazySize". +newtype ChunkSize = ChunkSize Int + deriving (Eq, Ord, Show) + +instance Arbitrary ChunkSize where + arbitrary = fmap (ChunkSize . max 1 . min 2048) arbitrary + +{- +ToDo: +Since non-negative-0.1 we have the Monoid superclass for NonNeg. +Maybe we do not need the Num instance anymore. +-} +instance Num ChunkSize where + (ChunkSize x) + (ChunkSize y) = + ChunkSize (x+y) + (-) = moduleError "ChunkSize.-" "intentionally unimplemented" + (*) = moduleError "ChunkSize.*" "intentionally unimplemented" + abs = moduleError "ChunkSize.abs" "intentionally unimplemented" + signum = moduleError "ChunkSize.signum" "intentionally unimplemented" + fromInteger = ChunkSize . fromInteger + +instance Monoid ChunkSize where + mempty = ChunkSize 0 + mappend (ChunkSize x) (ChunkSize y) = ChunkSize (x+y) + mconcat = ChunkSize . sum . List.map (\(ChunkSize c) -> c) + +instance NonNeg.C ChunkSize where + split = NonNeg.splitDefault (\(ChunkSize c) -> c) ChunkSize + +chunkSize :: Int -> ChunkSize +chunkSize x = + ChunkSize $ + if x>0 + then x + else moduleError "chunkSize" ("no positive number: " List.++ show x) + +defaultChunkSize :: ChunkSize +defaultChunkSize = + ChunkSize 1024 + + + +-- * Introducing and eliminating 'Vector's + +{-# INLINE empty #-} +empty :: (Storable a) => Vector a +empty = SV [] + +{-# INLINE singleton #-} +singleton :: (Storable a) => a -> Vector a +singleton x = SV [V.singleton x] + +fromChunks :: (Storable a) => [V.Vector a] -> Vector a +fromChunks = SV + +pack :: (Storable a) => ChunkSize -> [a] -> Vector a +pack size = unfoldr size ListHT.viewL + +unpack :: (Storable a) => Vector a -> [a] +unpack = List.concatMap V.unpack . chunks + + +{-# INLINE packWith #-} +packWith :: (Storable b) => ChunkSize -> (a -> b) -> [a] -> Vector b +packWith size f = + unfoldr size (fmap (mapFst f) . ListHT.viewL) + +{-# INLINE unpackWith #-} +unpackWith :: (Storable a) => (a -> b) -> Vector a -> [b] +unpackWith f = List.concatMap (V.unpackWith f) . chunks + + +{-# INLINE unfoldr #-} +unfoldr :: (Storable b) => + ChunkSize -> + (a -> Maybe (b,a)) -> + a -> + Vector b +unfoldr (ChunkSize size) f = + SV . + List.unfoldr (cancelNullVector . V.unfoldrN size f =<<) . + Just + +{- | +Example: + +> *Data.StorableVector.Lazy> unfoldrResult (ChunkSize 5) (\c -> if c>'z' then Left (Char.ord c) else Right (c, succ c)) 'a' +> (VectorLazy.fromChunks [Vector.pack "abcde",Vector.pack "fghij",Vector.pack "klmno",Vector.pack "pqrst",Vector.pack "uvwxy",Vector.pack "z"],123) +-} +{-# INLINE unfoldrResult #-} +unfoldrResult :: (Storable b) => + ChunkSize -> + (a -> Either c (b, a)) -> + a -> + (Vector b, c) +unfoldrResult (ChunkSize size) f = + let recourse a0 = + let (chunk, a1) = + V.unfoldrResultN size Right (either (Left . Left) Right . f) a0 + in either + ((,) (if V.null chunk then [] else [chunk])) + (mapFst (chunk :) . recourse) a1 + in mapFst SV . recourse + + +{-# INLINE sample #-} +sample :: (Storable a) => ChunkSize -> (Int -> a) -> Vector a +sample size f = + unfoldr size (\i -> Just (f i, succ i)) 0 + +{-# INLINE sampleN #-} +sampleN :: (Storable a) => ChunkSize -> Int -> (Int -> a) -> Vector a +sampleN size n f = + unfoldr size (\i -> toMaybe (i ChunkSize -> (a -> a) -> a -> Vector a +iterate size f = unfoldr size (\x -> Just (x, f x)) + +repeat :: Storable a => ChunkSize -> a -> Vector a +repeat (ChunkSize size) = + SV . List.repeat . V.replicate size + +cycle :: Storable a => Vector a -> Vector a +cycle = + SV . List.cycle . chunks + +replicate :: Storable a => ChunkSize -> Int -> a -> Vector a +replicate (ChunkSize size) n x = + let (numChunks, rest) = divMod n size + in append + (SV (List.replicate numChunks (V.replicate size x))) + (fromChunk (V.replicate rest x)) + + + + +-- * Basic interface + +{-# INLINE null #-} +null :: (Storable a) => Vector a -> Bool +null = List.null . chunks + +length :: Vector a -> Int +length = sum . List.map V.length . chunks + +equal :: (Storable a, Eq a) => Vector a -> Vector a -> Bool +equal (SV xs0) (SV ys0) = + let recourse (x:xs) (y:ys) = + let l = min (V.length x) (V.length y) + (xPrefix, xSuffix) = V.splitAt l x + (yPrefix, ySuffix) = V.splitAt l y + build z zs = + if V.null z then zs else z:zs + in xPrefix == yPrefix && + recourse (build xSuffix xs) (build ySuffix ys) + recourse [] [] = True + -- this requires that chunks will always be non-empty + recourse _ _ = False + in recourse xs0 ys0 + +index :: (Storable a) => Vector a -> Int -> a +index (SV xs) n = + if n < 0 + then + moduleError "index" + ("negative index: " List.++ show n) + else + List.foldr + (\x k m0 -> + let m1 = m0 - V.length x + in if m1 < 0 + then VB.unsafeIndex x m0 + else k m1) + (\m -> moduleError "index" + ("index too large: " List.++ show n + List.++ ", length = " List.++ show (n-m))) + xs n + + +{-# NOINLINE [0] cons #-} +cons :: Storable a => a -> Vector a -> Vector a +cons x = SV . (V.singleton x :) . chunks + +infixr 5 `append` + +{-# NOINLINE [0] append #-} +append :: Storable a => Vector a -> Vector a -> Vector a +append (SV xs) (SV ys) = SV (xs List.++ ys) + + +{- | +@extendL size x y@ +prepends the chunk @x@ and merges it with the first chunk of @y@ +if the total size is at most @size@. +This way you can prepend small chunks +while asserting a reasonable average size for chunks. +-} +extendL :: Storable a => ChunkSize -> V.Vector a -> Vector a -> Vector a +extendL (ChunkSize size) x (SV yt) = + SV $ + maybe + [x] + (\(y,ys) -> + if V.length x + V.length y <= size + then V.append x y : ys + else x:yt) + (ListHT.viewL yt) + + +concat :: (Storable a) => [Vector a] -> Vector a +concat = SV . List.concat . List.map chunks + + +-- * Transformations + +{-# INLINE map #-} +map :: (Storable x, Storable y) => + (x -> y) + -> Vector x + -> Vector y +map f = SV . List.map (V.map f) . chunks + + +reverse :: Storable a => Vector a -> Vector a +reverse = + SV . List.reverse . List.map V.reverse . chunks + + +-- * Reducing 'Vector's + +{-# INLINE foldl #-} +foldl :: Storable b => (a -> b -> a) -> a -> Vector b -> a +foldl f x0 = List.foldl (V.foldl f) x0 . chunks + +{-# INLINE foldl' #-} +foldl' :: Storable b => (a -> b -> a) -> a -> Vector b -> a +foldl' f x0 = List.foldl' (V.foldl f) x0 . chunks + +{-# INLINE foldr #-} +foldr :: Storable b => (b -> a -> a) -> a -> Vector b -> a +foldr f x0 = List.foldr (flip (V.foldr f)) x0 . chunks + + +{-# INLINE monoidConcatMap #-} +monoidConcatMap :: (Storable a, Monoid m) => (a -> m) -> Vector a -> m +monoidConcatMap f = + List.foldr (mappend . V.monoidConcatMap f) mempty . chunks + +{-# INLINE any #-} +any :: (Storable a) => (a -> Bool) -> Vector a -> Bool +any p = List.any (V.any p) . chunks + +{-# INLINE all #-} +all :: (Storable a) => (a -> Bool) -> Vector a -> Bool +all p = List.all (V.all p) . chunks + +maximum :: (Storable a, Ord a) => Vector a -> a +maximum = + List.maximum . List.map V.maximum . chunks +-- List.foldl1' max . List.map V.maximum . chunks + +minimum :: (Storable a, Ord a) => Vector a -> a +minimum = + List.minimum . List.map V.minimum . chunks +-- List.foldl1' min . List.map V.minimum . chunks + +{- +sum :: (Storable a, Num a) => Vector a -> a +sum = + List.sum . List.map V.sum . chunks + +product :: (Storable a, Num a) => Vector a -> a +product = + List.product . List.map V.product . chunks +-} + + +-- * inspecting a vector + +{-# INLINE pointer #-} +pointer :: Storable a => Vector a -> Ptr.Pointer a +pointer = Ptr.cons . chunks + +{-# INLINE viewL #-} +viewL :: Storable a => Vector a -> Maybe (a, Vector a) +viewL (SV xs0) = + do (x,xs) <- ListHT.viewL xs0 + (y,ys) <- V.viewL x + return (y, append (fromChunk ys) (SV xs)) + +{-# INLINE viewR #-} +viewR :: Storable a => Vector a -> Maybe (Vector a, a) +viewR (SV xs0) = + do xsp <- ListHT.viewR xs0 + let (xs,x) = xsp +{- + do ~(xs,x) <- ListHT.viewR xs0 +-} + let (ys,y) = fromMaybe (moduleError "viewR" "last chunk empty") (V.viewR x) + return (append (SV xs) (fromChunk ys), y) + +{-# INLINE switchL #-} +switchL :: Storable a => b -> (a -> Vector a -> b) -> Vector a -> b +switchL n j = + maybe n (uncurry j) . viewL + +{-# INLINE switchR #-} +switchR :: Storable a => b -> (Vector a -> a -> b) -> Vector a -> b +switchR n j = + maybe n (uncurry j) . viewR + + +{- +viewLSafe :: Storable a => Vector a -> Maybe (a, Vector a) +viewLSafe (SV xs0) = + -- dropWhile would be unnecessary if we require that all chunks are non-empty + do (x,xs) <- ListHT.viewL (List.dropWhile V.null xs0) + (y,ys) <- viewLVector x + return (y, append (fromChunk ys) (SV xs)) + +viewRSafe :: Storable a => Vector a -> Maybe (Vector a, a) +viewRSafe (SV xs0) = + -- dropWhile would be unnecessary if we require that all chunks are non-empty + do (xs,x) <- ListHT.viewR (dropWhileRev V.null xs0) + (ys,y) <- V.viewR x + return (append (SV xs) (fromChunk ys), y) +-} + + +{-# INLINE scanl #-} +scanl :: (Storable a, Storable b) => + (a -> b -> a) -> a -> Vector b -> Vector a +scanl f start = + cons start . snd . + mapAccumL (\acc -> (\b -> (b,b)) . f acc) start + +{-# INLINE mapAccumL #-} +mapAccumL :: (Storable a, Storable b) => + (acc -> a -> (acc, b)) -> acc -> Vector a -> (acc, Vector b) +mapAccumL f start = + mapSnd SV . + List.mapAccumL (V.mapAccumL f) start . + chunks + +{-# INLINE mapAccumR #-} +mapAccumR :: (Storable a, Storable b) => + (acc -> a -> (acc, b)) -> acc -> Vector a -> (acc, Vector b) +mapAccumR f start = + mapSnd SV . + List.mapAccumR (V.mapAccumR f) start . + chunks + +{-# INLINE crochetLChunk #-} +crochetLChunk :: (Storable x, Storable y) => + (x -> acc -> Maybe (y, acc)) + -> acc + -> V.Vector x + -> (V.Vector y, Maybe acc) +crochetLChunk f acc0 x0 = + mapSnd (fmap fst) $ + V.unfoldrN + (V.length x0) + (\(acc,xt) -> + do (x,xs) <- V.viewL xt + (y,acc') <- f x acc + return (y, (acc',xs))) + (acc0, x0) + +{-# INLINE crochetL #-} +crochetL :: (Storable x, Storable y) => + (x -> acc -> Maybe (y, acc)) + -> acc + -> Vector x + -> Vector y +crochetL f acc0 = + SV . List.unfoldr (\(xt,acc) -> + do (x,xs) <- ListHT.viewL xt + acc' <- acc + return $ mapSnd ((,) xs) $ crochetLChunk f acc' x) . + flip (,) (Just acc0) . + chunks + + + +-- * sub-vectors + +{-# INLINE take #-} +take :: (Storable a) => Int -> Vector a -> Vector a +{- this order of pattern matches is certainly the most lazy one +> take 4 (pack (chunkSize 2) $ "abcd" List.++ undefined) +VectorLazy.fromChunks [Vector.pack "ab",Vector.pack "cd"] +-} +take 0 _ = empty +take _ (SV []) = empty +take n (SV (x:xs)) = + let m = V.length x + in if m<=n + then SV $ (x:) $ chunks $ take (n-m) $ SV xs + else fromChunk (V.take n x) + +{- | +Take n values from the end of the vector in a memory friendly way. +@takeEnd n xs@ should perform the same as @drop (length xs - n) xs@, +but the latter one would have to materialise @xs@ completely. +In contrast to that +@takeEnd@ should hold only chunks of about @n@ elements at any time point. +-} +{-# INLINE takeEnd #-} +takeEnd :: (Storable a) => Int -> Vector a -> Vector a +takeEnd n xs = + -- cf. Pattern.drop + List.foldl (flip drop) xs $ List.map V.length $ chunks $ drop n xs + +{-# INLINE drop #-} +drop :: (Storable a) => Int -> Vector a -> Vector a +drop _ (SV []) = empty +drop n (SV (x:xs)) = + let m = V.length x + in if m<=n + then drop (n-m) (SV xs) + else SV (V.drop n x : xs) + +{-# INLINE splitAt #-} +splitAt :: (Storable a) => Int -> Vector a -> (Vector a, Vector a) +splitAt n0 = + {- this order of pattern matches is certainly the most lazy one + > splitAt 4 (pack (chunkSize 2) $ "abcd" List.++ undefined) + (VectorLazy.fromChunks [Vector.pack "ab",Vector.pack "cd"],VectorLazy.fromChunks *** Exception: Prelude.undefined + -} + let recourse 0 xs = ([], xs) + recourse _ [] = ([], []) + recourse n (x:xs) = + let m = V.length x + in if m<=n + then mapFst (x:) $ recourse (n-m) xs + else mapPair ((:[]), (:xs)) $ V.splitAt n x + in mapPair (SV, SV) . recourse n0 . chunks + + + +{-# INLINE dropMarginRem #-} +-- I have used this in an inner loop thus I prefer inlining +{- | +@dropMarginRem n m xs@ +drops at most the first @m@ elements of @xs@ +and ensures that @xs@ still contains @n@ elements. +Additionally returns the number of elements that could not be dropped +due to the margin constraint. +That is @dropMarginRem n m xs == (k,ys)@ implies @length xs - m == length ys - k@. +Requires @length xs >= n@. +-} +dropMarginRem :: (Storable a) => Int -> Int -> Vector a -> (Int, Vector a) +dropMarginRem n m xs = + List.foldl' + (\(mi,xsi) k -> (mi-k, drop k xsi)) + (m,xs) + (List.map V.length $ chunks $ take m $ drop n xs) + +{- +This implementation does only walk once through the dropped prefix. +It is maximally lazy and minimally space consuming. +-} +{-# INLINE dropMargin #-} +dropMargin :: (Storable a) => Int -> Int -> Vector a -> Vector a +dropMargin n m xs = + List.foldl' (flip drop) xs + (List.map V.length $ chunks $ take m $ drop n xs) + + + +{-# INLINE dropWhile #-} +dropWhile :: (Storable a) => (a -> Bool) -> Vector a -> Vector a +dropWhile _ (SV []) = empty +dropWhile p (SV (x:xs)) = + let y = V.dropWhile p x + in if V.null y + then dropWhile p (SV xs) + else SV (y:xs) + +{-# INLINE takeWhile #-} +takeWhile :: (Storable a) => (a -> Bool) -> Vector a -> Vector a +takeWhile _ (SV []) = empty +takeWhile p (SV (x:xs)) = + let y = V.takeWhile p x + in if V.length y < V.length x + then fromChunk y + else SV (x : chunks (takeWhile p (SV xs))) + + +{-# INLINE span #-} +span :: (Storable a) => (a -> Bool) -> Vector a -> (Vector a, Vector a) +span p = + let recourse [] = ([],[]) + recourse (x:xs) = + let (y,z) = V.span p x + in if V.null z + then mapFst (x:) (recourse xs) + else (chunks $ fromChunk y, (z:xs)) + in mapPair (SV, SV) . recourse . chunks +{- +span _ (SV []) = (empty, empty) +span p (SV (x:xs)) = + let (y,z) = V.span p x + in if V.length y == 0 + then mapFst (SV . (x:) . chunks) (span p (SV xs)) + else (SV [y], SV (z:xs)) +-} + + +-- * other functions + + +{-# INLINE filter #-} +filter :: (Storable a) => (a -> Bool) -> Vector a -> Vector a +filter p = + SV . List.filter (not . V.null) . List.map (V.filter p) . chunks + + +{- | +Generates laziness breaks +wherever one of the input signals has a chunk boundary. +-} +{-# INLINE zipWith #-} +zipWith :: (Storable a, Storable b, Storable c) => + (a -> b -> c) + -> Vector a + -> Vector b + -> Vector c +zipWith f as0 bs0 = + let recourse at@(a:_) bt@(b:_) = + let z = V.zipWith f a b + n = V.length z + in z : recourse + (chunks $ drop n $ fromChunks at) + (chunks $ drop n $ fromChunks bt) + recourse _ _ = [] + in fromChunks $ recourse (chunks as0) (chunks bs0) + +{-# INLINE zipWith3 #-} +zipWith3 :: (Storable a, Storable b, Storable c, Storable d) => + (a -> b -> c -> d) + -> Vector a + -> Vector b + -> Vector c + -> Vector d +zipWith3 f as0 bs0 cs0 = + let recourse at@(a:_) bt@(b:_) ct@(c:_) = + let z = V.zipWith3 f a b c + n = V.length z + in z : recourse + (chunks $ drop n $ fromChunks at) + (chunks $ drop n $ fromChunks bt) + (chunks $ drop n $ fromChunks ct) + recourse _ _ _ = [] + in fromChunks $ recourse (chunks as0) (chunks bs0) (chunks cs0) + +{-# INLINE zipWith4 #-} +zipWith4 :: (Storable a, Storable b, Storable c, Storable d, Storable e) => + (a -> b -> c -> d -> e) + -> Vector a + -> Vector b + -> Vector c + -> Vector d + -> Vector e +zipWith4 f as0 bs0 cs0 ds0 = + let recourse at@(a:_) bt@(b:_) ct@(c:_) dt@(d:_) = + let z = V.zipWith4 f a b c d + n = V.length z + in z : recourse + (chunks $ drop n $ fromChunks at) + (chunks $ drop n $ fromChunks bt) + (chunks $ drop n $ fromChunks ct) + (chunks $ drop n $ fromChunks dt) + recourse _ _ _ _ = [] + in fromChunks $ + recourse (chunks as0) (chunks bs0) (chunks cs0) (chunks ds0) + + +{- | +Preserves chunk pattern of the last argument. +-} +{-# INLINE zipWithLastPattern #-} +zipWithLastPattern :: (Storable a, Storable b, Storable c) => + (a -> b -> c) + -> Vector a + -> Vector b + -> Vector c +zipWithLastPattern f = + crochetL (\y -> liftM (mapFst (flip f y)) . Ptr.viewL) + . pointer + +{- | +Preserves chunk pattern of the last argument. +-} +{-# INLINE zipWithLastPattern3 #-} +zipWithLastPattern3 :: + (Storable a, Storable b, Storable c, Storable d) => + (a -> b -> c -> d) -> + (Vector a -> Vector b -> Vector c -> Vector d) +zipWithLastPattern3 f s0 s1 = + crochetL (\z (xt,yt) -> + liftM2 + (\(x,xs) (y,ys) -> (f x y z, (xs,ys))) + (Ptr.viewL xt) + (Ptr.viewL yt)) + (pointer s0, pointer s1) + +{- | +Preserves chunk pattern of the last argument. +-} +{-# INLINE zipWithLastPattern4 #-} +zipWithLastPattern4 :: + (Storable a, Storable b, Storable c, Storable d, Storable e) => + (a -> b -> c -> d -> e) -> + (Vector a -> Vector b -> Vector c -> Vector d -> Vector e) +zipWithLastPattern4 f s0 s1 s2 = + crochetL (\w (xt,yt,zt) -> + liftM3 + (\(x,xs) (y,ys) (z,zs) -> (f x y z w, (xs,ys,zs))) + (Ptr.viewL xt) + (Ptr.viewL yt) + (Ptr.viewL zt)) + (pointer s0, pointer s1, pointer s2) + + +{-# INLINE zipWithSize #-} +zipWithSize :: (Storable a, Storable b, Storable c) => + ChunkSize + -> (a -> b -> c) + -> Vector a + -> Vector b + -> Vector c +zipWithSize size f s0 s1 = + unfoldr size (\(xt,yt) -> + liftM2 + (\(x,xs) (y,ys) -> (f x y, (xs,ys))) + (Ptr.viewL xt) + (Ptr.viewL yt)) + (pointer s0, pointer s1) + +{-# INLINE zipWithSize3 #-} +zipWithSize3 :: + (Storable a, Storable b, Storable c, Storable d) => + ChunkSize -> (a -> b -> c -> d) -> + (Vector a -> Vector b -> Vector c -> Vector d) +zipWithSize3 size f s0 s1 s2 = + unfoldr size (\(xt,yt,zt) -> + liftM3 + (\(x,xs) (y,ys) (z,zs) -> + (f x y z, (xs,ys,zs))) + (Ptr.viewL xt) + (Ptr.viewL yt) + (Ptr.viewL zt)) + (pointer s0, pointer s1, pointer s2) + +{-# INLINE zipWithSize4 #-} +zipWithSize4 :: + (Storable a, Storable b, Storable c, Storable d, Storable e) => + ChunkSize -> (a -> b -> c -> d -> e) -> + (Vector a -> Vector b -> Vector c -> Vector d -> Vector e) +zipWithSize4 size f s0 s1 s2 s3 = + unfoldr size (\(xt,yt,zt,wt) -> + liftM4 + (\(x,xs) (y,ys) (z,zs) (w,ws) -> + (f x y z w, (xs,ys,zs,ws))) + (Ptr.viewL xt) + (Ptr.viewL yt) + (Ptr.viewL zt) + (Ptr.viewL wt)) + (pointer s0, pointer s1, pointer s2, pointer s3) + + +-- * interleaved vectors + +{-# INLINE sieve #-} +sieve :: (Storable a) => Int -> Vector a -> Vector a +sieve n = + fromChunks . List.filter (not . V.null) . snd . + List.mapAccumL + (\offset chunk -> + (mod (offset - V.length chunk) n, + V.sieve n $ V.drop offset chunk)) 0 . + chunks + +{-# INLINE deinterleave #-} +deinterleave :: (Storable a) => Int -> Vector a -> [Vector a] +deinterleave n = + P.map (sieve n) . P.take n . P.iterate (switchL empty (flip const)) + +{- | +Interleave lazy vectors +while maintaining the chunk pattern of the first vector. +All input vectors must have the same length. +-} +{-# INLINE interleaveFirstPattern #-} +interleaveFirstPattern :: (Storable a) => [Vector a] -> Vector a +interleaveFirstPattern [] = empty +interleaveFirstPattern vss@(vs:_) = + let pattern = List.map V.length $ chunks vs + split xs = + snd $ + List.mapAccumL + (\x n -> swap $ mapFst (V.concat . chunks) $ splitAt n x) + xs pattern + in fromChunks $ List.map V.interleave $ + List.transpose $ List.map split vss + +{- +interleaveFirstPattern vss@(vs:_) = + fromChunks . snd . + List.mapAccumL + (\xss n -> + swap $ + mapFst (V.interleave . List.map (V.concat . chunks)) $ + List.unzip $ List.map (splitAt n) xss) + vss . + List.map V.length . chunks $ vs +-} + + + +{- | +Ensure a minimal length of the list by appending pad values. +-} +{- disabled INLINE pad -} +pad :: (Storable a) => ChunkSize -> a -> Int -> Vector a -> Vector a +pad size y n0 = + let recourse n xt = + if n<=0 + then xt + else + case xt of + [] -> chunks $ replicate size n y + x:xs -> x : recourse (n - V.length x) xs + in SV . recourse n0 . chunks + +padAlt :: (Storable a) => ChunkSize -> a -> Int -> Vector a -> Vector a +padAlt size x n xs = + append xs + (let m = length xs + in if n>m + then replicate size (n-m) x + else empty) + + + + + +-- * Helper functions for StorableVector + + +{-# INLINE cancelNullVector #-} +cancelNullVector :: (V.Vector a, b) -> Maybe (V.Vector a, b) +cancelNullVector y = + toMaybe (not (V.null (fst y))) y + +-- if the chunk has length zero, an empty sequence is generated +{-# INLINE fromChunk #-} +fromChunk :: (Storable a) => V.Vector a -> Vector a +fromChunk x = + if V.null x + then empty + else SV [x] + + + +{- +reduceLVector :: Storable x => + (x -> acc -> Maybe acc) -> acc -> Vector x -> (acc, Bool) +reduceLVector f acc0 x = + let recourse i acc = + if i < V.length x + then (acc, True) + else + maybe + (acc, False) + (recourse (succ i)) + (f (V.index x i) acc) + in recourse 0 acc0 + + + + +{- * Fundamental functions -} + +{- +Usage of 'unfoldr' seems to be clumsy but that covers all cases, +like different block sizes in source and destination list. +-} +crochetLSize :: (Storable x, Storable y) => + ChunkSize + -> (x -> acc -> Maybe (y, acc)) + -> acc + -> T x + -> T y +crochetLSize size f = + curry (unfoldr size (\(acc,xt) -> + do (x,xs) <- viewL xt + (y,acc') <- f x acc + return (y, (acc',xs)))) + +crochetListL :: (Storable y) => + ChunkSize + -> (x -> acc -> Maybe (y, acc)) + -> acc + -> [x] + -> T y +crochetListL size f = + curry (unfoldr size (\(acc,xt) -> + do (x,xs) <- ListHT.viewL xt + (y,acc') <- f x acc + return (y, (acc',xs)))) + + + +{-# NOINLINE [0] crochetFusionListL #-} +crochetFusionListL :: (Storable y) => + ChunkSize + -> (x -> acc -> Maybe (y, acc)) + -> acc + -> FList.T x + -> T y +crochetFusionListL size f = + curry (unfoldr size (\(acc,xt) -> + do (x,xs) <- FList.viewL xt + (y,acc') <- f x acc + return (y, (acc',xs)))) + + +{-# INLINE [0] reduceL #-} +reduceL :: Storable x => + (x -> acc -> Maybe acc) -> acc -> Vector x -> acc +reduceL f acc0 = + let recourse acc xt = + case xt of + [] -> acc + (x:xs) -> + let (acc',continue) = reduceLVector f acc x + in if continue + then recourse acc' xs + else acc' + in recourse acc0 . chunks + + + +{- * Basic functions -} + + +{-# RULEZ + "Storable.append/repeat/repeat" forall size x. + append (repeat size x) (repeat size x) = repeat size x ; + + "Storable.append/repeat/replicate" forall size n x. + append (repeat size x) (replicate size n x) = repeat size x ; + + "Storable.append/replicate/repeat" forall size n x. + append (replicate size n x) (repeat size x) = repeat size x ; + + "Storable.append/replicate/replicate" forall size n m x. + append (replicate size n x) (replicate size m x) = + replicate size (n+m) x ; + + "Storable.mix/repeat/repeat" forall size x y. + mix (repeat size x) (repeat size y) = repeat size (x+y) ; + + #-} + +{-# RULES + "Storable.length/cons" forall x xs. + length (cons x xs) = 1 + length xs ; + + "Storable.length/map" forall f xs. + length (map f xs) = length xs ; + + "Storable.map/cons" forall f x xs. + map f (cons x xs) = cons (f x) (map f xs) ; + + "Storable.map/repeat" forall size f x. + map f (repeat size x) = repeat size (f x) ; + + "Storable.map/replicate" forall size f x n. + map f (replicate size n x) = replicate size n (f x) ; + + "Storable.map/repeat" forall size f x. + map f (repeat size x) = repeat size (f x) ; + + {- + This can make things worse, if 'map' is applied to replicate, + since this can use of sharing. + It can also destroy the more important map/unfoldr fusion in + take n . map f . unfoldr g + + "Storable.take/map" forall n f x. + take n (map f x) = map f (take n x) ; + -} + + "Storable.take/repeat" forall size n x. + take n (repeat size x) = replicate size n x ; + + "Storable.take/take" forall n m xs. + take n (take m xs) = take (min n m) xs ; + + "Storable.drop/drop" forall n m xs. + drop n (drop m xs) = drop (n+m) xs ; + + "Storable.drop/take" forall n m xs. + drop n (take m xs) = take (max 0 (m-n)) (drop n xs) ; + + "Storable.map/mapAccumL/snd" forall g f acc0 xs. + map g (snd (mapAccumL f acc0 xs)) = + snd (mapAccumL (\acc a -> mapSnd g (f acc a)) acc0 xs) ; + + #-} + +{- GHC says this is an orphaned rule + "Storable.map/mapAccumL/mapSnd" forall g f acc0 xs. + mapSnd (map g) (mapAccumL f acc0 xs) = + mapAccumL (\acc a -> mapSnd g (f acc a)) acc0 xs ; +-} + + +{- * Fusable functions -} + +scanLCrochet :: (Storable a, Storable b) => + (a -> b -> a) -> a -> Vector b -> Vector a +scanLCrochet f start = + cons start . + crochetL (\x acc -> let y = f acc x in Just (y, y)) start + +{-# INLINE mapCrochet #-} +mapCrochet :: (Storable a, Storable b) => (a -> b) -> (Vector a -> Vector b) +mapCrochet f = crochetL (\x _ -> Just (f x, ())) () + +{-# INLINE takeCrochet #-} +takeCrochet :: Storable a => Int -> Vector a -> Vector a +takeCrochet = crochetL (\x n -> toMaybe (n>0) (x, pred n)) + +{-# INLINE repeatUnfoldr #-} +repeatUnfoldr :: Storable a => ChunkSize -> a -> Vector a +repeatUnfoldr size = iterate size id + +{-# INLINE replicateCrochet #-} +replicateCrochet :: Storable a => ChunkSize -> Int -> a -> Vector a +replicateCrochet size n = takeCrochet n . repeat size + + + + +{- +The "fromList/drop" rule is not quite accurate +because the chunk borders are moved. +Maybe 'ChunkSize' better is a list of chunks sizes. +-} + +{-# RULEZ + "fromList/zipWith" + forall size f (as :: Storable a => [a]) (bs :: Storable a => [a]). + fromList size (List.zipWith f as bs) = + zipWith size f (fromList size as) (fromList size bs) ; + + "fromList/drop" forall as n size. + fromList size (List.drop n as) = + drop n (fromList size as) ; + #-} + + + +{- * Fused functions -} + +type Unfoldr s a = (s -> Maybe (a,s), s) + +{-# INLINE zipWithUnfoldr2 #-} +zipWithUnfoldr2 :: Storable z => + ChunkSize + -> (x -> y -> z) + -> Unfoldr a x + -> Unfoldr b y + -> T z +zipWithUnfoldr2 size h (f,a) (g,b) = + unfoldr size + (\(a0,b0) -> liftM2 (\(x,a1) (y,b1) -> (h x y, (a1,b1))) (f a0) (g b0)) +-- (uncurry (liftM2 (\(x,a1) (y,b1) -> (h x y, (a1,b1)))) . (f *** g)) + (a,b) + +{- done by takeCrochet +{-# INLINE mapUnfoldr #-} +mapUnfoldr :: (Storable x, Storable y) => + ChunkSize + -> (x -> y) + -> Unfoldr a x + -> T y +mapUnfoldr size g (f,a) = + unfoldr size (fmap (mapFst g) . f) a +-} + +{-# INLINE dropUnfoldr #-} +dropUnfoldr :: Storable x => + ChunkSize + -> Int + -> Unfoldr a x + -> T x +dropUnfoldr size n (f,a0) = + maybe + empty + (unfoldr size f) + (nest n (\a -> fmap snd . f =<< a) (Just a0)) + + +{- done by takeCrochet +{-# INLINE takeUnfoldr #-} +takeUnfoldr :: Storable x => + ChunkSize + -> Int + -> Unfoldr a x + -> T x +takeUnfoldr size n0 (f,a0) = + unfoldr size + (\(a,n) -> + do guard (n>0) + (x,a') <- f a + return (x, (a', pred n))) + (a0,n0) +-} + + +lengthUnfoldr :: Storable x => + Unfoldr a x + -> Int +lengthUnfoldr (f,a0) = + let recourse n a = + maybe n (recourse (succ n) . snd) (f a) + in recourse 0 a0 + + +{-# INLINE zipWithUnfoldr #-} +zipWithUnfoldr :: + (Storable b, Storable c) => + (acc -> Maybe (a, acc)) + -> (a -> b -> c) + -> acc + -> T b -> T c +zipWithUnfoldr f h a y = + crochetL (\y0 a0 -> + do (x0,a1) <- f a0 + Just (h x0 y0, a1)) a y + +{-# INLINE zipWithCrochetL #-} +zipWithCrochetL :: + (Storable x, Storable b, Storable c) => + ChunkSize + -> (x -> acc -> Maybe (a, acc)) + -> (a -> b -> c) + -> acc + -> T x -> T b -> T c +zipWithCrochetL size f h a x y = + crochetL (\(x0,y0) a0 -> + do (z0,a1) <- f x0 a0 + Just (h z0 y0, a1)) + a (zip size x y) + + +{-# INLINE crochetLCons #-} +crochetLCons :: + (Storable a, Storable b) => + (a -> acc -> Maybe (b, acc)) + -> acc + -> a -> T a -> T b +crochetLCons f a0 x xs = + maybe + empty + (\(y,a1) -> cons y (crochetL f a1 xs)) + (f x a0) + +{-# INLINE reduceLCons #-} +reduceLCons :: + (Storable a) => + (a -> acc -> Maybe acc) + -> acc + -> a -> T a -> acc +reduceLCons f a0 x xs = + maybe a0 (flip (reduceL f) xs) (f x a0) + + + + + +{-# RULES + "Storable.zipWith/share" forall size (h :: a->a->b) (x :: T a). + zipWith size h x x = map (\xi -> h xi xi) x ; + +-- "Storable.map/zipWith" forall size (f::c->d) (g::a->b->c) (x::T a) (y::T b). + "Storable.map/zipWith" forall size f g x y. + map f (zipWith size g x y) = + zipWith size (\xi yi -> f (g xi yi)) x y ; + + -- this rule lets map run on a different block structure + "Storable.zipWith/map,*" forall size f g x y. + zipWith size g (map f x) y = + zipWith size (\xi yi -> g (f xi) yi) x y ; + + "Storable.zipWith/*,map" forall size f g x y. + zipWith size g x (map f y) = + zipWith size (\xi yi -> g xi (f yi)) x y ; + + + "Storable.drop/unfoldr" forall size f a n. + drop n (unfoldr size f a) = + dropUnfoldr size n (f,a) ; + + "Storable.take/unfoldr" forall size f a n. + take n (unfoldr size f a) = +-- takeUnfoldr size n (f,a) ; + takeCrochet n (unfoldr size f a) ; + + "Storable.length/unfoldr" forall size f a. + length (unfoldr size f a) = lengthUnfoldr (f,a) ; + + "Storable.map/unfoldr" forall size g f a. + map g (unfoldr size f a) = +-- mapUnfoldr size g (f,a) ; + mapCrochet g (unfoldr size f a) ; + + "Storable.map/iterate" forall size g f a. + map g (iterate size f a) = + mapCrochet g (iterate size f a) ; + +{- + "Storable.zipWith/unfoldr,unfoldr" forall sizeA sizeB f g h a b n. + zipWith n h (unfoldr sizeA f a) (unfoldr sizeB g b) = + zipWithUnfoldr2 n h (f,a) (g,b) ; +-} + + -- block boundaries are changed here, so it changes lazy behaviour + "Storable.zipWith/unfoldr,*" forall sizeA sizeB f h a y. + zipWith sizeA h (unfoldr sizeB f a) y = + zipWithUnfoldr f h a y ; + + -- block boundaries are changed here, so it changes lazy behaviour + "Storable.zipWith/*,unfoldr" forall sizeA sizeB f h a y. + zipWith sizeA h y (unfoldr sizeB f a) = + zipWithUnfoldr f (flip h) a y ; + + "Storable.crochetL/unfoldr" forall size f g a b. + crochetL g b (unfoldr size f a) = + unfoldr size (\(a0,b0) -> + do (y0,a1) <- f a0 + (z0,b1) <- g y0 b0 + Just (z0, (a1,b1))) (a,b) ; + + "Storable.reduceL/unfoldr" forall size f g a b. + reduceL g b (unfoldr size f a) = + snd + (FList.recourse (\(a0,b0) -> + do (y,a1) <- f a0 + b1 <- g y b0 + Just (a1, b1)) (a,b)) ; + + "Storable.crochetL/cons" forall g b x xs. + crochetL g b (cons x xs) = + crochetLCons g b x xs ; + + "Storable.reduceL/cons" forall g b x xs. + reduceL g b (cons x xs) = + reduceLCons g b x xs ; + + + + + "Storable.take/crochetL" forall f a x n. + take n (crochetL f a x) = + takeCrochet n (crochetL f a x) ; + + "Storable.length/crochetL" forall f a x. + length (crochetL f a x) = length x ; + + "Storable.map/crochetL" forall g f a x. + map g (crochetL f a x) = + mapCrochet g (crochetL f a x) ; + + "Storable.zipWith/crochetL,*" forall size f h a x y. + zipWith size h (crochetL f a x) y = + zipWithCrochetL size f h a x y ; + + "Storable.zipWith/*,crochetL" forall size f h a x y. + zipWith size h y (crochetL f a x) = + zipWithCrochetL size f (flip h) a x y ; + + "Storable.crochetL/crochetL" forall f g a b x. + crochetL g b (crochetL f a x) = + crochetL (\x0 (a0,b0) -> + do (y0,a1) <- f x0 a0 + (z0,b1) <- g y0 b0 + Just (z0, (a1,b1))) (a,b) x ; + + "Storable.reduceL/crochetL" forall f g a b x. + reduceL g b (crochetL f a x) = + snd + (reduceL (\x0 (a0,b0) -> + do (y,a1) <- f x0 a0 + b1 <- g y b0 + Just (a1, b1)) (a,b) x) ; + #-} + +-} + +{- * IO -} + +{- | +Read the rest of a file lazily and +provide the reason of termination as IOError. +If IOError is EOF (check with @System.Error.isEOFError err@), +then the file was read successfully. +Only access the final IOError after you have consumed the file contents, +since finding out the terminating reason forces to read the entire file. +Make also sure you read the file completely, +because it is only closed when the file end is reached +(or an exception is encountered). + +TODO: +In ByteString.Lazy the chunk size is reduced +if data is not immediately available. +Maybe we should adapt that behaviour +but when working with realtime streams +that may mean that the chunks are very small. +-} +hGetContentsAsync :: Storable a => + ChunkSize -> Handle -> IO (IOError, Vector a) +hGetContentsAsync (ChunkSize size) h = + let go = + Unsafe.interleaveIO $ + flip catch (\err -> return (err,[])) $ + do v <- V.hGet h size + if V.null v + then hClose h >> + return (Exc.mkIOError Exc.eofErrorType + "StorableVector.Lazy.hGetContentsAsync" (Just h) Nothing, []) + else fmap (mapSnd (v:)) go +{- + Unsafe.interleaveIO $ + flip catch (\err -> return (err,[])) $ + liftM2 (\ chunk ~(err,rest) -> (err,chunk:rest)) + (V.hGet h size) go +-} + in fmap (mapSnd SV) go + +hGetContentsSync :: Storable a => + ChunkSize -> Handle -> IO (Vector a) +hGetContentsSync (ChunkSize size) h = + let go = + do v <- V.hGet h size + if V.null v + then return [] + else fmap (v:) go + in fmap SV go + +hPut :: Storable a => Handle -> Vector a -> IO () +hPut h = mapM_ (V.hPut h) . chunks + +{- +*Data.StorableVector.Lazy> print . mapSnd (length :: Vector Data.Int.Int16 -> Int) =<< readFileAsync (ChunkSize 1000) "dist/build/libHSstorablevector-0.1.3.a" +(dist/build/libHSstorablevector-0.1.3.a: hGetBuf: illegal operation (handle is closed),0) +-} +{- | +The file can only closed after all values are consumed. +That is you must always assert that you consume all elements of the stream, +and that no values are missed due to lazy evaluation. +This requirement makes this function useless in many applications. +-} +readFileAsync :: Storable a => ChunkSize -> FilePath -> IO (IOError, Vector a) +readFileAsync size path = + openBinaryFile path ReadMode >>= hGetContentsAsync size + +writeFile :: Storable a => FilePath -> Vector a -> IO () +writeFile path = + bracket (openBinaryFile path WriteMode) hClose . flip hPut + +appendFile :: Storable a => FilePath -> Vector a -> IO () +appendFile path = + bracket (openBinaryFile path AppendMode) hClose . flip hPut + + +{-# NOINLINE moduleError #-} +moduleError :: String -> String -> a +moduleError fun msg = + error ("Data.StorableVector.Lazy." List.++ fun List.++ ':':' ':msg) diff --git a/src/Data/StorableVector/Lazy/Builder.hs b/src/Data/StorableVector/Lazy/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Data/StorableVector/Lazy/Builder.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE Rank2Types #-} +{- | +Build a lazy storable vector by incrementally adding an element. +This is analogous to Data.Binary.Builder for Data.ByteString.Lazy. + +Attention: +This implementation is still almost 3 times slower +than constructing a lazy storable vector using unfoldr +in our Chorus speed test. +-} +module Data.StorableVector.Lazy.Builder ( + Builder, + toLazyStorableVector, + put, + flush, + ) where + +import qualified Data.StorableVector as SV +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector.ST.Strict as STV +-- import qualified Data.StorableVector.ST.Lazy as STVL + +import Data.StorableVector.Lazy (ChunkSize, ) +import Control.Monad (liftM2, ) +import Control.Monad.ST.Strict (ST, runST, ) +import Data.Monoid (Monoid(mempty, mappend), ) + +import Foreign.Storable (Storable, ) + +import qualified System.Unsafe as Unsafe + + +{- +Given an initial buffer and a function that generates the rest of the vector, +a 'Builder' generates the whole vector. +The idea is inspired by Data.Binary.Builder. + +We use the strict ST monad by default +and only rare 'Unsafe.interleaveST', +since this is more efficient than using lazy ST everywhere. + +Before that approach I tried to achieve this with a lazy State monad. +I found this more comprehensible but it was very slow +and had a space leak, when the last chunk shall be handled correctly. +-} +newtype Builder a = + Builder {run :: forall s. + ChunkSize -> + (Buffer s a -> ST s [SV.Vector a]) -> + (Buffer s a -> ST s [SV.Vector a]) + } + +type Buffer s a = (STV.Vector s a, Int) + + +-- instance Monoid (Builder a) where +{- +Storable constraint not needed in the current implementation, +but who knows what will be in future ... +-} +instance Storable a => Monoid (Builder a) where + {-# INLINE mempty #-} + {-# INLINE mappend #-} + mempty = Builder (\_ -> id) + mappend x y = Builder (\cs -> run x cs . run y cs) + + +{- | +> toLazyStorableVector (ChunkSize 7) $ Data.Monoid.mconcat $ map put ['a'..'z'] +-} +{-# INLINE toLazyStorableVector #-} +toLazyStorableVector :: Storable a => + ChunkSize -> Builder a -> SVL.Vector a +toLazyStorableVector cs bld = + SVL.fromChunks $ + runST (run bld cs (fmap (:[]) . fixVector) =<< newChunk cs) + + +{-# INLINE put #-} +put :: Storable a => a -> Builder a +put a = + Builder (\cs cont (v0,i0) -> + do STV.unsafeWrite v0 i0 a + let i1 = succ i0 + if i1 < STV.length v0 + then + cont (v0, i1) + else + liftM2 (:) + -- we could call 'flush' here, but this requires an extra 'SV.take' + (STV.unsafeFreeze v0) + (Unsafe.interleaveST $ + cont =<< newChunk cs) + ) + +{- +put :: Storable a => a -> Builder a +put a = + Builder (\cs cont (v0,i0) -> + if i0 < STV.length v0 + then + do STV.write v0 i0 a + cont (v0, succ i0) + else + liftM2 (:) + -- we could call 'flush' here, but this requires an extra 'SV.take' + (STV.unsafeFreeze v0) + (Unsafe.interleaveST $ + do (v1,i1) <- newChunk cs + STV.write v1 i1 a + cont (v1, succ i1)) + ) +-} + +{- + lazyToStrictST $ + liftM2 (:) + -- we could call 'flush' here, but this requires an extra 'SV.take' + (STVL.unsafeFreeze v0) + (strictToLazyST $ + do (v1,i1) <- newChunk cs + STV.write v1 i1 a + cont (v1, succ i1)) +-} + +{- +Prelude Control.Monad.ST.Lazy> Control.Monad.ST.runST (lazyToStrictST $ Monad.liftM2 (,) (strictToLazyST $ return 'a') (strictToLazyST (undefined::Monad m => m Char))) +*** Exception: Prelude.undefined +-} + +{- | +Set a laziness break. +-} +{-# INLINE flush #-} +flush :: Storable a => Builder a +flush = + Builder (\cs cont vi0 -> + liftM2 (:) + (fixVector vi0) + (Unsafe.interleaveST $ cont =<< newChunk cs) +{- + lazyToStrictST $ + liftM2 (:) + (strictToLazyST $ fixVector vi0) + (strictToLazyST $ cont =<< newChunk cs) +-} + ) + +{-# INLINE newChunk #-} +newChunk :: (Storable a) => + ChunkSize -> ST s (Buffer s a) +newChunk (SVL.ChunkSize size) = + fmap (flip (,) 0) $ STV.new_ size + +{-# INLINE fixVector #-} +fixVector :: (Storable a) => + Buffer s a -> ST s (SV.Vector a) +fixVector ~(v1,i1) = + fmap (SV.take i1) $ STV.unsafeFreeze v1 diff --git a/src/Data/StorableVector/Lazy/Pattern.hs b/src/Data/StorableVector/Lazy/Pattern.hs new file mode 100644 --- /dev/null +++ b/src/Data/StorableVector/Lazy/Pattern.hs @@ -0,0 +1,371 @@ +{- | +Functions for 'StorableVector' that allow control of the size of individual chunks. + +This is import for an application like the following: +You want to mix audio signals that are relatively shifted. +The structure of chunks of three streams may be illustrated as: + +> [____] [____] [____] [____] ... +> [____] [____] [____] [____] ... +> [____] [____] [____] [____] ... + +When we mix the streams (@zipWith3 (\x y z -> x+y+z)@) +with respect to the chunk structure of the first signal, +computing the first chunk requires full evaluation of all leading chunks of the stream. +However the last value of the third leading chunk +is much later in time than the last value of the first leading chunk. +We like to reduce these dependencies using a different chunk structure, +say + +> [____] [____] [____] [____] ... +> [__] [____] [____] [____] ... +> [] [____] [____] [____] ... + +-} +module Data.StorableVector.Lazy.Pattern ( + Vector, + ChunkSize, + chunkSize, + defaultChunkSize, + LazySize, + + empty, + singleton, + pack, + unpack, + packWith, + unpackWith, + unfoldrN, + iterateN, + cycle, + replicate, + null, + length, + cons, + append, + concat, + map, + reverse, + foldl, + foldl', + any, + all, + maximum, + minimum, + viewL, + viewR, + switchL, + switchR, + scanl, + mapAccumL, + mapAccumR, + crochetL, + take, + drop, + splitAt, + takeVectorPattern, + splitAtVectorPattern, + dropMarginRem, + dropMargin, + dropWhile, + takeWhile, + span, + filter, + zipWith, + zipWith3, + zipWith4, + zipWithSize, + zipWithSize3, + zipWithSize4, +{- + pad, + cancelNullVector, +-} + ) where + +import Numeric.NonNegative.Class ((-|)) +import qualified Numeric.NonNegative.Chunky as LS +import qualified Data.StorableVector.Lazy as LSV +import qualified Data.StorableVector as V + +import Data.StorableVector.Lazy (Vector(SV), ChunkSize(ChunkSize)) + +import Data.StorableVector.Lazy ( + chunkSize, defaultChunkSize, + empty, singleton, unpack, unpackWith, cycle, + null, cons, append, concat, map, reverse, + foldl, foldl', any, all, maximum, minimum, + viewL, viewR, switchL, switchR, + scanl, mapAccumL, mapAccumR, crochetL, + dropMarginRem, dropMargin, + dropWhile, takeWhile, span, filter, + zipWith, zipWith3, zipWith4, + ) + +import qualified Data.List as List + +import qualified Data.List.HT as ListHT +import Data.Tuple.HT (mapPair, mapFst, forcePair, swap, ) + +import Control.Monad (liftM2, liftM3, liftM4, guard, ) + +import Foreign.Storable (Storable) + +import Prelude hiding + (length, (++), iterate, foldl, map, repeat, replicate, null, + zip, zipWith, zipWith3, drop, take, splitAt, takeWhile, dropWhile, reverse, + any, all, concat, cycle, filter, maximum, minimum, scanl, span, ) +{- +import Data.Maybe (Maybe(Just, Nothing), ) +import Prelude (Int, (.), ($), fst, snd, (<=), flip, curry, return, fmap, not, uncurry, ) +-} + + +type LazySize = LS.T ChunkSize + +-- * Introducing and eliminating 'Vector's + +{- +Actually, this is lazy enough: + +> LSV.unpack $ pack (LS.fromChunks [10,15]) (['a'..'y'] List.++ Prelude.undefined) +"abcdefghijklmnopqrstuvwxy" +-} +pack :: (Storable a) => LazySize -> [a] -> Vector a +pack size = + fst . unfoldrN size ListHT.viewL + + +{-# INLINE packWith #-} +packWith :: (Storable b) => LazySize -> (a -> b) -> [a] -> Vector b +packWith size f = + fst . unfoldrN size (fmap (mapFst f) . ListHT.viewL) + + +{- +{-# INLINE unfoldrNAlt #-} +unfoldrNAlt :: (Storable b) => + LazySize + -> (a -> Maybe (b,a)) + -> a + -> (Vector b, Maybe a) +unfoldrNAlt (LS.Cons size) f x = + let go sz y = + case sz of + [] -> ([], y) + (ChunkSize s : ss) -> + maybe + ([], Nothing) + ((\(c,a1) -> mapFst (c:) $ go ss a1) . + V.unfoldrN s (fmap (mapSnd f))) + (f y) + in mapFst SV $ go size (Just x) +-} + +{-# INLINE unfoldrN #-} +unfoldrN :: (Storable b) => + LazySize + -> (a -> Maybe (b,a)) + -> a + -> (Vector b, Maybe a) +unfoldrN size f = + let go sz y = + forcePair $ + case sz of + [] -> ([], y) + (ChunkSize s : ss) -> + let m = + do a0 <- y + let p = V.unfoldrN s f a0 + guard (not (V.null (fst p))) + return p + in case m of + Nothing -> ([], Nothing) + Just (c,a1) -> mapFst (c:) $ go ss a1 + in mapFst SV . go (LS.toChunks size) . Just + + +{-# INLINE iterateN #-} +iterateN :: Storable a => LazySize -> (a -> a) -> a -> Vector a +iterateN size f = + fst . unfoldrN size (\x -> Just (x, f x)) + +{- +Tries to be time and memory efficient +by reusing subvectors of a chunk +until a larger chunk is needed. +However, it can be a memory leak +if a huge chunk is followed by many little ones. +-} +replicate :: Storable a => LazySize -> a -> Vector a +replicate size x = + SV $ snd $ + List.mapAccumL + (\v (ChunkSize m) -> + if m <= V.length v + then (v, V.take m v) + else let v1 = V.replicate m x + in (v1,v1)) + V.empty $ + LS.toChunks size + +{- +replicate :: Storable a => LazySize -> a -> Vector a +replicate size x = + SV $ List.map (\(ChunkSize m) -> V.replicate m x) (LS.toChunks size) +-} + + +-- * Basic interface + +length :: Vector a -> LazySize +length = LS.fromChunks . List.map chunkLength . LSV.chunks + +chunkLength :: V.Vector a -> ChunkSize +chunkLength = ChunkSize . V.length + +decrementLimit :: V.Vector a -> LazySize -> LazySize +decrementLimit x y = + y -| LS.fromNumber (chunkLength x) + +intFromChunkSize :: ChunkSize -> Int +intFromChunkSize (ChunkSize x) = x + +intFromLazySize :: LazySize -> Int +intFromLazySize = + List.sum . List.map intFromChunkSize . LS.toChunks + + + +-- * sub-vectors + +{- | +Generates laziness breaks +wherever either the lazy length number or the vector has a chunk boundary. +-} +{-# INLINE take #-} +take :: (Storable a) => LazySize -> Vector a -> Vector a +take n = fst . splitAt n + +{- | +Preserves the chunk pattern of the lazy vector. +-} +{-# INLINE takeVectorPattern #-} +takeVectorPattern :: (Storable a) => LazySize -> Vector a -> Vector a +takeVectorPattern _ (SV []) = empty +takeVectorPattern n (SV (x:xs)) = + if List.null (LS.toChunks n) + then empty + else + let remain = decrementLimit x n + in SV $ uncurry (:) $ + if LS.isNull remain + then (V.take (intFromLazySize n) x, []) + else + (x, LSV.chunks $ take remain $ LSV.fromChunks xs) + +{-# INLINE drop #-} +drop :: (Storable a) => LazySize -> Vector a -> Vector a +drop size xs = + List.foldl (flip (LSV.drop . intFromChunkSize)) xs (LS.toChunks size) + +{-# INLINE splitAt #-} +splitAt :: + (Storable a) => LazySize -> Vector a -> (Vector a, Vector a) +splitAt size xs = + mapFst LSV.concat $ swap $ + List.mapAccumL + (\xs0 n -> + swap $ LSV.splitAt (intFromChunkSize n) xs0) + xs (LS.toChunks size) + +{-# INLINE splitAtVectorPattern #-} +splitAtVectorPattern :: + (Storable a) => LazySize -> Vector a -> (Vector a, Vector a) +splitAtVectorPattern n0 = + forcePair . + if List.null (LS.toChunks n0) + then (,) empty + else + let recourse n xt = + forcePair $ + case xt of + [] -> ([], []) + (x:xs) -> + let remain = decrementLimit x n + in if LS.isNull remain + then mapPair ((:[]), (:xs)) $ + V.splitAt (intFromLazySize n) x + else mapFst (x:) $ recourse remain xs + in mapPair (SV, SV) . recourse n0 . LSV.chunks + + +{-# INLINE [0] zipWithSize #-} +zipWithSize :: (Storable a, Storable b, Storable c) => + LazySize + -> (a -> b -> c) + -> Vector a + -> Vector b + -> Vector c +zipWithSize size f = + curry (fst . unfoldrN size (\(xt,yt) -> + liftM2 + (\(x,xs) (y,ys) -> (f x y, (xs,ys))) + (viewL xt) + (viewL yt))) + +{-# INLINE zipWithSize3 #-} +zipWithSize3 :: + (Storable a, Storable b, Storable c, Storable d) => + LazySize -> (a -> b -> c -> d) -> + (Vector a -> Vector b -> Vector c -> Vector d) +zipWithSize3 size f s0 s1 s2 = + fst $ unfoldrN size (\(xt,yt,zt) -> + liftM3 + (\(x,xs) (y,ys) (z,zs) -> + (f x y z, (xs,ys,zs))) + (viewL xt) + (viewL yt) + (viewL zt)) + (s0,s1,s2) + +{-# INLINE zipWithSize4 #-} +zipWithSize4 :: + (Storable a, Storable b, Storable c, Storable d, Storable e) => + LazySize -> (a -> b -> c -> d -> e) -> + (Vector a -> Vector b -> Vector c -> Vector d -> Vector e) +zipWithSize4 size f s0 s1 s2 s3 = + fst $ unfoldrN size (\(xt,yt,zt,wt) -> + liftM4 + (\(x,xs) (y,ys) (z,zs) (w,ws) -> + (f x y z w, (xs,ys,zs,ws))) + (viewL xt) + (viewL yt) + (viewL zt) + (viewL wt)) + (s0,s1,s2,s3) + +{- +{- | +Ensure a minimal length of the list by appending pad values. +-} +{-# ONLINE pad #-} +pad :: (Storable a) => ChunkSize -> a -> Int -> Vector a -> Vector a +pad size y n0 = + let recourse n xt = + if n<=0 + then xt + else + case xt of + [] -> chunks $ replicate size n y + x:xs -> x : recourse (n - V.length x) xs + in SV . recourse n0 . chunks + +padAlt :: (Storable a) => ChunkSize -> a -> Int -> Vector a -> Vector a +padAlt size x n xs = + append xs + (let m = length xs + in if n>m + then replicate size (n-m) x + else empty) +-} diff --git a/src/Data/StorableVector/Lazy/Pointer.hs b/src/Data/StorableVector/Lazy/Pointer.hs new file mode 100644 --- /dev/null +++ b/src/Data/StorableVector/Lazy/Pointer.hs @@ -0,0 +1,20 @@ +{- | +In principle you can traverse through a lazy storable vector +using repeated calls to @viewL@. +However this needs a bit of pointer arrangement and allocation. +This data structure makes the inner loop faster, +that consists of traversing through a chunk. +-} +module Data.StorableVector.Lazy.Pointer ( + Pointer, cons, viewL, switchL, + ) where + +import Data.StorableVector.Lazy.PointerPrivate (Pointer(..), viewL, switchL, ) +import qualified Data.StorableVector.Lazy as VL + +import Foreign.Storable (Storable) + + +{-# INLINE cons #-} +cons :: Storable a => VL.Vector a -> Pointer a +cons = VL.pointer diff --git a/src/Data/StorableVector/Lazy/PointerPrivate.hs b/src/Data/StorableVector/Lazy/PointerPrivate.hs new file mode 100644 --- /dev/null +++ b/src/Data/StorableVector/Lazy/PointerPrivate.hs @@ -0,0 +1,42 @@ +module Data.StorableVector.Lazy.PointerPrivate where + +import qualified Data.StorableVector.Pointer as VP +import qualified Data.StorableVector as V +import qualified Data.StorableVector.Base as VB + +import Foreign.Storable (Storable) + + +data Pointer a = + Pointer { + chunks :: [VB.Vector a], + ptr :: {-# UNPACK #-} !(VP.Pointer a) + } + + +empty :: Storable a => Pointer a +empty = + Pointer [] (VP.cons V.empty) + +{-# INLINE cons #-} +cons :: Storable a => [VB.Vector a] -> Pointer a +cons [] = empty +cons (c:cs) = Pointer cs (VP.cons c) + +{-# INLINE viewL #-} +viewL :: Storable a => Pointer a -> Maybe (a, Pointer a) +viewL = switchL Nothing (curry Just) + +{-# INLINE switchL #-} +switchL :: Storable a => + b -> (a -> Pointer a -> b) -> Pointer a -> b +switchL n j = + let recourse p = + let ct = chunks p + in VP.switchL + (case ct of + [] -> n + (c:cs) -> recourse (Pointer cs (VP.cons c))) + (\a cp -> j a (Pointer ct cp)) + (ptr p) + in recourse diff --git a/src/Data/StorableVector/Lazy/PointerPrivateIndex.hs b/src/Data/StorableVector/Lazy/PointerPrivateIndex.hs new file mode 100644 --- /dev/null +++ b/src/Data/StorableVector/Lazy/PointerPrivateIndex.hs @@ -0,0 +1,38 @@ +{- +Alternative to PointerPrivate implemented at a higher level. +-} +module Data.StorableVector.Lazy.PointerPrivateIndex where + +import qualified Data.StorableVector as V +import qualified Data.StorableVector.Base as VB + +import Foreign.Storable (Storable) + + +data Pointer a = + Pointer {chunks :: ![VB.Vector a], index :: !Int} + + +{-# INLINE cons #-} +cons :: Storable a => [VB.Vector a] -> Pointer a +cons = flip Pointer 0 + +{-# INLINE viewL #-} +viewL :: Storable a => Pointer a -> Maybe (a, Pointer a) +viewL = switchL Nothing (curry Just) + +{-# INLINE switchL #-} +switchL :: Storable a => + b -> (a -> Pointer a -> b) -> Pointer a -> b +switchL n j = + let recourse p = + let s = chunks p + in case s of + [] -> n + (c:cs) -> + let i = index p + d = i - V.length c + in if d < 0 + then j (VB.unsafeIndex c i) (Pointer s (i+1)) + else recourse (Pointer cs d) + in recourse diff --git a/src/Data/StorableVector/Pointer.hs b/src/Data/StorableVector/Pointer.hs new file mode 100644 --- /dev/null +++ b/src/Data/StorableVector/Pointer.hs @@ -0,0 +1,52 @@ +{- | +In principle you can traverse through a storable vector +using repeated calls to @viewL@ or using @index@. +However this needs a bit of pointer arrangement and allocation. +This data structure should make loops optimally fast. +-} +module Data.StorableVector.Pointer where + +-- import qualified Data.StorableVector as V +import qualified Data.StorableVector.Base as VB + +import qualified Foreign.ForeignPtr as FPtr +import Foreign.Marshal.Array (advancePtr, ) +import Foreign.Storable (Storable, peek, ) +import Foreign (Ptr, ) +import qualified System.Unsafe as Unsafe + + +{- +The reference to the ForeignPtr asserts, +that the array is maintained and thus is not garbage collected. +The Ptr we use for traversing would not achieve this. +-} +{- | +We might have name the data type iterator. +-} +data Pointer a = + Pointer { + fptr :: {-# UNPACK #-} !(FPtr.ForeignPtr a), + ptr :: {-# UNPACK #-} !(Ptr a), + left :: {-# UNPACK #-} !Int + } + + +{-# INLINE cons #-} +cons :: Storable a => VB.Vector a -> Pointer a +cons (VB.SV fp s l) = + Pointer fp (advancePtr (Unsafe.foreignPtrToPtr fp) s) l + + +{-# INLINE viewL #-} +viewL :: Storable a => Pointer a -> Maybe (a, Pointer a) +viewL = switchL Nothing (curry Just) + +{-# INLINE switchL #-} +switchL :: Storable a => + b -> (a -> Pointer a -> b) -> Pointer a -> b +switchL n j (Pointer fp p l) = + if l<=0 + then n + else j (VB.inlinePerformIO (peek p)) (Pointer fp (advancePtr p 1) (l-1)) +-- Unsafe.performIO at this place would make SpeedPointer test 0.5 s slower diff --git a/src/Data/StorableVector/ST/Lazy.hs b/src/Data/StorableVector/ST/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/Data/StorableVector/ST/Lazy.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE Rank2Types #-} +{- | +Module : Data.StorableVector.ST.Strict +License : BSD-style +Maintainer : haskell@henning-thielemann.de +Stability : experimental +Portability : portable, requires ffi +Tested with : GHC 6.4.1 + +Interface for access to a mutable StorableVector. +-} +module Data.StorableVector.ST.Lazy ( + Vector, + new, + new_, + read, + write, + modify, + unsafeRead, + unsafeWrite, + unsafeModify, + freeze, + unsafeFreeze, + thaw, + VST.length, + runSTVector, + mapST, + mapSTLazy, + ) where + +-- import qualified Data.StorableVector.Base as V +import qualified Data.StorableVector as VS +import qualified Data.StorableVector.Lazy as VL + +import qualified Data.StorableVector.ST.Strict as VST + +import Data.StorableVector.ST.Strict (Vector) + + +import qualified Control.Monad.ST.Lazy as ST +import Control.Monad.ST.Lazy (ST) + +import Foreign.Storable (Storable) + +-- import Prelude (Int, ($), (+), return, const, ) +import Prelude hiding (read, length, ) + + + +-- * access to mutable storable vector + +{-# INLINE new #-} +new :: (Storable e) => + Int -> e -> ST s (Vector s e) +new n x = ST.strictToLazyST (VST.new n x) + +{-# INLINE new_ #-} +new_ :: (Storable e) => + Int -> ST s (Vector s e) +new_ n = ST.strictToLazyST (VST.new_ n) + +{- | +> Control.Monad.ST.runST (do arr <- new_ 10; Monad.zipWithM_ (write arr) [9,8..0] ['a'..]; read arr 3) +-} +{-# INLINE read #-} +read :: (Storable e) => + Vector s e -> Int -> ST s e +read xs n = ST.strictToLazyST (VST.read xs n) + +{- | +> VS.unpack $ runSTVector (do arr <- new_ 10; Monad.zipWithM_ (write arr) [9,8..0] ['a'..]; return arr) +-} +{-# INLINE write #-} +write :: (Storable e) => + Vector s e -> Int -> e -> ST s () +write xs n x = ST.strictToLazyST (VST.write xs n x) + +{-# INLINE modify #-} +modify :: (Storable e) => + Vector s e -> Int -> (e -> e) -> ST s () +modify xs n f = ST.strictToLazyST (VST.modify xs n f) + + +{-# INLINE unsafeRead #-} +unsafeRead :: (Storable e) => + Vector s e -> Int -> ST s e +unsafeRead xs n = ST.strictToLazyST (VST.unsafeRead xs n) + +{-# INLINE unsafeWrite #-} +unsafeWrite :: (Storable e) => + Vector s e -> Int -> e -> ST s () +unsafeWrite xs n x = ST.strictToLazyST (VST.unsafeWrite xs n x) + +{-# INLINE unsafeModify #-} +unsafeModify :: (Storable e) => + Vector s e -> Int -> (e -> e) -> ST s () +unsafeModify xs n f = ST.strictToLazyST (VST.unsafeModify xs n f) + + +{-# INLINE freeze #-} +freeze :: (Storable e) => + Vector s e -> ST s (VS.Vector e) +freeze xs = ST.strictToLazyST (VST.freeze xs) + +{-# INLINE unsafeFreeze #-} +unsafeFreeze :: (Storable e) => + Vector s e -> ST s (VS.Vector e) +unsafeFreeze xs = ST.strictToLazyST (VST.unsafeFreeze xs) + +{-# INLINE thaw #-} +thaw :: (Storable e) => + VS.Vector e -> ST s (Vector s e) +thaw xs = ST.strictToLazyST (VST.thaw xs) + + + +{-# INLINE runSTVector #-} +runSTVector :: (Storable e) => + (forall s. ST s (Vector s e)) -> VS.Vector e +runSTVector m = VST.runSTVector (ST.lazyToStrictST m) + + + +-- * operations on immutable storable vector within ST monad + +{- | +> :module + Data.STRef +> VS.unpack $ Control.Monad.ST.runST (do ref <- newSTRef 'a'; mapST (\ _n -> do c <- readSTRef ref; modifySTRef ref succ; return c) (VS.pack [1,2,3,4::Data.Int.Int16])) +-} +{-# INLINE mapST #-} +mapST :: (Storable a, Storable b) => + (a -> ST s b) -> VS.Vector a -> ST s (VS.Vector b) +mapST f xs = + ST.strictToLazyST (VST.mapST (ST.lazyToStrictST . f) xs) + + +{- | +> *Data.StorableVector.ST.Strict Data.STRef> VL.unpack $ Control.Monad.ST.runST (do ref <- newSTRef 'a'; mapSTLazy (\ _n -> do c <- readSTRef ref; modifySTRef ref succ; return c) (VL.pack VL.defaultChunkSize [1,2,3,4::Data.Int.Int16])) +> "abcd" + +The following should not work on infinite streams, +since we are in 'ST' with strict '>>='. +But it works. Why? + +> *Data.StorableVector.ST.Strict Data.STRef.Lazy> VL.unpack $ Control.Monad.ST.Lazy.runST (do ref <- newSTRef 'a'; mapSTLazy (\ _n -> do c <- readSTRef ref; modifySTRef ref succ; return c) (VL.pack VL.defaultChunkSize [0::Data.Int.Int16 ..])) +> "Interrupted. +-} +{-# INLINE mapSTLazy #-} +mapSTLazy :: (Storable a, Storable b) => + (a -> ST s b) -> VL.Vector a -> ST s (VL.Vector b) +mapSTLazy f (VL.SV xs) = + fmap VL.SV $ mapM (mapST f) xs diff --git a/src/Data/StorableVector/ST/Private.hs b/src/Data/StorableVector/ST/Private.hs new file mode 100644 --- /dev/null +++ b/src/Data/StorableVector/ST/Private.hs @@ -0,0 +1,54 @@ +{- | +Module : Data.StorableVector.ST.Strict +License : BSD-style +Maintainer : haskell@henning-thielemann.de +Stability : experimental +Portability : portable, requires ffi +Tested with : GHC 6.4.1 + +-} +module Data.StorableVector.ST.Private where + +import qualified Data.StorableVector.Base as V + +import Data.StorableVector.Memory (mallocForeignPtrArray, ) + +import Control.Monad.ST.Strict (ST, ) + +import Foreign.Ptr (Ptr, ) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, ) +import Foreign.Storable (Storable, ) + +import qualified System.Unsafe as Unsafe + +-- import Prelude (Int, ($), (+), return, const, ) +import Prelude hiding (read, length, ) + + +data Vector s a = + SV {-# UNPACK #-} !(ForeignPtr a) + {-# UNPACK #-} !Int -- length + + +-- | Wrapper of mallocForeignPtrArray. +create :: (Storable a) => Int -> (Ptr a -> IO ()) -> IO (Vector s a) +create l f = do + fp <- mallocForeignPtrArray l + withForeignPtr fp f + return $! SV fp l + +{-# INLINE unsafeCreate #-} +unsafeCreate :: (Storable a) => Int -> (Ptr a -> IO ()) -> ST s (Vector s a) +unsafeCreate l f = Unsafe.ioToST $ create l f + +{- +This function must be in ST monad, +since it is usually called +as termination of a series of write accesses to the vector. +We must assert that no read access to the V.Vector can happen +before the end of the write accesses. +(And the caller must assert, that he actually never writes again into that vector.) +-} +{-# INLINE unsafeToVector #-} +unsafeToVector :: Vector s a -> ST s (V.Vector a) +unsafeToVector (SV x l) = return (V.SV x 0 l) diff --git a/src/Data/StorableVector/ST/Strict.hs b/src/Data/StorableVector/ST/Strict.hs new file mode 100644 --- /dev/null +++ b/src/Data/StorableVector/ST/Strict.hs @@ -0,0 +1,287 @@ +{-# LANGUAGE Rank2Types #-} +{- | +Module : Data.StorableVector.ST.Strict +License : BSD-style +Maintainer : haskell@henning-thielemann.de +Stability : experimental +Portability : portable, requires ffi +Tested with : GHC 6.4.1 + +Interface for access to a mutable StorableVector. +-} +module Data.StorableVector.ST.Strict ( + Vector, + new, + new_, + read, + write, + modify, + maybeRead, + maybeWrite, + maybeModify, + unsafeRead, + unsafeWrite, + unsafeModify, + freeze, + unsafeFreeze, + thaw, + length, + runSTVector, + mapST, + mapSTLazy, + ) where + +import Data.StorableVector.ST.Private + (Vector(SV), create, unsafeCreate, unsafeToVector, ) +import qualified Data.StorableVector.Base as V +import qualified Data.StorableVector as VS +import qualified Data.StorableVector.Lazy as VL + +import Control.Monad.ST.Strict (ST, runST, ) + +import Foreign.Ptr (Ptr, ) +import Foreign.ForeignPtr (withForeignPtr, ) +import Foreign.Storable (Storable(peek, poke)) +import Foreign.Marshal.Array (advancePtr, copyArray, ) +import qualified System.Unsafe as Unsafe + +import qualified Data.Traversable as Traversable +import Data.Maybe.HT (toMaybe, ) +import Data.Maybe (isJust, ) + +-- import Prelude (Int, ($), (+), return, const, ) +import Prelude hiding (read, length, ) + + +-- * access to mutable storable vector + +{-# INLINE new #-} +new :: (Storable e) => + Int -> e -> ST s (Vector s e) +new n x = + unsafeCreate n $ + let {-# INLINE go #-} + go m p = + if m>0 + then poke p x >> go (pred m) (V.incPtr p) + else return () + in go n + +{-# INLINE new_ #-} +new_ :: (Storable e) => + Int -> ST s (Vector s e) +new_ n = + unsafeCreate n (const (return ())) + + +{- | +> Control.Monad.ST.runST (do arr <- new_ 10; Monad.zipWithM_ (write arr) [9,8..0] ['a'..]; read arr 3) +-} +{-# INLINE read #-} +read :: (Storable e) => + Vector s e -> Int -> ST s e +read v n = + access "read" v n $ unsafeRead v n + +{- | +> VS.unpack $ runSTVector (do arr <- new_ 10; Monad.zipWithM_ (write arr) [9,8..0] ['a'..]; return arr) +-} +{-# INLINE write #-} +write :: (Storable e) => + Vector s e -> Int -> e -> ST s () +write v n x = + access "write" v n $ unsafeWrite v n x + +{- | +> VS.unpack $ runSTVector (do arr <- new 10 'a'; Monad.mapM_ (\n -> modify arr (mod n 8) succ) [0..10]; return arr) +-} +{-# INLINE modify #-} +modify :: (Storable e) => + Vector s e -> Int -> (e -> e) -> ST s () +modify v n f = + access "modify" v n $ unsafeModify v n f + +{-# INLINE access #-} +access :: (Storable e) => + String -> Vector s e -> Int -> ST s a -> ST s a +access name (SV _v l) n act = + if 0<=n && n Control.Monad.ST.runST (do arr <- new_ 10; Monad.zipWithM_ (write arr) [9,8..0] ['a'..]; read arr 3) + +In future 'maybeRead' will replace 'read'. +-} +{-# INLINE maybeRead #-} +maybeRead :: (Storable e) => + Vector s e -> Int -> ST s (Maybe e) +maybeRead v n = + maybeAccess v n $ unsafeRead v n + +{- | +Returns 'True' if the element could be written +and 'False' if the index was out of range. + +> runSTVector (do arr <- new_ 10; foldr (\c go i -> maybeWrite arr i c >>= \cont -> if cont then go (succ i) else return arr) (error "unreachable") ['a'..] 0) + +In future 'maybeWrite' will replace 'write'. +-} +{-# INLINE maybeWrite #-} +maybeWrite :: (Storable e) => + Vector s e -> Int -> e -> ST s Bool +maybeWrite v n x = + fmap isJust $ maybeAccess v n $ unsafeWrite v n x + +{- | +Similar to 'maybeWrite'. + +In future 'maybeModify' will replace 'modify'. +-} +{-# INLINE maybeModify #-} +maybeModify :: (Storable e) => + Vector s e -> Int -> (e -> e) -> ST s Bool +maybeModify v n f = + fmap isJust $ maybeAccess v n $ unsafeModify v n f + +{-# INLINE maybeAccess #-} +maybeAccess :: (Storable e) => + Vector s e -> Int -> ST s a -> ST s (Maybe a) +maybeAccess (SV _v l) n act = + Traversable.sequence $ toMaybe (0<=n && n + Vector s e -> Int -> ST s e +unsafeRead v n = + unsafeAccess v n $ peek + +{-# INLINE unsafeWrite #-} +unsafeWrite :: (Storable e) => + Vector s e -> Int -> e -> ST s () +unsafeWrite v n x = + unsafeAccess v n $ \p -> poke p x + +{-# INLINE unsafeModify #-} +unsafeModify :: (Storable e) => + Vector s e -> Int -> (e -> e) -> ST s () +unsafeModify v n f = + unsafeAccess v n $ \p -> poke p . f =<< peek p + +{-# INLINE unsafeAccess #-} +unsafeAccess :: (Storable e) => + Vector s e -> Int -> (Ptr e -> IO a) -> ST s a +unsafeAccess (SV v _l) n act = + Unsafe.ioToST (withForeignPtr v $ \p -> act (advancePtr p n)) + + +{-# INLINE freeze #-} +freeze :: (Storable e) => + Vector s e -> ST s (VS.Vector e) +freeze (SV x l) = + Unsafe.ioToST $ + V.create l $ \p -> + withForeignPtr x $ \f -> + copyArray p f (fromIntegral l) + +{- | +This is like 'freeze' but it does not copy the vector. +You must make sure that you never write again to the array. +It is best to use 'unsafeFreeze' only at the end of a block, +that is run by 'runST'. +-} +{-# INLINE unsafeFreeze #-} +unsafeFreeze :: (Storable e) => + Vector s e -> ST s (VS.Vector e) +unsafeFreeze = unsafeToVector + + +{-# INLINE thaw #-} +thaw :: (Storable e) => + VS.Vector e -> ST s (Vector s e) +thaw v = + Unsafe.ioToST $ + V.withStartPtr v $ \f l -> + create l $ \p -> + copyArray p f (fromIntegral l) + + +{-# INLINE length #-} +length :: + Vector s e -> Int +length (SV _v l) = l + + +{-# INLINE runSTVector #-} +runSTVector :: (Storable e) => + (forall s. ST s (Vector s e)) -> VS.Vector e +runSTVector m = + runST (unsafeToVector =<< m) + + + +-- * operations on immutable storable vector within ST monad + +{- | +> :module + Data.STRef +> VS.unpack $ Control.Monad.ST.runST (do ref <- newSTRef 'a'; mapST (\ _n -> do c <- readSTRef ref; modifySTRef ref succ; return c) (VS.pack [1,2,3,4::Data.Int.Int16])) +-} +{-# INLINE mapST #-} +mapST :: (Storable a, Storable b) => + (a -> ST s b) -> VS.Vector a -> ST s (VS.Vector b) +mapST f (V.SV px sx n) = + let {-# INLINE go #-} + go l q p = + if l>0 + then + do Unsafe.ioToST . poke p =<< f =<< Unsafe.ioToST (peek q) + go (pred l) (advancePtr q 1) (advancePtr p 1) + else return () + in do ys@(SV py _) <- new_ n + go n + (Unsafe.foreignPtrToPtr px `advancePtr` sx) + (Unsafe.foreignPtrToPtr py) + unsafeToVector ys + +{- +mapST f xs@(V.SV v s l) = + let go l q p = + if l>0 + then + do poke p =<< stToIO . f =<< peek q + go (pred l) (advancePtr q 1) (advancePtr p 1) + else return () + n = VS.length xs + in return $ V.unsafeCreate n $ \p -> + withForeignPtr v $ \q -> go n (advancePtr q s) p +-} + + +{- | +> *Data.StorableVector.ST.Strict Data.STRef> VL.unpack $ Control.Monad.ST.runST (do ref <- newSTRef 'a'; mapSTLazy (\ _n -> do c <- readSTRef ref; modifySTRef ref succ; return c) (VL.pack VL.defaultChunkSize [1,2,3,4::Data.Int.Int16])) +> "abcd" + +The following should not work on infinite streams, +since we are in 'ST' with strict '>>='. +But it works. Why? + +> *Data.StorableVector.ST.Strict Data.STRef> VL.unpack $ Control.Monad.ST.runST (do ref <- newSTRef 'a'; mapSTLazy (\ _n -> do c <- readSTRef ref; modifySTRef ref succ; return c) (VL.pack VL.defaultChunkSize [0::Data.Int.Int16 ..])) +> "Interrupted. +-} +{-# INLINE mapSTLazy #-} +mapSTLazy :: (Storable a, Storable b) => + (a -> ST s b) -> VL.Vector a -> ST s (VL.Vector b) +mapSTLazy f (VL.SV xs) = + fmap VL.SV $ mapM (mapST f) xs diff --git a/storablevector.cabal b/storablevector.cabal --- a/storablevector.cabal +++ b/storablevector.cabal @@ -1,5 +1,5 @@ Name: storablevector -Version: 0.2.8.3 +Version: 0.2.9 Category: Data Synopsis: Fast, packed, strict storable arrays with a list interface like ByteString Description: @@ -25,9 +25,10 @@ Homepage: http://www.haskell.org/haskellwiki/Storable_Vector Stability: Experimental Build-Type: Simple -Tested-With: GHC==6.8.2, GHC==6.12.3, GHC==7.4.1, GHC==7.6.2 +Tested-With: GHC==6.8.2, GHC==6.12.3 +Tested-With: GHC==7.4.1, GHC==7.6.2, GHC==7.8.2 Tested-With: JHC==0.7.3 -Cabal-Version: >=1.6 +Cabal-Version: >=1.14 Extra-Source-Files: foreign-ptr/fast/Data/StorableVector/Memory.hs foreign-ptr/slow/Data/StorableVector/Memory.hs @@ -39,13 +40,7 @@ Flag separateSYB description: Data.Generics available in separate package. -Flag functorInstance - description: Use a custom Functor instance for pairs and functions -Flag buildTests - description: Build test executables - default: False - Source-Repository head type: darcs location: http://code.haskell.org/storablevector/ @@ -53,13 +48,14 @@ Source-Repository this type: darcs location: http://code.haskell.org/storablevector/ - tag: 0.2.8.3 + tag: 0.2.9 + Library Build-Depends: non-negative >=0.1 && <0.2, utility-ht >=0.0.5 && <0.1, - transformers >=0.2 && <0.4, + transformers >=0.2 && <0.5, unsafe >=0.0 && <0.1, QuickCheck >=1 && <3 @@ -81,9 +77,9 @@ Else Build-Depends: base >=1 && <2 - Extensions: CPP, ForeignFunctionInterface GHC-Options: -Wall -funbox-strict-fields - Hs-Source-Dirs: . + Default-Language: Haskell98 + Hs-Source-Dirs: src Exposed-Modules: Data.StorableVector @@ -108,59 +104,53 @@ Data.StorableVector.Lazy.PointerPrivateIndex - -Executable test +Test-Suite test + Type: exitcode-stdio-1.0 GHC-Options: -Wall -funbox-strict-fields - Hs-Source-Dirs: ., foreign-ptr/slow, tests - Main-Is: tests.hs - Other-Modules: QuickCheckUtils, Instances - Extensions: CPP, ForeignFunctionInterface - If flag(buildTests) + Default-Language: Haskell98 + Hs-Source-Dirs: tests + Main-Is: Test.hs + Other-Modules: Test.Utility + Build-Depends: + storablevector, + bytestring >=0.9 && <0.11, + QuickCheck >=1 && <3 + If flag(splitBase) Build-Depends: - bytestring >=0.9 && <0.11, - QuickCheck >=1 && <3 - If flag(splitBase) - Build-Depends: random >=1.0 && <1.1 - If flag(functorInstance) - Hs-Source-Dirs: tests-2 - Build-Depends: base >=3 && <4 - Else - Hs-Source-Dirs: tests-1 - Build-Depends: base >=4 && <5 - Else - Hs-Source-Dirs: tests-1 - Build-Depends: base >=1.0 && <2 + random >=1.0 && <1.1, + base >=3 && <5 Else - Buildable: False + Hs-Source-Dirs: tests-1 + Build-Depends: base >=1.0 && <2 -Executable speedtest +Benchmark speedtest + Type: exitcode-stdio-1.0 GHC-Options: -Wall -- -fvia-C -optc-ffast-math -optc-O3 -optc-ftree-vectorize Main-Is: SpeedTestChorus.hs Other-Modules: Data.StorableVector.Private - Extensions: CPP, ForeignFunctionInterface - Hs-Source-Dirs: ., foreign-ptr/slow, speedtest - If flag(buildTests) - Build-Depends: - sample-frame >=0.0.1 && <0.1, - deepseq >=1.1 && <1.4 - If flag(splitBase) - Build-Depends: base >= 3 && <5 - Else - Build-Depends: base >= 1.0 && < 2 + Default-Language: Haskell98 + Hs-Source-Dirs: speedtest + Build-Depends: + storablevector, + sample-frame >=0.0.1 && <0.1, + deepseq >=1.1 && <1.4 + If flag(splitBase) + Build-Depends: base >= 3 && <5 Else - Buildable: False + Build-Depends: base >= 1.0 && < 2 -Executable speedpointer +Benchmark speedpointer + Type: exitcode-stdio-1.0 GHC-Options: -Wall Main-Is: Pointer.hs - Extensions: CPP, ForeignFunctionInterface - Hs-Source-Dirs: ., foreign-ptr/slow, speedtest - If flag(buildTests) - If flag(splitBase) - Build-Depends: base >=3 && <5 - Else - Build-Depends: base >=1.0 && <2 + Default-Language: Haskell98 + Hs-Source-Dirs: speedtest + Build-Depends: + storablevector, + utility-ht + If flag(splitBase) + Build-Depends: base >=3 && <5 Else - Buildable: False + Build-Depends: base >=1.0 && <2 diff --git a/tests-2/Instances.hs b/tests-2/Instances.hs deleted file mode 100644 --- a/tests-2/Instances.hs +++ /dev/null @@ -1,1 +0,0 @@ -module Instances where diff --git a/tests/QuickCheckUtils.hs b/tests/QuickCheckUtils.hs deleted file mode 100644 --- a/tests/QuickCheckUtils.hs +++ /dev/null @@ -1,225 +0,0 @@ -{-# OPTIONS_GHC -O -fglasgow-exts #-} --- --- Uses multi-param type classes --- -module QuickCheckUtils where - -import Instances () - -import Test.QuickCheck --- import Test.QuickCheck (Arbitrary(arbitrary, coarbitrary), variant, choose, sized, (==>), Property, ) -import Text.Show.Functions () -import System.Random (RandomGen, StdGen, Random, newStdGen, split, randomR, random, ) - -import Control.Monad (liftM2) -import Data.Char (ord) -import Data.Word (Word8) -import Data.Int (Int64) -import System.IO (hFlush, stdout, ) - -import qualified Data.ByteString as P -import qualified Data.StorableVector as V -import qualified Data.List as List - -import qualified Data.ByteString.Char8 as PC - --- Enable this to get verbose test output. Including the actual tests. -debug = False - -mytest :: Testable a => a -> Int -> IO () -mytest a n = mycheck defaultConfig - { configMaxTest=n - , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a - -mycheck :: Testable a => Config -> a -> IO () -mycheck config a = - do rnd <- newStdGen - mytests config (evaluate a) rnd 0 0 [] - -mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO () -mytests config gen rnd0 ntest nfail stamps - | ntest == configMaxTest config = do done "OK," ntest stamps - | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps - | otherwise = - do putStr (configEvery config ntest (arguments result)) >> hFlush stdout - case ok result of - Nothing -> - mytests config gen rnd1 ntest (nfail+1) stamps - Just True -> - mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps) - Just False -> - putStr ( "Falsifiable after " - ++ show ntest - ++ " tests:\n" - ++ unlines (arguments result) - ) >> hFlush stdout - where - result = generate (configSize config ntest) rnd2 gen - (rnd1,rnd2) = split rnd0 - -done :: String -> Int -> [[String]] -> IO () -done mesg ntest stamps = - do putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table ) - where - table = display - . map entry - . reverse - . List.sort - . map pairLength - . List.group - . List.sort - . filter (not . null) - $ stamps - - display [] = ".\n" - display [x] = " (" ++ x ++ ").\n" - display xs = ".\n" ++ unlines (map (++ ".") xs) - - pairLength xss@(xs:_) = (length xss, xs) - entry (n, xs) = percentage n ntest - ++ " " - ++ concat (List.intersperse ", " xs) - - percentage n m = show ((100 * n) `div` m) ++ "%" - ------------------------------------------------------------------------- - -instance Arbitrary Char where - arbitrary = choose ('a', 'i') - coarbitrary c = variant (ord c `rem` 4) - -instance Arbitrary Word8 where - arbitrary = choose (97, 105) - coarbitrary c = variant (fromIntegral ((fromIntegral c) `rem` 4)) - -instance Arbitrary Int64 where - arbitrary = sized $ \n -> choose (-fromIntegral n,fromIntegral n) - coarbitrary n = variant (fromIntegral (if n >= 0 then 2*n else 2*(-n) + 1)) - -{- -instance Arbitrary Char where - arbitrary = choose ('\0', '\255') -- since we have to test words, unlines too - coarbitrary c = variant (ord c `rem` 16) - -instance Arbitrary Word8 where - arbitrary = choose (minBound, maxBound) - coarbitrary c = variant (fromIntegral ((fromIntegral c) `rem` 16)) --} - -instance Random Word8 where - randomR = integralRandomR - random = randomR (minBound,maxBound) - -instance Random Int64 where - randomR = integralRandomR - random = randomR (minBound,maxBound) - -integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g) -integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer, - fromIntegral b :: Integer) g of - (x,g) -> (fromIntegral x, g) - -instance Arbitrary V where - arbitrary = V.pack `fmap` arbitrary - coarbitrary s = coarbitrary (V.unpack s) - -instance Arbitrary P.ByteString where - arbitrary = P.pack `fmap` arbitrary - coarbitrary s = coarbitrary (P.unpack s) - - ------------------------------------------------------------------------- --- --- We're doing two forms of testing here. Firstly, model based testing. --- For our Lazy and strict bytestring types, we have model types: --- --- i.e. Lazy == Byte --- \\ // --- List --- --- That is, the Lazy type can be modeled by functions in both the Byte --- and List type. For each of the 3 models, we have a set of tests that --- check those types match. --- --- The Model class connects a type and its model type, via a conversion --- function. --- --- -class Model a b where - model :: a -> b -- get the abstract value from a concrete value - --- --- Connecting our Lazy and Strict types to their models. We also check --- the data invariant on Lazy types. --- --- These instances represent the arrows in the above diagram --- -instance Model P [W] where model = P.unpack -instance Model P [Char] where model = PC.unpack -instance Model V [W] where model = V.unpack -instance Model V P where model = P.pack . V.unpack - --- Types are trivially modeled by themselves -instance Model Bool Bool where model = id -instance Model Int Int where model = id -instance Model Int64 Int64 where model = id -instance Model Int64 Int where model = fromIntegral -instance Model Word8 Word8 where model = id -instance Model Ordering Ordering where model = id -instance Model Char Char where model = id - --- More structured types are modeled recursively, using the NatTrans class from Gofer. -class (Functor f, Functor g) => NatTrans f g where - eta :: f a -> g a - --- The transformation of the same type is identity -instance NatTrans [] [] where eta = id -instance NatTrans Maybe Maybe where eta = id -instance NatTrans ((->) X) ((->) X) where eta = id -instance NatTrans ((->) W) ((->) W) where eta = id -instance NatTrans ((->) Char) ((->) Char) where eta = id - --- We have a transformation of pairs, if the pairs are in Model -instance Model f g => NatTrans ((,) f) ((,) g) where eta (f,a) = (model f, a) - --- And finally, we can take any (m a) to (n b), if we can Model m n, and a b -instance (NatTrans m n, Model a b) => Model (m a) (n b) where model x = fmap model (eta x) - ------------------------------------------------------------------------- - --- Some short hand. -type X = Int -type W = Word8 -type P = P.ByteString -type V = V.Vector Word8 - ------------------------------------------------------------------------- --- --- These comparison functions handle wrapping and equality. --- --- A single class for these would be nice, but note that they differe in --- the number of arguments, and those argument types, so we'd need HList --- tricks. See here: http://okmij.org/ftp/Haskell/vararg-fn.lhs --- - -eq1 f g = \a -> - model (f a) == g (model a) -eq2 f g = \a b -> - model (f a b) == g (model a) (model b) -eq3 f g = \a b c -> - model (f a b c) == g (model a) (model b) (model c) -eq4 f g = \a b c d -> - model (f a b c d) == g (model a) (model b) (model c) (model d) -eq5 f g = \a b c d e -> - model (f a b c d e) == g (model a) (model b) (model c) (model d) (model e) - --- --- And for functions that take non-null input --- -eqnotnull1 f g = \x -> (not (isNull x)) ==> eq1 f g x -eqnotnull2 f g = \x y -> (not (isNull y)) ==> eq2 f g x y -eqnotnull3 f g = \x y z -> (not (isNull z)) ==> eq3 f g x y z - -class IsNull t where isNull :: t -> Bool -instance IsNull P.ByteString where isNull = P.null -instance IsNull V where isNull = V.null diff --git a/tests/Test.hs b/tests/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Test.hs @@ -0,0 +1,212 @@ +import qualified Data.StorableVector as V +import qualified Data.ByteString as P +import Test.QuickCheck (Property, quickCheck, ) +import Test.Utility + (V, W, X, P, applyId, applyModel, + eq0, eq1, eq2, eqnotnull1, eqnotnull2, eqnotnull3, ) +import Text.Printf (printf) + + +-- * compare Data.StorableVector <=> ByteString + +limit :: Int -> Int +limit = flip mod 10000 + +prop_concatVP :: [V] -> Bool +prop_nullVP :: V -> Bool +prop_reverseVP :: V -> Bool +prop_transposeVP :: [V] -> Bool +prop_groupVP :: V -> Bool +prop_initsVP :: V -> Bool +prop_tailsVP :: V -> Bool +prop_allVP :: (W -> Bool) -> V -> Bool +prop_anyVP :: (W -> Bool) -> V -> Bool +prop_appendVP :: V -> V -> Bool +prop_breakVP :: (W -> Bool) -> V -> Bool +prop_concatMapVP :: (W -> V) -> V -> Bool +prop_consVP :: W -> V -> Bool +prop_countVP :: W -> V -> Bool +prop_dropVP :: X -> V -> Bool +prop_dropWhileVP :: (W -> Bool) -> V -> Bool +prop_filterVP :: (W -> Bool) -> V -> Bool +prop_findVP :: (W -> Bool) -> V -> Bool +prop_findIndexVP :: (W -> Bool) -> V -> Bool +prop_findIndicesVP :: (W -> Bool) -> V -> Bool +prop_isPrefixOfVP :: V -> V -> Bool +prop_mapVP :: (W -> W) -> V -> Bool +prop_replicateVP :: X -> W -> Bool +prop_iterateVP :: X -> (W -> W) -> W -> Bool +prop_snocVP :: V -> W -> Bool +prop_spanVP :: (W -> Bool) -> V -> Bool +prop_splitVP :: W -> V -> Bool +prop_splitAtVP :: X -> V -> Bool +prop_takeVP :: X -> V -> Bool +prop_takeWhileVP :: (W -> Bool) -> V -> Bool +prop_elemVP :: W -> V -> Bool +prop_notElemVP :: W -> V -> Bool +prop_elemIndexVP :: W -> V -> Bool +prop_elemIndicesVP :: W -> V -> Bool +prop_lengthVP :: V -> Bool +prop_headVP :: V -> Property +prop_initVP :: V -> Property +prop_lastVP :: V -> Property +prop_maximumVP :: V -> Property +prop_minimumVP :: V -> Property +prop_tailVP :: V -> Property +prop_foldl1VP :: (W -> W -> W) -> V -> Property +prop_foldl1VP' :: (W -> W -> W) -> V -> Property +prop_foldr1VP :: (W -> W -> W) -> V -> Property +prop_scanlVP :: (W -> W -> W) -> W -> V -> Property +prop_scanrVP :: (W -> W -> W) -> W -> V -> Property +prop_eqVP :: V -> V -> Bool +prop_foldlVP :: (X -> W -> X) -> X -> V -> Bool +prop_foldlVP' :: (X -> W -> X) -> X -> V -> Bool +prop_foldrVP :: (W -> X -> X) -> X -> V -> Bool +prop_mapAccumLVP :: (X -> W -> (X, W)) -> X -> V -> Bool +prop_mapAccumRVP :: (X -> W -> (X, W)) -> X -> V -> Bool +prop_zipWithVP :: (W -> W -> W) -> V -> V -> Bool + +prop_concatVP = V.concat `eq1` P.concat +prop_nullVP = V.null `eq1` P.null +prop_reverseVP = V.reverse `eq1` P.reverse +prop_transposeVP = V.transpose `eq1` P.transpose +prop_groupVP = V.group `eq1` P.group +prop_initsVP = V.inits `eq1` P.inits +prop_tailsVP = V.tails `eq1` P.tails +prop_allVP = V.all `eq2` P.all +prop_anyVP = V.any `eq2` P.any +prop_appendVP = V.append `eq2` P.append +prop_breakVP = V.break `eq2` P.break +prop_concatMapVP = V.concatMap `eq2` P.concatMap +prop_consVP = V.cons `eq2` P.cons +prop_countVP = V.count `eq2` P.count +prop_dropVP = V.drop `eq2` P.drop +prop_dropWhileVP = V.dropWhile `eq2` P.dropWhile +prop_filterVP = V.filter `eq2` P.filter +prop_findVP = V.find `eq2` P.find +prop_findIndexVP = V.findIndex `eq2` P.findIndex +prop_findIndicesVP = V.findIndices `eq2` P.findIndices +prop_isPrefixOfVP = V.isPrefixOf `eq2` P.isPrefixOf +prop_mapVP = V.map `eq2` P.map +prop_replicateVP = (\n -> V.replicate n `eq1` P.replicate n) . limit +prop_iterateVP = (\n f -> V.iterateN n f `eq1` P.pack . take n . iterate f) . limit +prop_snocVP = V.snoc `eq2` P.snoc +prop_spanVP = V.span `eq2` P.span +prop_splitVP = V.split `eq2` P.split +prop_splitAtVP = V.splitAt `eq2` P.splitAt +prop_takeVP = V.take `eq2` P.take +prop_takeWhileVP = V.takeWhile `eq2` P.takeWhile +prop_elemVP = V.elem `eq2` P.elem +prop_notElemVP = V.notElem `eq2` P.notElem +prop_elemIndexVP = V.elemIndex `eq2` P.elemIndex +prop_elemIndicesVP = V.elemIndices `eq2` P.elemIndices +prop_lengthVP = V.length `eq1` P.length + +prop_headVP = V.head `eqnotnull1` P.head +prop_initVP = V.init `eqnotnull1` P.init +prop_lastVP = V.last `eqnotnull1` P.last +prop_maximumVP = V.maximum `eqnotnull1` P.maximum +prop_minimumVP = V.minimum `eqnotnull1` P.minimum +prop_tailVP = V.tail `eqnotnull1` P.tail +prop_foldl1VP = V.foldl1 `eqnotnull2` P.foldl1 +prop_foldl1VP' = V.foldl1' `eqnotnull2` P.foldl1' +prop_foldr1VP = V.foldr1 `eqnotnull2` P.foldr1 +prop_scanlVP = V.scanl `eqnotnull3` P.scanl +prop_scanrVP = V.scanr `eqnotnull3` P.scanr + +prop_eqVP = + eq2 + ((==) :: V -> V -> Bool) + ((==) :: P -> P -> Bool) +prop_foldlVP f b as = + uncurry eq0 + ((V.foldl, P.foldl) `applyId` f `applyId` b `applyModel` as) +prop_foldlVP' f b as = + uncurry eq0 + ((V.foldl', P.foldl') `applyId` f `applyId` b `applyModel` as) +prop_foldrVP f b as = + uncurry eq0 + ((V.foldr, P.foldr) `applyId` f `applyId` b `applyModel` as) +prop_mapAccumLVP f b as = + uncurry eq0 + ((V.mapAccumL, P.mapAccumL) `applyId` f `applyId` b `applyModel` as) +prop_mapAccumRVP f b as = + uncurry eq0 + ((V.mapAccumR, P.mapAccumR) `applyId` f `applyId` b `applyModel` as) +prop_zipWithVP f xs ys = + uncurry eq0 + ((V.zipWith f, \x y -> P.pack (P.zipWith f x y)) `applyModel` xs `applyModel` ys) + +prop_unfoldrVP :: Int -> (X -> Maybe (W, X)) -> X -> Bool +prop_unfoldrVP n0 f = + let n = limit n0 + in eq1 + (fst . V.unfoldrN n f) + (fst . P.unfoldrN n f) + + +vp_tests :: [(String, IO ())] +vp_tests = + ("all", quickCheck prop_allVP) : + ("any", quickCheck prop_anyVP) : + ("append", quickCheck prop_appendVP) : + ("concat", quickCheck prop_concatVP) : + ("cons", quickCheck prop_consVP) : + ("eq", quickCheck prop_eqVP) : + ("filter", quickCheck prop_filterVP) : + ("find", quickCheck prop_findVP) : + ("findIndex", quickCheck prop_findIndexVP) : + ("findIndices", quickCheck prop_findIndicesVP) : + ("foldl", quickCheck prop_foldlVP) : + ("foldl'", quickCheck prop_foldlVP') : + ("foldl1", quickCheck prop_foldl1VP) : + ("foldl1'", quickCheck prop_foldl1VP') : + ("foldr", quickCheck prop_foldrVP) : + ("foldr1", quickCheck prop_foldr1VP) : + ("mapAccumL", quickCheck prop_mapAccumLVP) : + ("mapAccumR", quickCheck prop_mapAccumRVP) : + ("zipWith", quickCheck prop_zipWithVP) : + ("unfoldr", quickCheck prop_unfoldrVP) : + ("head", quickCheck prop_headVP) : + ("init", quickCheck prop_initVP) : + ("isPrefixOf", quickCheck prop_isPrefixOfVP) : + ("last", quickCheck prop_lastVP) : + ("length", quickCheck prop_lengthVP) : + ("map", quickCheck prop_mapVP) : + ("maximum", quickCheck prop_maximumVP) : + ("minimum", quickCheck prop_minimumVP) : + ("null", quickCheck prop_nullVP) : + ("reverse", quickCheck prop_reverseVP) : + ("snoc", quickCheck prop_snocVP) : + ("tail", quickCheck prop_tailVP) : + ("scanl", quickCheck prop_scanlVP) : + ("scanr", quickCheck prop_scanrVP) : + ("transpose", quickCheck prop_transposeVP) : + ("replicate", quickCheck prop_replicateVP) : + ("iterateN", quickCheck prop_iterateVP) : + ("take", quickCheck prop_takeVP) : + ("drop", quickCheck prop_dropVP) : + ("splitAt", quickCheck prop_splitAtVP) : + ("takeWhile", quickCheck prop_takeWhileVP) : + ("dropWhile", quickCheck prop_dropWhileVP) : + ("break", quickCheck prop_breakVP) : + ("span", quickCheck prop_spanVP) : + ("split", quickCheck prop_splitVP) : + ("count", quickCheck prop_countVP) : + ("group", quickCheck prop_groupVP) : + ("inits", quickCheck prop_initsVP) : + ("tails", quickCheck prop_tailsVP) : + ("elem", quickCheck prop_elemVP) : + ("notElem", quickCheck prop_notElemVP) : + ("elemIndex", quickCheck prop_elemIndexVP) : + ("elemIndices", quickCheck prop_elemIndicesVP) : + ("concatMap", quickCheck prop_concatMapVP) : + [] + + +main :: IO () +main = run vp_tests + +run :: [(String, IO ())] -> IO () +run tests = do + mapM_ (\(s,a) -> printf "%-25s: " s >> a) tests diff --git a/tests/Test/Utility.hs b/tests/Test/Utility.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Utility.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +module Test.Utility where + +import Test.QuickCheck (Property, (==>), ) +import Text.Show.Functions () + +import Data.Word (Word8) +import Data.Int (Int64) + +import qualified Data.ByteString as P +import qualified Data.StorableVector as V + +import qualified Data.ByteString.Char8 as PC + + +{- | +Class allows to compare StorableVector implementation +with implementations for similar data structures, +here ByteString and [Word8]. +-} +class Model a b where + model :: a -> b + +instance Model P [W] where model = P.unpack +instance Model P [Char] where model = PC.unpack +instance Model V [W] where model = V.unpack +instance Model V P where model = P.pack . V.unpack + +instance Model Bool Bool where model = id +instance Model Int Int where model = id +instance Model Int64 Int64 where model = id +instance Model Int64 Int where model = fromIntegral +instance Model Word8 Word8 where model = id +instance Model Ordering Ordering where model = id +instance Model Char Char where model = id + +instance (Model x y) => Model (a -> x) (a -> y) where + model f = model . f + +instance (Model x y) => Model (Maybe x) (Maybe y) where + model = fmap model + +instance (Model x y) => Model [x] [y] where + model = fmap model + +instance + (Model x0 y0, Model x1 y1) => + Model (x0,x1) (y0,y1) where + model (x0,x1) = (model x0, model x1) + + +type X = Int +type W = Word8 +type P = P.ByteString +type V = V.Vector Word8 + + +infixl 0 `applyId`, `applyModel` + +applyId :: (a -> x, a -> y) -> a -> (x,y) +applyId (f,g) a = (f a, g a) + +applyModel :: (Model x0 y0) => (x0 -> x, y0 -> y) -> x0 -> (x,y) +applyModel (f,g) x = (f x, g $ model x) + + +{- +These comparison functions handle wrapping and equality automatically. +-} +eq0 :: + (Model x y, Eq y) => + x -> y -> Bool + +eq1 :: + (Model x1 y1, Model x y, Eq y) => + (x1 -> x) -> (y1 -> y) -> x1 -> Bool + +eq2 :: + (Model x2 y2, Model x1 y1, Model x y, Eq y) => + (x2 -> x1 -> x) -> (y2 -> y1 -> y) -> x2 -> x1 -> Bool + +eq3 :: + (Model x3 y3, Model x2 y2, Model x1 y1, Model x y, Eq y) => + (x3 -> x2 -> x1 -> x) -> (y3 -> y2 -> y1 -> y) -> x3 -> x2 -> x1 -> Bool + +eq4 :: + (Model x4 y4, Model x3 y3, Model x2 y2, Model x1 y1, Model x y, Eq y) => + (x4 -> x3 -> x2 -> x1 -> x) -> + (y4 -> y3 -> y2 -> y1 -> y) -> + x4 -> x3 -> x2 -> x1 -> Bool + +eq5 :: + (Model x5 y5, Model x4 y4, Model x3 y3, Model x2 y2, Model x1 y1, Model x y, Eq y) => + (x5 -> x4 -> x3 -> x2 -> x1 -> x) -> + (y5 -> y4 -> y3 -> y2 -> y1 -> y) -> + x5 -> x4 -> x3 -> x2 -> x1 -> Bool + + +infix 4 `eq1`, `eq2`, `eq3`, `eq4`, `eq5` + +eq0 f g = + model f == g +eq1 f g = \a -> + model (f a) == g (model a) +eq2 f g = \a b -> + model (f a b) == g (model a) (model b) +eq3 f g = \a b c -> + model (f a b c) == g (model a) (model b) (model c) +eq4 f g = \a b c d -> + model (f a b c d) == g (model a) (model b) (model c) (model d) +eq5 f g = \a b c d e -> + model (f a b c d e) == g (model a) (model b) (model c) (model d) (model e) + + +{- +Handle functions that require non-empty input. +-} +eqnotnull1 :: + (Model x y, Model x1 y1, IsNull x1, Eq y) => + (x1 -> x) -> (y1 -> y) -> x1 -> Property + +eqnotnull2 :: + (Model x y, Model x1 y1, Model x2 y2, IsNull x1, Eq y) => + (x2 -> x1 -> x) -> (y2 -> y1 -> y) -> x2 -> x1 -> Property + +eqnotnull3 :: + (Model x y, Model x1 y1, Model x2 y2, Model x3 y3, IsNull x1, + Eq y) => + (x3 -> x2 -> x1 -> x) -> + (y3 -> y2 -> y1 -> y) -> + x3 -> x2 -> x1 -> Property + +eqnotnull1 f g = \x -> not (isNull x) ==> eq1 f g x +eqnotnull2 f g = \x y -> not (isNull y) ==> eq2 f g x y +eqnotnull3 f g = \x y z -> not (isNull z) ==> eq3 f g x y z + +class IsNull t where isNull :: t -> Bool +instance IsNull P.ByteString where isNull = P.null +instance IsNull V where isNull = V.null diff --git a/tests/tests.hs b/tests/tests.hs deleted file mode 100644 --- a/tests/tests.hs +++ /dev/null @@ -1,160 +0,0 @@ -{-# OPTIONS_GHC -O #-} -import qualified Data.StorableVector as V -import qualified Data.ByteString as P -import QuickCheckUtils - (V, W, X, P, mytest, - eq1, eq2, eq3, eqnotnull1, eqnotnull2, eqnotnull3, ) -import Text.Printf (printf) -import System.Environment (getArgs) - --- --- Data.StorableVector <=> ByteString --- - -prop_concatVP = (V.concat :: [V] -> V) `eq1` P.concat -prop_nullVP = (V.null :: V -> Bool) `eq1` P.null -prop_reverseVP = (V.reverse :: V -> V) `eq1` P.reverse -prop_transposeVP = (V.transpose :: [V] -> [V]) `eq1` P.transpose -prop_groupVP = (V.group :: V -> [V]) `eq1` P.group -prop_initsVP = (V.inits :: V -> [V]) `eq1` P.inits -prop_tailsVP = (V.tails :: V -> [V]) `eq1` P.tails -prop_allVP = (V.all :: (W -> Bool) -> V -> Bool) `eq2` P.all -prop_anyVP = (V.any :: (W -> Bool) -> V -> Bool) `eq2` P.any -prop_appendVP = (V.append :: V -> V -> V) `eq2` P.append -prop_breakVP = (V.break :: (W -> Bool) -> V -> (V, V)) `eq2` P.break -prop_concatMapVP = (V.concatMap :: (W -> V) -> V -> V) `eq2` P.concatMap -prop_consVP = (V.cons :: W -> V -> V) `eq2` P.cons -prop_countVP = (V.count :: W -> V -> X) `eq2` P.count -prop_dropVP = (V.drop :: X -> V -> V) `eq2` P.drop -prop_dropWhileVP = (V.dropWhile :: (W -> Bool) -> V -> V) `eq2` P.dropWhile -prop_filterVP = (V.filter :: (W -> Bool) -> V -> V) `eq2` P.filter -prop_findVP = (V.find :: (W -> Bool) -> V -> Maybe W) `eq2` P.find -prop_findIndexVP = (V.findIndex :: (W -> Bool) -> V -> Maybe X) `eq2` P.findIndex -prop_findIndicesVP = (V.findIndices :: (W -> Bool) -> V -> [X]) `eq2` P.findIndices -prop_isPrefixOfVP = (V.isPrefixOf :: V -> V -> Bool) `eq2` P.isPrefixOf -prop_mapVP = (V.map :: (W -> W) -> V -> V) `eq2` P.map -prop_replicateVP = (V.replicate :: X -> W -> V) `eq2` P.replicate -prop_iterateVP = (V.iterateN :: X -> (W -> W) -> W -> V) `eq3` (\n f -> P.pack . take n . iterate f) -prop_snocVP = (V.snoc :: V -> W -> V) `eq2` P.snoc -prop_spanVP = (V.span :: (W -> Bool) -> V -> (V, V)) `eq2` P.span -prop_splitVP = (V.split :: W -> V -> [V]) `eq2` P.split -prop_splitAtVP = (V.splitAt :: X -> V -> (V, V)) `eq2` P.splitAt -prop_takeVP = (V.take :: X -> V -> V) `eq2` P.take -prop_takeWhileVP = (V.takeWhile :: (W -> Bool) -> V -> V) `eq2` P.takeWhile -prop_elemVP = (V.elem :: W -> V -> Bool) `eq2` P.elem -prop_notElemVP = (V.notElem :: W -> V -> Bool) `eq2` P.notElem -prop_elemIndexVP = (V.elemIndex :: W -> V -> Maybe X) `eq2` P.elemIndex -prop_elemIndicesVP = (V.elemIndices :: W -> V -> [X])`eq2` P.elemIndices -prop_lengthVP = (V.length :: V -> X) `eq1` P.length - -prop_headVP = (V.head :: V -> W) `eqnotnull1` P.head -prop_initVP = (V.init :: V -> V) `eqnotnull1` P.init -prop_lastVP = (V.last :: V -> W) `eqnotnull1` P.last -prop_maximumVP = (V.maximum :: V -> W) `eqnotnull1` P.maximum -prop_minimumVP = (V.minimum :: V -> W) `eqnotnull1` P.minimum -prop_tailVP = (V.tail :: V -> V) `eqnotnull1` P.tail -prop_foldl1VP = (V.foldl1 :: (W -> W -> W) -> V -> W) `eqnotnull2` P.foldl1 -prop_foldl1VP' = (V.foldl1' :: (W -> W -> W) -> V -> W) `eqnotnull2` P.foldl1' -prop_foldr1VP = (V.foldr1 :: (W -> W -> W) -> V -> W) `eqnotnull2` P.foldr1 -prop_scanlVP = (V.scanl :: (W -> W -> W) -> W -> V -> V) `eqnotnull3` P.scanl -prop_scanrVP = (V.scanr :: (W -> W -> W) -> W -> V -> V) `eqnotnull3` P.scanr - -prop_eqVP = eq2 - ((==) :: V -> V -> Bool) - ((==) :: P -> P -> Bool) -prop_foldlVP = eq3 - (V.foldl :: (X -> W -> X) -> X -> V -> X) - (P.foldl :: (X -> W -> X) -> X -> P -> X) -prop_foldlVP' = eq3 - (V.foldl' :: (X -> W -> X) -> X -> V -> X) - (P.foldl' :: (X -> W -> X) -> X -> P -> X) -prop_foldrVP = eq3 - (V.foldr :: (W -> X -> X) -> X -> V -> X) - (P.foldr :: (W -> X -> X) -> X -> P -> X) -prop_mapAccumLVP = eq3 - (V.mapAccumL :: (X -> W -> (X,W)) -> X -> V -> (X, V)) - (P.mapAccumL :: (X -> W -> (X,W)) -> X -> P -> (X, P)) -prop_mapAccumRVP = eq3 - (V.mapAccumR :: (X -> W -> (X,W)) -> X -> V -> (X, V)) - (P.mapAccumR :: (X -> W -> (X,W)) -> X -> P -> (X, P)) -prop_zipWithVP = eq3 - (V.zipWith :: (W -> W -> W) -> V -> V -> V) --- (P.zipWith :: (W -> W -> W) -> P -> P -> P) - (\f x y -> P.pack (P.zipWith f x y) :: P) - -prop_unfoldrVP = eq3 - ((\n f a -> V.take (fromIntegral n) $ - V.unfoldr f a) :: Int -> (X -> Maybe (W,X)) -> X -> V) - ((\n f a -> fst $ - P.unfoldrN n f a) :: Int -> (X -> Maybe (W,X)) -> X -> P) - ------------------------------------------------------------------------- --- StorableVector <=> ByteString - -vp_tests = - [("all", mytest prop_allVP) - ,("any", mytest prop_anyVP) - ,("append", mytest prop_appendVP) - ,("concat", mytest prop_concatVP) - ,("cons", mytest prop_consVP) - ,("eq", mytest prop_eqVP) - ,("filter", mytest prop_filterVP) - ,("find", mytest prop_findVP) - ,("findIndex", mytest prop_findIndexVP) - ,("findIndices", mytest prop_findIndicesVP) - ,("foldl", mytest prop_foldlVP) - ,("foldl'", mytest prop_foldlVP') - ,("foldl1", mytest prop_foldl1VP) - ,("foldl1'", mytest prop_foldl1VP') - ,("foldr", mytest prop_foldrVP) - ,("foldr1", mytest prop_foldr1VP) - ,("mapAccumL", mytest prop_mapAccumLVP) - ,("mapAccumR", mytest prop_mapAccumRVP) - ,("zipWith", mytest prop_zipWithVP) - -- ,("unfoldr", mytest prop_unfoldrVP) - ,("head", mytest prop_headVP) - ,("init", mytest prop_initVP) - ,("isPrefixOf", mytest prop_isPrefixOfVP) - ,("last", mytest prop_lastVP) - ,("length", mytest prop_lengthVP) - ,("map", mytest prop_mapVP) - ,("maximum ", mytest prop_maximumVP) - ,("minimum" , mytest prop_minimumVP) - ,("null", mytest prop_nullVP) - ,("reverse", mytest prop_reverseVP) - ,("snoc", mytest prop_snocVP) - ,("tail", mytest prop_tailVP) - ,("scanl", mytest prop_scanlVP) - ,("scanr", mytest prop_scanrVP) - ,("transpose", mytest prop_transposeVP) - ,("replicate", mytest prop_replicateVP) - ,("iterateN", mytest prop_iterateVP) - ,("take", mytest prop_takeVP) - ,("drop", mytest prop_dropVP) - ,("splitAt", mytest prop_splitAtVP) - ,("takeWhile", mytest prop_takeWhileVP) - ,("dropWhile", mytest prop_dropWhileVP) - ,("break", mytest prop_breakVP) - ,("span", mytest prop_spanVP) - ,("split", mytest prop_splitVP) - ,("count", mytest prop_countVP) - ,("group", mytest prop_groupVP) - ,("inits", mytest prop_initsVP) - ,("tails", mytest prop_tailsVP) - ,("elem", mytest prop_elemVP) - ,("notElem", mytest prop_notElemVP) - ,("elemIndex", mytest prop_elemIndexVP) - ,("elemIndices", mytest prop_elemIndicesVP) - ,("concatMap", mytest prop_concatMapVP) - ] - ------------------------------------------------------------------------- --- The entry point - -main = run vp_tests - -run :: [(String, Int -> IO ())] -> IO () -run tests = do - x <- getArgs - let n = if null x then 100 else read . head $ x - mapM_ (\(s,a) -> printf "%-25s: " s >> a n) tests