storablevector (empty) → 0.1
raw patch · 6 files changed
+1567/−0 lines, 6 filesdep +QuickCheckdep +basedep +bytestringsetup-changed
Dependencies added: QuickCheck, base, bytestring, haskell98
Files
- Data/StorableVector.hs +1117/−0
- Data/StorableVector/Base.hs +230/−0
- LICENSE +30/−0
- Setup.lhs +3/−0
- storablevector.cabal +31/−0
- tests/tests.hs +156/−0
+ Data/StorableVector.hs view
@@ -0,0 +1,1117 @@+{-# OPTIONS_GHC -cpp -fglasgow-exts -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+--+--+-- License : BSD-style+--+-- Maintainer : sjanssen@cse.unl.edu+-- 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.++module Data.StorableVector (++ -- * The @Vector@ type+ Vector,++ -- * Introducing and eliminating 'Vector's+ empty,+ singleton,+ pack,+ unpack,+ packWith,+ unpackWith,++ -- * Basic interface+ cons,+ snoc,+ append,+ head,+ last,+ tail,+ init,+ null,+ length,+ viewL,+ viewR,++ -- * Transformating 'Vector's+ map,+ reverse,+ intersperse,+ transpose,++ -- * Reducing 'Vector's (folds)+ foldl,+ foldl',+ foldl1,+ foldl1',+ foldr,+ foldr1,++ -- ** Special folds+ concat,+ concatMap,+ any,+ all,+ maximum,+ minimum,++ -- * Building 'Vector's+ -- ** Scans+ scanl,+ scanl1,+ scanr,+ scanr1,++ -- ** Accumulating maps+ mapAccumL,+ mapAccumR,+ mapIndexed,++ -- ** Unfolding 'Vector's+ replicate,+ unfoldr,+ unfoldrN,++ -- * 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,+ unzip,+ copy,++ ) 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,unzip,notElem)++import Data.StorableVector.Base++import qualified Data.List as List++import Control.Exception (assert)++import Foreign.ForeignPtr+import Foreign.Marshal.Array+import Foreign.Ptr+import Foreign.Storable (Storable(..))++import Data.Monoid (Monoid, mempty, mappend, mconcat)++#if !defined(__GLASGOW_HASKELL__)+import System.IO.Unsafe+#endif++#if defined(__GLASGOW_HASKELL__)++import GHC.IOBase++#endif++-- -----------------------------------------------------------------------------+--+-- Useful macros, until we have bang patterns+--++#define STRICT1(f) f _a | _a `seq` False = undefined+#define STRICT2(f) f _a _b | _a `seq` _b `seq` False = undefined+#define STRICT3(f) f _a _b _c | _a `seq` _b `seq` _c `seq` False = undefined+#define STRICT4(f) f _a _b _c _d | _a `seq` _b `seq` _c `seq` _d `seq` False = undefined+#define STRICT5(f) f _a _b _c _d e | _a `seq` _b `seq` _c `seq` _d `seq` _e `seq` False = undefined++-- -----------------------------------------------------------------------------++instance (Storable a, Eq a) => Eq (Vector a)+ where (==) = eq++instance (Storable a) => Monoid (Vector a) where+ mempty = empty+ mappend = append+ mconcat = concat++-- | /O(n)/ Equality on the 'Vector' type.+eq :: (Storable a, Eq a) => Vector a -> Vector a -> Bool+eq a@(SV p s l) b@(SV p' s' l')+ | l /= l' = False -- short cut on length+ | p == p' && s == s' = True -- short cut for the same string+ | otherwise = unpack a == unpack b+{-# INLINE eq #-}++-- -----------------------------------------------------------------------------+-- 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 _ [] = return ()+ go p (x:xs) = poke p x >> go (p `advancePtr` 1) xs++-- | /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+ STRICT2(go)+ go _ [] = return ()+ go p (x:xs) = poke p (k x) >> go (p `advancePtr` 1) xs -- less space than pokeElemOff+{-# INLINE packWith #-}++-- | /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 (SV ps s l) = inlinePerformIO $ withForeignPtr ps $ \p ->+ go (p `advancePtr` s) (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 #-}++-- ---------------------------------------------------------------------+-- 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.+--++#if defined(__GLASGOW_HASKELL__)+{-# INLINE [1] length #-}+#endif++------------------------------------------------------------------------++-- | /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 (SV x s l) = unsafeCreate (l+1) $ \p -> withForeignPtr x $ \f -> do+ poke p c+ copyArray (p `advancePtr` 1) (f `advancePtr` s) (fromIntegral l)+{-# INLINE cons #-}++-- | /O(n)/ Append an element to the end of a 'Vector'+snoc :: (Storable a) => Vector a -> a -> Vector a+snoc (SV x s l) c = unsafeCreate (l+1) $ \p -> withForeignPtr x $ \f -> do+ copyArray (castPtr p) (f `advancePtr` s) 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 (SV x s l)+ | l <= 0 = errorEmptyList "head"+ | otherwise = inlinePerformIO $ withForeignPtr x $ \p -> peekElemOff 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 (SV p s l)+ | l <= 0 = errorEmptyList "tail"+ | otherwise = SV p (s+1) (l-1)+{-# INLINE tail #-}++-- | /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 ps@(SV x s l)+ | null ps = errorEmptyList "last"+ | otherwise = inlinePerformIO $ withForeignPtr x $ \p -> peekElemOff 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 ps@(SV p s l)+ | null ps = errorEmptyList "init"+ | otherwise = SV p s (l-1)+{-# INLINE init #-}++-- | /O(n)/ Append two Vectors+append :: (Storable a) => Vector a -> Vector a -> Vector a+append xs ys | null xs = ys+ | null ys = xs+ | otherwise = 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 (SV fp s len) = inlinePerformIO $ withForeignPtr fp $ \a ->+ create len $ map_ 0 (a `advancePtr` s)+ where+ STRICT3(map_)+ map_ n p1 p2+ | n >= len = return ()+ | otherwise = do+ x <- peekElemOff p1 n+ pokeElemOff p2 n (f x)+ map_ (n+1) p1 p2+{-# INLINE map #-}++-- | /O(n)/ 'reverse' @xs@ efficiently returns the elements of @xs@ in reverse order.+reverse :: (Storable a) => Vector a -> Vector a+reverse (SV x s l) = unsafeCreate l $ \p -> withForeignPtr x $ \f -> + sequence_ [peekElemOff (f `plusPtr` s) 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 (SV x s l) = inlinePerformIO $ withForeignPtr x $ \ptr ->+ lgo v (ptr `advancePtr` s) (ptr `advancePtr` (s+l))+ where+ STRICT3(lgo)+ lgo z p q | p == q = return z+ | otherwise = do c <- peek p+ lgo (f z c) (p `advancePtr` 1) q+{-# INLINE foldl #-}++-- | 'foldl\'' is like 'foldl', but strict in the accumulator.+-- Though actually foldl is also strict in the accumulator.+foldl' :: (Storable a) => (b -> a -> b) -> b -> Vector a -> b+foldl' = foldl+{-# 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.+foldr :: (Storable a) => (a -> b -> b) -> b -> Vector a -> b+foldr k z =+ let recurse = maybe z (\(h,t) -> k h (recurse t)) . viewL+ in recurse+{-# INLINE foldr #-}++-- | '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 ps =+ maybe+ (errorEmptyList "foldl1")+ (\(h,t) -> foldl f h t)+ (viewL ps)+{-# 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 ps =+ maybe+ (errorEmptyList "foldl1'")+ (\(h,t) -> foldl' f h t)+ (viewL ps)+{-# 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 ps =+ maybe+ (errorEmptyList "foldr1")+ (\(i,l) -> foldr f l i)+ (viewR ps)+{-# 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 xs ptr+ where len = P.sum . P.map length $ xs+ STRICT2(go)+ go [] _ = return ()+ go (SV p s l:ps) ptr = do+ withForeignPtr p $ \fp -> copyArray ptr (fp `advancePtr` s) l+ go ps (ptr `advancePtr` l)++-- | 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 . foldr ((:) . f) []+{-# INLINE concatMap #-}++-- | /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 _ (SV _ _ 0) = False+any f (SV x s l) = inlinePerformIO $ withForeignPtr x $ \ptr ->+ go (ptr `advancePtr` s) (ptr `advancePtr` (s+l))+ where+ STRICT2(go)+ go p q | p == q = return False+ | otherwise = do c <- peek p+ if f c then return True+ else go (p `advancePtr` 1) q++-- | /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 _ (SV _ _ 0) = True+all f (SV x s l) = inlinePerformIO $ withForeignPtr x $ \ptr ->+ go (ptr `advancePtr` s) (ptr `advancePtr` (s+l))+ where+ STRICT2(go)+ go p q | p == q = return True -- end of list+ | otherwise = do c <- peek p+ if f c+ then go (p `advancePtr` 1) q+ else return False++------------------------------------------------------------------------++-- | /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++------------------------------------------------------------------------++viewL :: Storable a => Vector a -> Maybe (a, Vector a)+viewL x =+ if null x+ then Nothing+ else Just (unsafeHead x, unsafeTail x)++viewR :: Storable a => Vector a -> Maybe (Vector a, a)+viewR x =+ if null x+ then Nothing+ else Just (unsafeInit x, unsafeLast x)++-- | 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 ps =+ maybe empty (uncurry (scanl f)) (viewL ps)+{-# 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 ps =+ maybe empty (uncurry (flip (scanl f))) (viewR ps)+{-# INLINE scanr1 #-}++-- ---------------------------------------------------------------------+-- Unfolds and replicates++-- | /O(n)/ 'replicate' @n x@ is a 'Vector' of length @n@ with @x@+-- the value of every element.+--+replicate :: (Storable a) => Int -> a -> Vector a+replicate w c+ | w <= 0 = empty+ | otherwise = fst $ unfoldrN w (const $ return (c, ())) ()++-- | /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, Nothing) -> s : []+ (s, Just x') -> s : unfoldChunk n' (n+n') x'++-- | /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 i f x0+ | i < 0 = (empty, Just x0)+ | otherwise = unsafePerformIO $ createAndTrim' i $ \p -> go p x0 0+ where STRICT3(go)+ go p x n =+ 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 (p `advancePtr` 1) x' (n+1)+{-# INLINE unfoldrN #-}++unfoldlN :: (Storable b) => Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a)+unfoldlN i f x0+ | i < 0 = (empty, Just x0)+ | otherwise = unsafePerformIO $ createAndTrim' i $ \p -> go (p `advancePtr` i) x0 i+ where STRICT3(go)+ go p x n =+ 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' x' (n-1)+{-# INLINE unfoldlN #-}++-- ---------------------------------------------------------------------+-- 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 @[]@ 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 p ps+ where+ STRICT2(loop)+ loop q qs =+ chunk :+ maybe []+ (\(_,t) -> loop q t)+ (viewL rest)+ where (chunk,rest) = break q qs+{-# 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 =+ maybe []+ (\(h,_) ->+ let (ys, zs) = span (== h) xs+ in ys : group zs)+ (viewL xs)++-- | The 'groupBy' function is the non-overloaded version of 'group'.+groupBy :: (Storable a) => (a -> a -> Bool) -> Vector a -> [Vector a]+groupBy k xs =+ maybe []+ (\(h,t) ->+ let n = 1 + findIndexOrEnd (not . k h) t+ in unsafeTake n xs : groupBy k (unsafeDrop n xs))+ (viewL xs)+++-- | /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. +-- This implementation uses memchr(3).+elemIndex :: (Storable a, Eq a) => a -> Vector a -> Maybe Int+elemIndex c (SV x s l) = inlinePerformIO $ withForeignPtr x $ \p -> go p (s + l) 0+ where+ STRICT3(go)+ go p end i | i == end = return Nothing+ | otherwise = do+ e <- peekElemOff p i+ if c == e+ then return $ Just (i - s)+ else go p end (i + 1)+{-# 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 ch (SV x s l) = inlinePerformIO $ withForeignPtr x $ \p ->+ go (p `advancePtr` s) (l-1)+ where+ STRICT2(go)+ go p i | i < 0 = return Nothing+ | otherwise = do ch' <- peekElemOff p i+ if ch == ch'+ then return $ Just i+ else go p (i-1)+{-# INLINE elemIndexEnd #-}++-- | /O(n)/ The 'elemIndices' function extends 'elemIndex', by returning+-- the indices of all elements equal to the query element, in ascending order.+-- This implementation uses memchr(3).+elemIndices :: (Storable a, Eq a) => a -> Vector a -> [Int]+elemIndices c ps = loop 0 ps+ where STRICT2(loop)+ loop n ps' =+ maybe []+ (\(h,t) ->+ if c == h+ then n : loop (n+1) t+ else loop (n+1) t) $+ viewL ps'+{-# 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 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 k (SV x s l) = inlinePerformIO $ withForeignPtr x $ \f -> go (f `advancePtr` s) 0+ where+ STRICT2(go)+ go ptr n | n >= l = return Nothing+ | otherwise = do w <- peek ptr+ if k w+ then return (Just n)+ else go (ptr `advancePtr` 1) (n+1)+{-# 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 ps = loop 0 ps+ where+ STRICT2(loop)+ loop n qs =+ maybe []+ (\(h,t) ->+ if p h+ then n : loop (n+1) t+ else loop (n+1) t) $+ viewL qs++-- | '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 k (SV x s l) = inlinePerformIO $ withForeignPtr x $ \f -> go (f `advancePtr` s) 0+ where+ STRICT2(go)+ go ptr n | n >= l = return l+ | otherwise = do w <- peek ptr+ if k w+ then return n+ else go (ptr `advancePtr` 1) (n+1)+{-# INLINE findIndexOrEnd #-}++-- ---------------------------------------------------------------------+-- Searching Vectors++-- | /O(n)/ 'elem' is the 'Vector' membership predicate.+elem :: (Storable a, Eq a) => a -> Vector a -> Bool+elem c ps = case elemIndex c ps of Nothing -> False ; _ -> True+{-# 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 k ps@(SV x s l)+ | null ps = ps+ | otherwise = unsafePerformIO $ createAndTrim l $ \p -> withForeignPtr x $ \f -> + let STRICT3(go)+ go end i j | i == end = return j+ | otherwise = do+ w <- peekElemOff f i+ if k w+ then do+ pokeElemOff p j w + go end (i+1) (j + 1)+ else+ go end (i+1) j+ in go (s + l) s 0+{-# INLINE filter #-}++-- | /O(n)/ The 'find' function takes a predicate and a 'Vector',+-- and returns the first element in matching the predicate, or 'Nothing'+-- if there is no such element.+--+-- > 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 `eq` 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 `eq` 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 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)++-- zipWith f ps qs = pack $ List.zipWith f (unpack ps) (unpack qs)+{-# INLINE zipWith #-}++-- | /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 #-}++-- ---------------------------------------------------------------------+-- 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) = [SV x s n | n <- [0..l]]++-- | /O(n)/ Return all final segments of the given 'Vector', longest first.+tails :: (Storable a) => Vector a -> [Vector a]+tails p =+ maybe [empty] (\(_,t) -> p : tails t) $+ viewL 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 (SV x s l) = unsafeCreate l $ \p -> withForeignPtr x $ \f ->+ copyArray p (f `advancePtr` s) (fromIntegral l)++-- ---------------------------------------------------------------------+-- Internal utilities++-- Common up near identical calls to `error' to reduce the number+-- constant strings created when compiled:+errorEmptyList :: String -> a+errorEmptyList fun = moduleError fun "empty Vector"+{-# NOINLINE errorEmptyList #-}++moduleError :: String -> String -> a+moduleError fun msg = error ("Data.Vector." ++ fun ++ ':':' ':msg)+{-# NOINLINE moduleError #-}++-- Find from the end of the string using predicate+findFromEndUntil :: (Storable a) => (a -> Bool) -> Vector a -> Int+STRICT2(findFromEndUntil)+findFromEndUntil 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))
+ Data/StorableVector/Base.hs view
@@ -0,0 +1,230 @@+{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+--+-- 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)++ inlinePerformIO++ ) where++import Foreign.Ptr (Ptr)+import Foreign.ForeignPtr+import Foreign.Marshal.Array (advancePtr, copyArray)+import Foreign.Storable (Storable(..))++import Control.Exception (assert)++#if defined(__GLASGOW_HASKELL__)+import qualified Foreign.Concurrent as FC (newForeignPtr)++import Data.Generics (Data(..), Typeable(..))+import GHC.Ptr (Ptr(..))+import GHC.Base (realWorld#)+import GHC.IOBase++#if defined(__GLASGOW_HASKELL__) && !defined(SLOW_FOREIGN_PTR)+import GHC.ForeignPtr (mallocPlainForeignPtrBytes)+#endif++#else+import Data.Char (chr)+import System.IO.Unsafe (unsafePerformIO)+#endif++-- CFILES stuff is Hugs only+{-# CFILES cbits/fpstring.c #-}++-- -----------------------------------------------------------------------------+--+-- Useful macros, until we have bang patterns+--++#define STRICT1(f) f a | a `seq` False = undefined+#define STRICT2(f) f a b | a `seq` b `seq` False = undefined+#define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined+#define STRICT4(f) f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined+#define STRICT5(f) f a b c d e | a `seq` b `seq` c `seq` d `seq` e `seq` False = undefined++-- -----------------------------------------------------------------------------++-- | 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 (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 #-}++-- ---------------------------------------------------------------------+-- 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 (SV ps s l) = (ps, s, l)++-- | 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 = unsafePerformIO (create l f)+{-# INLINE unsafeCreate #-}++-- | Wrapper of mallocForeignPtrArray.+create :: (Storable a) => Int -> (Ptr a -> IO ()) -> IO (Vector a)+create l f = do+#if defined(SLOW_FOREIGN_PTR) || !defined(__GLASGOW_HASKELL__)+ fp <- mallocForeignPtrArray l+#else+ fp <- mallocPlainForeignPtrArray l+#endif+ 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+#if defined(SLOW_FOREIGN_PTR) || !defined(__GLASGOW_HASKELL__)+ fp <- mallocForeignPtrArray l+#else+ fp <- mallocPlainForeignPtrArray l+#endif+ 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+#if defined(SLOW_FOREIGN_PTR) || !defined(__GLASGOW_HASKELL__)+ fp <- mallocForeignPtrArray l+#else+ fp <- mallocPlainForeignPtrArray l+#endif+ 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 unsafePerformIO, 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 @unsafePerformIO@.+--+{-# INLINE inlinePerformIO #-}+inlinePerformIO :: IO a -> a+#if defined(__GLASGOW_HASKELL__)+inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r+#else+inlinePerformIO = unsafePerformIO+#endif
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) Henning Thielemann 2008+ (c) Spencer Janssen 2007+ (c) Don Stewart 2005-2006+ (c) David Roundy 2003-2005.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ storablevector.cabal view
@@ -0,0 +1,31 @@+Name: storablevector+Version: 0.1+Category: Data+Synopsis: Fast, packed, strict storable arrays with a list interface like ByteString+Description:+ Fast, packed, strict storable arrays with a list interface.+ This is much like bytestring but can be used for every Storable type.+License: BSD3+License-file: LICENSE+Author: Spencer Janssen <sjanssen@cse.unl.edu>+Maintainer: Henning Thielemann <storablevector@henning-thielemann.de>+Homepage: http://darcs.haskell.org/storablevector+Package-URL: http://code.haskell.org/~sjanssen/storablevector+Build-Depends: base+Build-Type: Simple+Tested-With: GHC==6.4.1+Extensions: CPP, ForeignFunctionInterface+Exposed-modules: Data.StorableVector+ Data.StorableVector.Base+GHC-Options: -Wall -fglasgow-exts -funbox-strict-fields+CPP-Options: -DSLOW_FOREIGN_PTR++-- -DSLOW_FOREIGN_PTR++Executable: test+GHC-Options: -Wall -fglasgow-exts -funbox-strict-fields+CPP-Options: -DSLOW_FOREIGN_PTR+Hs-Source-Dirs: ., tests+Main-Is: tests.hs+Extensions: CPP, ForeignFunctionInterface+Build-Depends: base, haskell98, bytestring, QuickCheck
+ tests/tests.hs view
@@ -0,0 +1,156 @@+{-# OPTIONS_GHC -O #-}+import qualified Data.StorableVector as V+import qualified Data.ByteString as P+import QuickCheckUtils+import Text.Printf+import System (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_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)+ ,("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