diff --git a/Data/StorableVector.hs b/Data/StorableVector.hs new file mode 100644 --- /dev/null +++ b/Data/StorableVector.hs @@ -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)) diff --git a/Data/StorableVector/Base.hs b/Data/StorableVector/Base.hs new file mode 100644 --- /dev/null +++ b/Data/StorableVector/Base.hs @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/storablevector.cabal b/storablevector.cabal new file mode 100644 --- /dev/null +++ b/storablevector.cabal @@ -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 +Maintainer: Henning Thielemann +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 diff --git a/tests/tests.hs b/tests/tests.hs new file mode 100644 --- /dev/null +++ b/tests/tests.hs @@ -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