packages feed

storablevector 0.2.8.3 → 0.2.9

raw patch · 34 files changed

+5243/−5269 lines, 34 filesdep +storablevectordep ~basedep ~transformersdep ~utility-ht

Dependencies added: storablevector

Dependency ranges changed: base, transformers, utility-ht

Files

− Data/StorableVector.hs 
@@ -1,1565 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}------ Module      : StorableVector--- Copyright   : (c) The University of Glasgow 2001,---               (c) David Roundy 2003-2005,---               (c) Simon Marlow 2005---               (c) Don Stewart 2005-2006---               (c) Bjorn Bringert 2006---               (c) Spencer Janssen 2006---               (c) Henning Thielemann 2008-2013--------- License     : BSD-style------ Maintainer  : Henning Thielemann--- Stability   : experimental--- Portability : portable, requires ffi and cpp--- Tested with : GHC 6.4.1 and Hugs March 2005---------- | A time and space-efficient implementation of vectors using--- packed arrays, suitable for high performance use, both in terms--- of large data quantities, or high speed requirements. Vectors--- are encoded as strict arrays, held in a 'ForeignPtr',--- and can be passed between C and Haskell with little effort.------ This module is intended to be imported @qualified@, to avoid name--- clashes with "Prelude" functions.  eg.------ > import qualified Data.StorableVector as V------ Original GHC implementation by Bryan O\'Sullivan. Rewritten to use--- UArray by Simon Marlow. Rewritten to support slices and use--- ForeignPtr by David Roundy. Polished and extended by Don Stewart.--- Generalized to any Storable value by Spencer Janssen.--- Chunky lazy stream, also with chunk pattern control,--- mutable access in ST monad, Builder monoid by Henning Thieleman.--module Data.StorableVector (--        -- * The @Vector@ type-        Vector,--        -- * Introducing and eliminating 'Vector's-        empty,-        singleton,-        pack,-        unpack,-        packN,-        packWith,-        unpackWith,--        -- * Basic interface-        cons,-        snoc,-        append,-        head,-        last,-        tail,-        init,-        null,-        length,-        viewL,-        viewR,-        switchL,-        switchR,--        -- * Transforming 'Vector's-        map,-        reverse,-        intersperse,-        transpose,--        -- * Reducing 'Vector's (folds)-        foldl,-        foldl',-        foldl1,-        foldl1',-        foldr,-        foldr1,--        -- ** Special folds-        concat,-        concatMap,-        monoidConcatMap,-        any,-        all,-        maximum,-        minimum,--        -- * Building 'Vector's-        -- ** Scans-        scanl,-        scanl1,-        scanr,-        scanr1,--        -- ** Accumulating maps-        mapAccumL,-        mapAccumR,-        mapIndexed,--        -- ** Unfolding 'Vector's-        replicate,-        iterateN,-        unfoldr,-        unfoldrN,-        unfoldrResultN,-        sample,--        -- * Substrings--        -- ** Breaking strings-        take,-        drop,-        splitAt,-        takeWhile,-        dropWhile,-        span,-        spanEnd,-        break,-        breakEnd,-        group,-        groupBy,-        inits,-        tails,--        -- ** Breaking into many substrings-        split,-        splitWith,-        tokens,--        -- ** Joining strings-        join,--        -- * Predicates-        isPrefixOf,-        isSuffixOf,--        -- * Searching 'Vector's--        -- ** Searching by equality-        elem,-        notElem,--        -- ** Searching with a predicate-        find,-        filter,--        -- * Indexing 'Vector's-        index,-        elemIndex,-        elemIndices,-        elemIndexEnd,-        findIndex,-        findIndices,-        count,-        findIndexOrEnd,--        -- * Zipping and unzipping 'Vector's-        zip,-        zipWith,-        zipWith3,-        zipWith4,-        unzip,-        copy,--        -- * Interleaved 'Vector's-        sieve,-        deinterleave,-        interleave,--        -- * IO-        hGet,-        hPut,-        readFile,-        writeFile,-        appendFile,--  ) where--import qualified Prelude as P-import Prelude hiding           (reverse,head,tail,last,init,null-                                ,length,map,lines,foldl,foldr,unlines-                                ,concat,any,take,drop,splitAt,takeWhile-                                ,dropWhile,span,break,elem,filter,maximum-                                ,minimum,all,concatMap,foldl1,foldr1-                                ,scanl,scanl1,scanr,scanr1-                                ,readFile,writeFile,appendFile,replicate-                                ,getContents,getLine,putStr,putStrLn-                                ,zip,zipWith,zipWith3,unzip,notElem-                                ,pred,succ)--import Data.StorableVector.Base--import qualified Control.Monad.Trans.Cont as MC--import qualified Data.List as List-import qualified Data.List.HT as ListHT-import qualified Data.Strictness.HT as Strict-import Data.Tuple.HT (mapSnd, )-import Data.Maybe.HT (toMaybe, )-import Data.Maybe (fromMaybe, isJust, )-import Data.Bool.HT (if', )--import Control.Exception        (assert, bracket, )--import Foreign.ForeignPtr       (ForeignPtr, withForeignPtr, )-import Foreign.Marshal.Array    (advancePtr, copyArray, withArray, )-import Foreign.Ptr              (Ptr, minusPtr, )-import Foreign.Storable         (Storable(..))--import Data.Monoid              (Monoid, mempty, mappend, mconcat, )-import Control.Monad            (mplus, guard, when, liftM2, liftM3, liftM4, )--import System.IO                (openBinaryFile, hClose, hFileSize,-                                 hGetBuf, hPutBuf,-                                 Handle, IOMode(..), )--import qualified System.Unsafe as Unsafe--- import GHC.IOBase---- -------------------------------------------------------------------------------instance (Storable a, Eq a) => Eq (Vector a) where-    (==) = equal--instance (Storable a) => Monoid (Vector a) where-    mempty  = empty-    mappend = append-    mconcat = concat---- | /O(n)/ Equality on the 'Vector' type.-equal :: (Storable a, Eq a) => Vector a -> Vector a -> Bool-equal a b =-   Unsafe.performIO $-   withStartPtr a $ \paf la ->-   withStartPtr b $ \pbf lb ->-    if la /= lb-      then-        return False-      else-        if paf == pbf-          then return True-          else-            let go = Strict.arguments3 $ \p q l ->-                   if l==0-                     then return True-                     else-                       do x <- peek p-                          y <- peek q-                          if x==y-                            then go (incPtr p) (incPtr q) (l-1)-                            else return False-            in  go paf pbf la-{-# INLINE equal #-}---- -------------------------------------------------------------------------------- Introducing and eliminating 'Vector's---- | /O(1)/ The empty 'Vector'-empty :: (Storable a) => Vector a-empty = unsafeCreate 0 $ const $ return ()-{-# NOINLINE empty #-}---- | /O(1)/ Construct a 'Vector' containing a single element-singleton :: (Storable a) => a -> Vector a-singleton c = unsafeCreate 1 $ \p -> poke p c-{-# INLINE singleton #-}---- | /O(n)/ Convert a '[a]' into a 'Vector a'.----pack :: (Storable a) => [a] -> Vector a-pack str = unsafeCreate (P.length str) $ \p -> go p str-    where-      go = Strict.arguments2 $ \p ->-        ListHT.switchL-           (return ())-           (\x xs -> poke p x >> go (incPtr p) xs)---- | /O(n)/ Convert first @n@ elements of a '[a]' into a 'Vector a'.----packN :: (Storable a) => Int -> [a] -> (Vector a, [a])-packN n =-   mapSnd (fromMaybe []) . unfoldrN n ListHT.viewL---- | /O(n)/ Converts a 'Vector a' to a '[a]'.-unpack :: (Storable a) => Vector a -> [a]-unpack = foldr (:) []-{-# INLINE unpack #-}------------------------------------------------------------------------------ | /O(n)/ Convert a list into a 'Vector' using a conversion function-packWith :: (Storable b) => (a -> b) -> [a] -> Vector b-packWith k str = unsafeCreate (P.length str) $ \p -> go p str-    where-      go = Strict.arguments2 $ \p ->-        ListHT.switchL-           (return ())-           (\x xs -> poke p (k x) >> go (incPtr p) xs)-                          -- less space than pokeElemOff-{-# INLINE packWith #-}--{--*Data.StorableVector> List.take 10 $ unpackWith id $ pack [0..10000000::Int]-[0,1,2,3,4,5,6,7,8,9]-(19.18 secs, 2327851592 bytes)--}--- | /O(n)/ Convert a 'Vector' into a list using a conversion function-unpackWith :: (Storable a) => (a -> b) -> Vector a -> [b]-unpackWith f = foldr ((:) . f) []-{-# INLINE unpackWith #-}--{--That's too inefficient, since it builds the list from back to front,-that is, in a too strict manner.---- | /O(n)/ Convert a 'Vector' into a list using a conversion function-unpackWith :: (Storable a) => (a -> b) -> Vector a -> [b]-unpackWith _ (SV _  _ 0) = []-unpackWith k v@(SV ps s l) = inlinePerformIO $ withStartPtr v $ \p ->-        go p (l - 1) []-    where-        STRICT3(go)-        go p 0 acc = peek p          >>= \e -> return (k e : acc)-        go p n acc = peekElemOff p n >>= \e -> go p (n-1) (k e : acc)-{-# INLINE unpackWith #-}---*Data.StorableVector> List.take 10 $ unpack $ pack [0..10000000::Int]-[0,1,2,3,4,5,6,7,8,9]-(18.57 secs, 2323959948 bytes)-*Data.StorableVector> unpack $ take 10 $ pack [0..10000000::Int]-[0,1,2,3,4,5,6,7,8,9]-(18.40 secs, 2324002120 bytes)-*Data.StorableVector> List.take 10 $ unpackWith id $ pack [0..10000000::Int]-Interrupted.--}---- ------------------------------------------------------------------------ Basic interface---- | /O(1)/ Test whether a 'Vector' is empty.-null :: Vector a -> Bool-null (SV _ _ l) = assert (l >= 0) $ l <= 0-{-# INLINE null #-}---- ------------------------------------------------------------------------ | /O(1)/ 'length' returns the length of a 'Vector' as an 'Int'.-length :: Vector a -> Int-length (SV _ _ l) = assert (l >= 0) $ l------- length/loop fusion. When taking the length of any fuseable loop,--- rewrite it as a foldl', and thus avoid allocating the result buffer--- worth around 10% in speed testing.-----{-# INLINE [1] length #-}------------------------------------------------------------------------------ | /O(n)/ 'cons' is analogous to (:) for lists, but of different--- complexity, as it requires a memcpy.-cons :: (Storable a) => a -> Vector a -> Vector a-cons c v =-   unsafeWithStartPtr v $ \f l ->-   create (l + 1) $ \p -> do-      poke p c-      copyArray (incPtr p) f (fromIntegral l)-{-# INLINE cons #-}---- | /O(n)/ Append an element to the end of a 'Vector'-snoc :: (Storable a) => Vector a -> a -> Vector a-snoc v c =-   unsafeWithStartPtr v $ \f l ->-   create (l + 1) $ \p -> do-      copyArray p f l-      pokeElemOff p l c-{-# INLINE snoc #-}---- | /O(1)/ Extract the first element of a 'Vector', which must be non-empty.--- An exception will be thrown in the case of an empty 'Vector'.-head :: (Storable a) => Vector a -> a-head =-   withNonEmptyVector "head" $ \ p s _l -> foreignPeek p s-{-# INLINE head #-}---- | /O(1)/ Extract the elements after the head of a 'Vector', which must be non-empty.--- An exception will be thrown in the case of an empty 'Vector'.-tail :: (Storable a) => Vector a -> Vector a-tail =-   withNonEmptyVector "tail" $ \ p s l -> SV p (s+1) (l-1)-{-# INLINE tail #-}--laxTail :: (Storable a) => Vector a -> Vector a-laxTail v@(SV fp s l) =-   if l<=0-     then v-     else SV fp (s+1) (l-1)-{-# INLINE laxTail #-}---- | /O(1)/ Extract the last element of a 'Vector', which must be finite and non-empty.--- An exception will be thrown in the case of an empty 'Vector'.-last :: (Storable a) => Vector a -> a-last =-   withNonEmptyVector "last" $ \ p s l -> foreignPeek p (s+l-1)-{-# INLINE last #-}---- | /O(1)/ Return all the elements of a 'Vector' except the last one.--- An exception will be thrown in the case of an empty 'Vector'.-init :: Vector a -> Vector a-init =-   withNonEmptyVector "init" $ \ p s l -> SV p s (l-1)-{-# INLINE init #-}---- | /O(n)/ Append two Vectors-append :: (Storable a) => Vector a -> Vector a -> Vector a-append xs ys =-   if' (null xs) ys $-   if' (null ys) xs $-   concat [xs,ys]-{-# INLINE append #-}---- ------------------------------------------------------------------------ Transformations---- | /O(n)/ 'map' @f xs@ is the 'Vector' obtained by applying @f@ to each--- element of @xs@.-map :: (Storable a, Storable b) => (a -> b) -> Vector a -> Vector b-map f v =-   unsafeWithStartPtr v $ \a len ->-   create len $ \p ->-      let go = Strict.arguments3 $-             \ n p1 p2 ->-               when (n>0) $-                 do poke p2 . f =<< peek p1-                    go (n-1) (incPtr p1) (incPtr p2)-      in  go len a p-{-# INLINE map #-}--{--mapByIndex :: (Storable a, Storable b) => (a -> b) -> Vector a -> Vector b-mapByIndex f v = inlinePerformIO $ withStartPtr v $ \a len ->-    create len $ \p2 ->-       let go = Strict.arguments1 $ \ n ->-              when (n<len) $-                do pokeElemOff p2 n . f =<< peekElemOff a n-                   go (n+1)-       in  go 0--}---- | /O(n)/ 'reverse' @xs@ efficiently returns the elements of @xs@ in reverse order.-reverse :: (Storable a) => Vector a -> Vector a-reverse v =-   unsafeWithStartPtr v $ \f l ->-   create l $ \p ->-   sequence_ [peekElemOff f i >>= pokeElemOff p (l - i - 1)-                 | i <- [0 .. l - 1]]---- | /O(n)/ The 'intersperse' function takes a element and a--- 'Vector' and \`intersperses\' that element between the elements of--- the 'Vector'.  It is analogous to the intersperse function on--- Lists.-intersperse :: (Storable a) => a -> Vector a -> Vector a-intersperse c = pack . List.intersperse c . unpack---- | The 'transpose' function transposes the rows and columns of its--- 'Vector' argument.-transpose :: (Storable a) => [Vector a] -> [Vector a]-transpose ps = P.map pack (List.transpose (P.map unpack ps))---- ------------------------------------------------------------------------ Reducing 'Vector's---- | 'foldl', applied to a binary operator, a starting value (typically--- the left-identity of the operator), and a Vector, reduces the--- 'Vector' using the binary operator, from left to right.--- This function is subject to array fusion.-foldl :: (Storable a) => (b -> a -> b) -> b -> Vector a -> b-foldl f v xs =-   foldr (\x k acc -> k (f acc x)) id xs v-{-# INLINE foldl #-}---- | 'foldl\'' is like 'foldl', but strict in the accumulator.-foldl' :: (Storable a) => (b -> a -> b) -> b -> Vector a -> b-foldl' f b v =-   Unsafe.performIO $ withStartPtr v $ \ptr l ->-      let q  = ptr `advancePtr` l-          go = Strict.arguments2 $ \p z ->-             if p == q-               then return z-               else go (incPtr p) . f z =<< peek p-      in  go ptr b-{-# INLINE foldl' #-}---- | 'foldr', applied to a binary operator, a starting value--- (typically the right-identity of the operator), and a 'Vector',--- reduces the 'Vector' using the binary operator, from right to left.--- However, it is not the same as 'foldl' applied to the reversed vector.--- Actually 'foldr' starts processing with the first element,--- and thus can be used for efficiently building a singly linked list--- by @foldr (:) [] vec@.--- Unfortunately 'foldr' is quite slow for low-level loops,--- since GHC (up to 6.12.1) cannot detect the loop.-foldr :: (Storable a) => (a -> b -> b) -> b -> Vector a -> b-foldr = foldrByLoop-{-# INLINE foldr #-}--{--*Data.StorableVector> List.length $ foldrBySwitch (:) [] $ replicate 1000000 'a'-1000000-(11.29 secs, 1183476300 bytes)-*Data.StorableVector> List.length $ foldrByIO (:) [] $ replicate 1000000 'a'-1000000-(7.86 secs, 1033901140 bytes)-*Data.StorableVector> List.length $ foldrByIndex (:) [] $ replicate 1000000 'a'-1000000-(7.86 secs, 914340420 bytes)-*Data.StorableVector> List.length $ foldrByLoop (:) [] $ replicate 1000000 'a'-1000000-(6.38 secs, 815355460 bytes)--}-{--We cannot simply increment the pointer,-since ForeignPtr cannot be incremented.-We also cannot convert from ForeignPtr to Ptr-and increment that instead,-because we need to keep the reference to ForeignPtr,-otherwise memory might be freed.-We can also not perform loop entirely in strict IO,-since this eat up the stack quickly-and 'foldr' might be used to build a list lazily.--}-foldrByLoop :: (Storable a) => (a -> b -> b) -> b -> Vector a -> b-foldrByLoop f z (SV fp s l) =-   let end = s+l-       go = Strict.arguments1 $ \k ->-          if k<end-            then f (foreignPeek fp k) (go (succ k))-            else z-   in  go s-{-# INLINE foldrByLoop #-}--{--foldrByIO :: (Storable a) => (a -> b -> b) -> b -> Vector a -> b-foldrByIO f z v@(SV fp _ _) =-   unsafeWithStartPtr v $-   let go = Strict.arguments2 $ \p l ->-          Unsafe.interleaveIO $-          if l>0-            then liftM2 f (peek p) (go (incPtr p) (pred l))-            else touchForeignPtr fp >> return z-   in  go-{-# INLINE foldrByIO #-}--foldrByIndex :: (Storable a) => (a -> b -> b) -> b -> Vector a -> b-foldrByIndex k z xs =-   let recourse n =-          if n < length xs-            then k (unsafeIndex xs n) (recourse (succ n))-            else z-   in  recourse 0-{-# INLINE foldrByIndex #-}--{--This implementation is a bit inefficient,-since switchL creates a new Vector structure-instead of just incrementing an index.--}-foldrBySwitch :: (Storable a) => (a -> b -> b) -> b -> Vector a -> b-foldrBySwitch k z =-   let recourse = switchL z (\h t -> k h (recourse t))-   in  recourse-{-# INLINE foldrBySwitch #-}--}----- | 'foldl1' is a variant of 'foldl' that has no starting value--- argument, and thus must be applied to non-empty 'Vector's.--- This function is subject to array fusion.--- An exception will be thrown in the case of an empty 'Vector'.-foldl1 :: (Storable a) => (a -> a -> a) -> Vector a -> a-foldl1 f =-   switchL-      (errorEmpty "foldl1")-      (foldl f)-{-# INLINE foldl1 #-}---- | 'foldl1\'' is like 'foldl1', but strict in the accumulator.--- An exception will be thrown in the case of an empty 'Vector'.-foldl1' :: (Storable a) => (a -> a -> a) -> Vector a -> a-foldl1' f =-   switchL-      (errorEmpty "foldl1'")-      (foldl' f)-{-# INLINE foldl1' #-}---- | 'foldr1' is a variant of 'foldr' that has no starting value argument,--- and thus must be applied to non-empty 'Vector's--- An exception will be thrown in the case of an empty 'Vector'.-foldr1 :: (Storable a) => (a -> a -> a) -> Vector a -> a-foldr1 f =-   switchR-      (errorEmpty "foldr1")-      (flip (foldr f))-{-# INLINE foldr1 #-}---- ------------------------------------------------------------------------ Special folds---- | /O(n)/ Concatenate a list of 'Vector's.-concat :: (Storable a) => [Vector a] -> Vector a-concat []     = empty-concat [ps]   = ps-concat xs     = unsafeCreate len $ \ptr -> go ptr xs-  where len = P.sum . P.map length $ xs-        go =-          Strict.arguments2 $ \ptr ->-             ListHT.switchL-                (return ())-                (\v ps -> do-                   withStartPtr v $ copyArray ptr-                   go (ptr `advancePtr` length v) ps)---- | Map a function over a 'Vector' and concatenate the results-concatMap :: (Storable a, Storable b) => (a -> Vector b) -> Vector a -> Vector b-concatMap f = concat . unpackWith f-{-# INLINE concatMap #-}---- | This is like @mconcat . map f@,--- but in many cases the result of @f@ will not be storable.-monoidConcatMap :: (Storable a, Monoid m) => (a -> m) -> Vector a -> m-monoidConcatMap f =-   foldr (mappend . f) mempty-{-# INLINE monoidConcatMap #-}---- | /O(n)/ Applied to a predicate and a 'Vector', 'any' determines if--- any element of the 'Vector' satisfies the predicate.-any :: (Storable a) => (a -> Bool) -> Vector a -> Bool-any f = foldr ((||) . f) False-{-# INLINE any #-}---- | /O(n)/ Applied to a predicate and a 'Vector', 'all' determines--- if all elements of the 'Vector' satisfy the predicate.-all :: (Storable a) => (a -> Bool) -> Vector a -> Bool-all f = foldr ((&&) . f) True-{-# INLINE all #-}------------------------------------------------------------------------------ | /O(n)/ 'maximum' returns the maximum value from a 'Vector'--- This function will fuse.--- An exception will be thrown in the case of an empty 'Vector'.-maximum :: (Storable a, Ord a) => Vector a -> a-maximum = foldl1' max---- | /O(n)/ 'minimum' returns the minimum value from a 'Vector'--- This function will fuse.--- An exception will be thrown in the case of an empty 'Vector'.-minimum :: (Storable a, Ord a) => Vector a -> a-minimum = foldl1' min----------------------------------------------------------------------------switchL :: Storable a => b -> (a -> Vector a -> b) -> Vector a -> b-switchL n j x =-   if null x-     then n-     else j (unsafeHead x) (unsafeTail x)-{-# INLINE switchL #-}--switchR :: Storable a => b -> (Vector a -> a -> b) -> Vector a -> b-switchR n j x =-   if null x-     then n-     else j (unsafeInit x) (unsafeLast x)-{-# INLINE switchR #-}--viewL :: Storable a => Vector a -> Maybe (a, Vector a)-viewL = switchL Nothing (curry Just)-{-# INLINE viewL #-}--viewR :: Storable a => Vector a -> Maybe (Vector a, a)-viewR = switchR Nothing (curry Just)-{-# INLINE viewR #-}---- | The 'mapAccumL' function behaves like a combination of 'map' and--- 'foldl'; it applies a function to each element of a 'Vector',--- passing an accumulating parameter from left to right, and returning a--- final value of this accumulator together with the new list.-mapAccumL :: (Storable a, Storable b) => (acc -> a -> (acc, b)) -> acc -> Vector a -> (acc, Vector b)-mapAccumL f acc0 as0 =-   let (bs, Just (acc2, _)) =-          unfoldrN (length as0)-             (\(acc,as) ->-                 fmap-                    (\(asHead,asTail) ->-                        let (acc1,b) = f acc asHead-                        in  (b, (acc1, asTail)))-                    (viewL as))-             (acc0,as0)-   in  (acc2, bs)-{-# INLINE mapAccumL #-}---- | The 'mapAccumR' function behaves like a combination of 'map' and--- 'foldr'; it applies a function to each element of a 'Vector',--- passing an accumulating parameter from right to left, and returning a--- final value of this accumulator together with the new 'Vector'.-mapAccumR :: (Storable a, Storable b) => (acc -> a -> (acc, b)) -> acc -> Vector a -> (acc, Vector b)-mapAccumR f acc0 as0 =-   let (bs, Just (acc2, _)) =-          unfoldlN (length as0)-             (\(acc,as) ->-                 fmap-                    (\(asInit,asLast) ->-                        let (acc1,b) = f acc asLast-                        in  (b, (acc1, asInit)))-                    (viewR as))-             (acc0,as0)-   in  (acc2, bs)-{-# INLINE mapAccumR #-}---- | /O(n)/ map functions, provided with the index at each position-mapIndexed :: (Storable a, Storable b) => (Int -> a -> b) -> Vector a -> Vector b-mapIndexed f = snd . mapAccumL (\i e -> (i + 1, f i e)) 0-{-# INLINE mapIndexed #-}---- ------------------------------------------------------------------------ Building 'Vector's---- | 'scanl' is similar to 'foldl', but returns a list of successive--- reduced values from the left. This function will fuse.------ > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]------ Note that------ > last (scanl f z xs) == foldl f z xs.-scanl :: (Storable a, Storable b) => (a -> b -> a) -> a -> Vector b -> Vector a-scanl f acc0 as0 =-   fst $-      unfoldrN (succ (length as0))-         (fmap $ \(acc,as) ->-             (acc,-              fmap-                 (\(asHead,asTail) ->-                     (f acc asHead, asTail))-                 (viewL as)))-         (Just (acc0, as0))---- less efficient but much more comprehensible--- scanl f z ps =---   cons z (snd (mapAccumL (\acc a -> let b = f acc a in (b,b)) z ps))--    -- n.b. haskell's List scan returns a list one bigger than the-    -- input, so we need to snoc here to get some extra space, however,-    -- it breaks map/up fusion (i.e. scanl . map no longer fuses)-{-# INLINE scanl #-}---- | 'scanl1' is a variant of 'scanl' that has no starting value argument.--- This function will fuse.------ > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]-scanl1 :: (Storable a) => (a -> a -> a) -> Vector a -> Vector a-scanl1 f = switchL empty (scanl f)-{-# INLINE scanl1 #-}---- | scanr is the right-to-left dual of scanl.-scanr :: (Storable a, Storable b) => (a -> b -> b) -> b -> Vector a -> Vector b-scanr f acc0 as0 =-   fst $-      unfoldlN (succ (length as0))-         (fmap $ \(acc,as) ->-             (acc,-              fmap-                 (\(asInit,asLast) ->-                     (f asLast acc, asInit))-                 (viewR as)))-         (Just (acc0, as0))-{-# INLINE scanr #-}---- | 'scanr1' is a variant of 'scanr' that has no starting value argument.-scanr1 :: (Storable a) => (a -> a -> a) -> Vector a -> Vector a-scanr1 f = switchR empty (flip (scanl f))-{-# INLINE scanr1 #-}---- ------------------------------------------------------------------------ Unfolds and replicates---- | /O(n)/ 'replicate' @n x@ is a 'Vector' of length @n@ with @x@--- the value of every element.----{- nice implementation-replicate :: (Storable a) => Int -> a -> Vector a-replicate n c =-   fst $ unfoldrN n (const $ Just (c, ())) ()--}--{--fast implementation--Maybe it could be made even faster by plainly copying the bit pattern of the first element.-Since there is no function like 'memset',-we could not warrant that the implementation is really efficient-for the actual machine we run on.--}-replicate :: (Storable a) => Int -> a -> Vector a-replicate n c =-   if n <= 0-     then empty-     else unsafeCreate n $-       let go = Strict.arguments2 $ \i p ->-              if i == 0-                then return ()-                else poke p c >> go (pred i) (incPtr p)-       in  go n-{-# INLINE replicate #-}-{--For 'replicate 10000000 (42::Int)' generates:--Main_zdwa_info:-	movl (%ebp),%eax-	testl %eax,%eax-	jne .LcfIQ-	movl $ghczmprim_GHCziUnit_Z0T_closure+1,%esi-	addl $8,%ebp-	jmp *(%ebp)-.LcfIQ:-	movl 4(%ebp),%ecx-	movl $42,(%ecx)-	decl %eax-	addl $4,4(%ebp)-	movl %eax,(%ebp)-	jmp Main_zdwa_info--that is, the inner loop consists of 9 instructions,-where I would write something like:-	# counter in %ecx-	testl %ecx-	jz skip_loop-	movl $42,%ebx-start_loop:-	movl %ebx,(%edx)-	addl $4,%edx-	loop start_loop-skip_loop:--and need only 3 instructions in the loop.--}----- | /O(n)/ 'iterateN' @n f x@ is a 'Vector' of length @n@--- where the elements of @x@ are generated by repeated application of @f@.----iterateN :: (Storable a) => Int -> (a -> a) -> a -> Vector a-iterateN n f =-   fst . unfoldrN n (\a -> Just (a, f a))-{-# INLINE iterateN #-}---- | /O(n)/, where /n/ is the length of the result.  The 'unfoldr'--- function is analogous to the List \'unfoldr\'.  'unfoldr' builds a--- 'Vector' from a seed value.  The function takes the element and--- returns 'Nothing' if it is done producing the 'Vector or returns--- 'Just' @(a,b)@, in which case, @a@ is the next element in the 'Vector',--- and @b@ is the seed value for further production.------ Examples:------ >    unfoldr (\x -> if x <= 5 then Just (x, x + 1) else Nothing) 0--- > == pack [0, 1, 2, 3, 4, 5]----unfoldr :: (Storable b) => (a -> Maybe (b, a)) -> a -> Vector b-unfoldr f = concat . unfoldChunk 32 64-  where unfoldChunk n n' x =-          case unfoldrN n f x of-            (s, mx) -> s : maybe [] (unfoldChunk n' (n+n')) mx-{-# INLINE unfoldr #-}---- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a 'Vector' from a seed--- value.  However, the length of the result is limited by the first--- argument to 'unfoldrN'.  This function is more efficient than 'unfoldr'--- when the maximum length of the result is known.------ The following equation relates 'unfoldrN' and 'unfoldr':------ > fst (unfoldrN n f s) == take n (unfoldr f s)----unfoldrN :: (Storable b) => Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a)-unfoldrN n f x0 =-   if n <= 0-     then (empty, Just x0)-     else Unsafe.performIO $ createAndTrim' n $ \p -> go p n x0-       {--       go must not be strict in the accumulator-       since otherwise packN would be too strict.-       -}-       where-          go = Strict.arguments2 $ \p i -> \x ->-             if i == 0-               then return (0, n-i, Just x)-               else-                 case f x of-                   Nothing     -> return (0, n-i, Nothing)-                   Just (w,x') -> do poke p w-                                     go (incPtr p) (i-1) x'-{-# INLINE unfoldrN #-}--{--Examples:--f i = Just (i::Char, succ i)--f i = toMaybe (i<='p') (i::Char, succ i)---}--- | /O(n)/ Like 'unfoldrN' this function builds a 'Vector'--- from a seed value with limited size.--- Additionally it returns a value, that depends on the state,--- but is not necessarily the state itself.--- If end of vector and end of the generator coincide,--- then the result is as if only the end of vector is reached.------ Example:------ > unfoldrResultN 30 Char.ord (\c -> if c>'z' then Left 1000 else Right (c, succ c)) 'a'------ The following equation relates 'unfoldrN' and 'unfoldrResultN':------ > unfoldrN n f s ==--- >    unfoldrResultN n Just--- >       (maybe (Left Nothing) Right . f) s------ It is not possible to express 'unfoldrResultN' in terms of 'unfoldrN'.----unfoldrResultN :: (Storable b) => Int -> (a -> c) -> (a -> Either c (b, a)) -> a -> (Vector b, c)-unfoldrResultN i g f x0 =-   if i <= 0-     then (empty, g x0)-     else Unsafe.performIO $ createAndTrim' i $ \p -> go p 0 x0-       {--       go must not be strict in the accumulator-       since otherwise packN would be too strict.-       -}-       where-          go = Strict.arguments2 $ \p n -> \a0 ->-             if n == i-               then return (0, n, g a0)-               else-                 case f a0 of-                   Left c -> return (0, n, c)-                   Right (b,a1) -> do poke p b-                                      go (incPtr p) (n+1) a1-{-# INLINE unfoldrResultN #-}--unfoldlN :: (Storable b) => Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a)-unfoldlN i f x0-    | i < 0     = (empty, Just x0)-    | otherwise = Unsafe.performIO $ createAndTrim' i $ \p -> go (p `advancePtr` i) i x0-  where go = Strict.arguments2 $ \p n -> \x ->-           if n == 0-             then return (n, i, Just x)-             else-               case f x of-                 Nothing     -> return (n, i, Nothing)-                 Just (w,x') ->-                    let p' = p `advancePtr` (-1)-                    in  do poke p' w-                           go p' (n-1) x'-{-# INLINE unfoldlN #-}----- | /O(n)/, where /n/ is the length of the result.--- This function constructs a vector by evaluating a function--- that depends on the element index.--- It is a special case of 'unfoldrN' and can in principle be parallelized.------ Examples:------ >    sample 26 (\x -> chr(ord 'a'+x))--- > == pack "abcdefghijklmnopqrstuvwxyz"----sample :: (Storable a) => Int -> (Int -> a) -> Vector a-sample n f =-   fst $ unfoldrN n (\i -> Just (f i, succ i)) 0-{-# INLINE sample #-}----- ------------------------------------------------------------------------ Substrings---- | /O(1)/ 'take' @n@, applied to a 'Vector' @xs@, returns the prefix--- of @xs@ of length @n@, or @xs@ itself if @n > 'length' xs@.-take :: (Storable a) => Int -> Vector a -> Vector a-take n ps@(SV x s l)-    | n <= 0    = empty-    | n >= l    = ps-    | otherwise = SV x s n-{-# INLINE take #-}---- | /O(1)/ 'drop' @n xs@ returns the suffix of @xs@ after the first @n@--- elements, or 'empty' if @n > 'length' xs@.-drop  :: (Storable a) => Int -> Vector a -> Vector a-drop n ps@(SV x s l)-    | n <= 0    = ps-    | n >= l    = empty-    | otherwise = SV x (s+n) (l-n)-{-# INLINE drop #-}---- | /O(1)/ 'splitAt' @n xs@ is equivalent to @('take' n xs, 'drop' n xs)@.-splitAt :: (Storable a) => Int -> Vector a -> (Vector a, Vector a)-splitAt n ps@(SV x s l)-    | n <= 0    = (empty, ps)-    | n >= l    = (ps, empty)-    | otherwise = (SV x s n, SV x (s+n) (l-n))-{-# INLINE splitAt #-}---- | 'takeWhile', applied to a predicate @p@ and a 'Vector' @xs@,--- returns the longest prefix (possibly empty) of @xs@ of elements that--- satisfy @p@.-takeWhile :: (Storable a) => (a -> Bool) -> Vector a -> Vector a-takeWhile f ps = unsafeTake (findIndexOrEnd (not . f) ps) ps-{-# INLINE takeWhile #-}---- | 'dropWhile' @p xs@ returns the suffix remaining after 'takeWhile' @p xs@.-dropWhile :: (Storable a) => (a -> Bool) -> Vector a -> Vector a-dropWhile f ps = unsafeDrop (findIndexOrEnd (not . f) ps) ps-{-# INLINE dropWhile #-}---- | 'break' @p@ is equivalent to @'span' ('not' . p)@.-break :: (Storable a) => (a -> Bool) -> Vector a -> (Vector a, Vector a)-break p ps = case findIndexOrEnd p ps of n -> (unsafeTake n ps, unsafeDrop n ps)-{-# INLINE break #-}---- | 'breakEnd' behaves like 'break' but from the end of the 'Vector'------ breakEnd p == spanEnd (not.p)-breakEnd :: (Storable a) => (a -> Bool) -> Vector a -> (Vector a, Vector a)-breakEnd  p ps = splitAt (findFromEndUntil p ps) ps---- | 'span' @p xs@ breaks the 'Vector' into two segments. It is--- equivalent to @('takeWhile' p xs, 'dropWhile' p xs)@-span :: (Storable a) => (a -> Bool) -> Vector a -> (Vector a, Vector a)-span p ps = break (not . p) ps-{-# INLINE span #-}---- | 'spanEnd' behaves like 'span' but from the end of the 'Vector'.--- We have------ > spanEnd (not.isSpace) "x y z" == ("x y ","z")------ and------ > spanEnd (not . isSpace) ps--- >    ==--- > let (x,y) = span (not.isSpace) (reverse ps) in (reverse y, reverse x)----spanEnd :: (Storable a) => (a -> Bool) -> Vector a -> (Vector a, Vector a)-spanEnd  p ps = splitAt (findFromEndUntil (not.p) ps) ps---- | /O(n)/ Splits a 'Vector' into components delimited by--- separators, where the predicate returns True for a separator element.--- The resulting components do not contain the separators.  Two adjacent--- separators result in an empty component in the output.  eg.------ > splitWith (=='a') "aabbaca" == ["","","bb","c",""]--- > splitWith (=='a') []        == []----splitWith :: (Storable a) => (a -> Bool) -> Vector a -> [Vector a]-splitWith _ (SV _ _ 0) = []-splitWith p ps = loop ps-    where-        loop =-           uncurry (:) .-           mapSnd (switchL [] (\ _ t -> loop t)) .-           break p-{-# INLINE splitWith #-}---- | /O(n)/ Break a 'Vector' into pieces separated by the--- argument, consuming the delimiter. I.e.------ > split '\n' "a\nb\nd\ne" == ["a","b","d","e"]--- > split 'a'  "aXaXaXa"    == ["","X","X","X"]--- > split 'x'  "x"          == ["",""]------ and------ > join [c] . split c == id--- > split == splitWith . (==)------ As for all splitting functions in this library, this function does--- not copy the substrings, it just constructs new 'Vector's that--- are slices of the original.----split :: (Storable a, Eq a) => a -> Vector a -> [Vector a]-split w v = splitWith (w==) v-{-# INLINE split #-}---- | Like 'splitWith', except that sequences of adjacent separators are--- treated as a single separator. eg.------ > tokens (=='a') "aabbaca" == ["bb","c"]----tokens :: (Storable a) => (a -> Bool) -> Vector a -> [Vector a]-tokens f = P.filter (not.null) . splitWith f-{-# INLINE tokens #-}---- | The 'group' function takes a 'Vector' and returns a list of--- 'Vector's such that the concatenation of the result is equal to the--- argument.  Moreover, each sublist in the result contains only equal--- elements.  For example,------ > group "Mississippi" = ["M","i","ss","i","ss","i","pp","i"]------ It is a special case of 'groupBy', which allows the programmer to--- supply their own equality test. It is about 40% faster than--- /groupBy (==)/-group :: (Storable a, Eq a) => Vector a -> [Vector a]-group xs =-   switchL []-      (\ h _ ->-          let (ys, zs) = span (== h) xs-          in  ys : group zs)-      xs---- | The 'groupBy' function is the non-overloaded version of 'group'.-groupBy :: (Storable a) => (a -> a -> Bool) -> Vector a -> [Vector a]-groupBy k xs =-   switchL []-      (\ h t ->-          let n = 1 + findIndexOrEnd (not . k h) t-          in  unsafeTake n xs : groupBy k (unsafeDrop n xs))-      xs-{-# INLINE groupBy #-}----- | /O(n)/ The 'join' function takes a 'Vector' and a list of--- 'Vector's and concatenates the list after interspersing the first--- argument between each element of the list.-join :: (Storable a) => Vector a -> [Vector a] -> Vector a-join s = concat . List.intersperse s-{-# INLINE join #-}---- ------------------------------------------------------------------------ Indexing 'Vector's---- | /O(1)/ 'Vector' index (subscript) operator, starting from 0.-index :: (Storable a) => Vector a -> Int -> a-index ps n-    | n < 0          = moduleError "index" ("negative index: " ++ show n)-    | n >= length ps = moduleError "index" ("index too large: " ++ show n-                                         ++ ", length = " ++ show (length ps))-    | otherwise      = ps `unsafeIndex` n-{-# INLINE index #-}---- | /O(n)/ The 'elemIndex' function returns the index of the first--- element in the given 'Vector' which is equal to the query--- element, or 'Nothing' if there is no such element.-elemIndex :: (Storable a, Eq a) => a -> Vector a -> Maybe Int-elemIndex c = findIndex (c==)-{-# INLINE elemIndex #-}---- | /O(n)/ The 'elemIndexEnd' function returns the last index of the--- element in the given 'Vector' which is equal to the query--- element, or 'Nothing' if there is no such element. The following--- holds:------ > elemIndexEnd c xs ==--- > (-) (length xs - 1) `fmap` elemIndex c (reverse xs)----elemIndexEnd :: (Storable a, Eq a) => a -> Vector a -> Maybe Int-elemIndexEnd c =-   fst .-   foldl-      (\(ri,i) x -> (if c==x then Just i else ri, succ i))-      (Nothing,0)-{-# INLINE elemIndexEnd #-}---- | /O(n)/ The 'elemIndices' function extends 'elemIndex', by returning--- the indices of all elements equal to the query element, in ascending order.-elemIndices :: (Storable a, Eq a) => a -> Vector a -> [Int]-elemIndices c = findIndices (c==)-{-# INLINE elemIndices #-}---- | count returns the number of times its argument appears in the 'Vector'------ > count = length . elemIndices------ But more efficiently than using length on the intermediate list.-count :: (Storable a, Eq a) => a -> Vector a -> Int-count w =-   foldl (flip $ \c -> if c==w then succ else id) 0-{--count w sv =-   List.length $ elemIndices w sv--}-{-# INLINE count #-}---- | The 'findIndex' function takes a predicate and a 'Vector' and--- returns the index of the first element in the 'Vector'--- satisfying the predicate.-findIndex :: (Storable a) => (a -> Bool) -> Vector a -> Maybe Int-findIndex p xs =-   {- The implementation is in principle the same as for findIndices,-      but we use the First monoid, instead of the List/append monoid.-      We could also implement findIndex in terms of monoidConcatMap. -}-   foldr-      (\x k n ->-         toMaybe (p x) n `mplus` k (succ n))-      (const Nothing) xs 0-{-# INLINE findIndex #-}---- | The 'findIndices' function extends 'findIndex', by returning the--- indices of all elements satisfying the predicate, in ascending order.-findIndices :: (Storable a) => (a -> Bool) -> Vector a -> [Int]-findIndices p xs =-   foldr-      (\x k n ->-         (if p x then (n:) else id)-            (k (succ n)))-      (const []) xs 0-{-# INLINE findIndices #-}---- | 'findIndexOrEnd' is a variant of findIndex, that returns the length--- of the string if no element is found, rather than Nothing.-findIndexOrEnd :: (Storable a) => (a -> Bool) -> Vector a -> Int-findIndexOrEnd p xs =-   foldr-      (\x k n ->-         if p x then n else k (succ n))-      id xs 0-{-# INLINE findIndexOrEnd #-}---- ------------------------------------------------------------------------ Searching Vectors---- | /O(n)/ 'elem' is the 'Vector' membership predicate.-elem :: (Storable a, Eq a) => a -> Vector a -> Bool-elem c ps = isJust $ elemIndex c ps-{-# INLINE elem #-}---- | /O(n)/ 'notElem' is the inverse of 'elem'-notElem :: (Storable a, Eq a) => a -> Vector a -> Bool-notElem c ps = not (elem c ps)-{-# INLINE notElem #-}---- | /O(n)/ 'filter', applied to a predicate and a 'Vector',--- returns a 'Vector' containing those elements that satisfy the--- predicate. This function is subject to array fusion.-filter :: (Storable a) => (a -> Bool) -> Vector a -> Vector a-filter p (SV fp s l) =-   let end = s+l-   in  fst $-       unfoldrN l-          (let go = Strict.arguments1 $ \k0 ->-                  do guard (k0<end)-                     let x = foreignPeek fp k0-                         k1 = succ k0-                     if p x-                       then Just (x,k1)-                       else go k1-           in  go)-          s-{-# 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 == unsafeTake l1 y---- | /O(n)/ The 'isSuffixOf' function takes two 'Vector's and returns 'True'--- iff the first is a suffix of the second.------ The following holds:------ > isSuffixOf x y == reverse x `isPrefixOf` reverse y----isSuffixOf :: (Storable a, Eq a) => Vector a -> Vector a -> Bool-isSuffixOf x@(SV _ _ l1) y@(SV _ _ l2) =-    l1 <= l2 && x == unsafeDrop (l2 - l1) y---- ------------------------------------------------------------------------ Zipping---- | /O(n)/ 'zip' takes two 'Vector's and returns a list of--- corresponding pairs of elements. If one input 'Vector' is short,--- excess elements of the longer 'Vector' are discarded. This is--- equivalent to a pair of 'unpack' operations.-zip :: (Storable a, Storable b) => Vector a -> Vector b -> [(a, b)]-zip ps qs =-   maybe [] id $-      do (ph,pt) <- viewL ps-         (qh,qt) <- viewL qs-         return ((ph,qh) : zip pt qt)---- | 'zipWith' generalises 'zip' by zipping with the function given as--- the first argument, instead of a tupling function.  For example,--- @'zipWith' (+)@ is applied to two 'Vector's to produce the list of--- corresponding sums.-zipWith :: (Storable a, Storable b, Storable c) =>-   (a -> b -> c) -> Vector a -> Vector b -> Vector c-zipWith f as bs =-   unsafeWithStartPtr as $ \pa0 la ->-   withStartPtr       bs $ \pb0 lb ->-   let len = min la lb-   in  create len $ \p0 ->-       let go = Strict.arguments4 $ \n p pa pb ->-              when (n>0) $-                 liftM2 f (peek pa) (peek pb) >>= poke p >>-                 go (pred n) (incPtr p) (incPtr pa) (incPtr pb)-       in  go len p0 pa0 pb0----- zipWith f ps qs = pack $ List.zipWith f (unpack ps) (unpack qs)-{-# INLINE zipWith #-}---- | Like 'zipWith' but for three input vectors-zipWith3 :: (Storable a, Storable b, Storable c, Storable d) =>-   (a -> b -> c -> d) -> Vector a -> Vector b -> Vector c -> Vector d-zipWith3 f as bs cs =-   unsafeWithStartPtr as $ \pa0 la ->-   withStartPtr       bs $ \pb0 lb ->-   withStartPtr       cs $ \pc0 lc ->-   let len = la `min` lb `min` lc-   in  create len $ \p0 ->-       let go = Strict.arguments5 $ \n p pa pb pc ->-              when (n>0) $-                 liftM3 f (peek pa) (peek pb) (peek pc) >>= poke p >>-                 go (pred n) (incPtr p) (incPtr pa) (incPtr pb) (incPtr pc)-       in  go len p0 pa0 pb0 pc0-{-# INLINE zipWith3 #-}---- | Like 'zipWith' but for four input vectors--- If you need even more input vectors,--- you might write a function yourselve using unfoldrN and viewL.-zipWith4 :: (Storable a, Storable b, Storable c, Storable d, Storable e) =>-   (a -> b -> c -> d -> e) -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e-zipWith4 f as bs cs ds =-   unsafeWithStartPtr as $ \pa0 la ->-   withStartPtr       bs $ \pb0 lb ->-   withStartPtr       cs $ \pc0 lc ->-   withStartPtr       ds $ \pd0 ld ->-   let len = la `min` lb `min` lc `min` ld-   in  create len $ \p0 ->-       let go =-              Strict.arguments2 $ \n p ->-              Strict.arguments4 $ \pa pb pc pd ->-              when (n>0) $-                 liftM4 f (peek pa) (peek pb) (peek pc) (peek pd) >>= poke p >>-                 go (pred n) (incPtr p) (incPtr pa) (incPtr pb) (incPtr pc) (incPtr pd)-       in  go len p0 pa0 pb0 pc0 pd0-{-# INLINE zipWith4 #-}---- | /O(n)/ 'unzip' transforms a list of pairs of elements into a pair of--- 'Vector's. Note that this performs two 'pack' operations.-unzip :: (Storable a, Storable b) => [(a, b)] -> (Vector a, Vector b)-unzip ls = (pack (P.map fst ls), pack (P.map snd ls))-{-# INLINE unzip #-}---- ------------------------------------------------------------------------ Interleaved 'Vector's---- | /O(l/n)/ 'sieve' selects every 'n'th element.-sieve :: (Storable a) => Int -> Vector a -> Vector a-sieve n (SV fp s l) =-   let end = s+l-   in  fst $-       unfoldrN (- div (-l) n)-          (Strict.arguments1 $ \k0 ->-              do guard (k0<end)-                 Just (foreignPeek fp k0, k0 + n))-          s-{-# INLINE sieve #-}---- | /O(n)/--- Returns n sieved vectors with successive starting elements.--- @deinterleave 3 (pack ['a'..'k']) = [pack "adgj", pack "behk", pack "cfi"]@--- This is the same as 'Data.List.HT.sliceHorizontal'.-deinterleave :: (Storable a) => Int -> Vector a -> [Vector a]-deinterleave n =-   P.map (sieve n) . P.take n . P.iterate laxTail---- | /O(n)/--- Almost the inverse of deinterleave.--- Restriction is that all input vector must have equal length.--- @interleave [pack "adgj", pack "behk", pack "cfil"] = pack ['a'..'l']@-interleave :: (Storable a) => [Vector a] -> Vector a-interleave vs =-   Unsafe.performIO $-   MC.runContT-      (do-         pls <- mapM (\v -> MC.ContT (withStartPtr v . curry)) vs-         let (ps,ls) = P.unzip pls-         ptrs <- MC.ContT (withArray ps)-         if and (ListHT.mapAdjacent (==) ls)-           then return (ptrs, P.sum ls)-           else moduleError "interleave" "all input vectors must have the same length")-      (\(ptrs, totalLength) -> create totalLength $ \p ->-         let n = P.length vs-             pEnd = advancePtr p totalLength-             go = Strict.arguments3 $ \k0 j p0 -> do-                poke p0 =<< flip peekElemOff j =<< peekElemOff ptrs k0-                let p1 = advancePtr p0 1-                    k1 = succ k0-                when (p1 < pEnd) $-                   if k1 < n-                     then go k1 j p1-                     else go 0 (succ j) p1-         in  go 0 0 p)-{-# INLINE interleave #-}----- ------------------------------------------------------------------------ Special lists---- | /O(n)/ Return all initial segments of the given 'Vector', shortest first.-inits :: (Storable a) => Vector a -> [Vector a]-inits (SV x s l) = List.map (SV x s) [0..l]---- | /O(n)/ Return all final segments of the given 'Vector', longest first.-tails :: (Storable a) => Vector a -> [Vector a]-tails p =-   switchL [empty] (\ _ t -> p : tails t) p---- ------------------------------------------------------------------------ ** Ordered 'Vector's---- ------------------------------------------------------------------------ Low level constructors---- | /O(n)/ Make a copy of the 'Vector' with its own storage.---   This is mainly useful to allow the rest of the data pointed---   to by the 'Vector' to be garbage collected, for example---   if a large string has been read in, and only a small part of it---   is needed in the rest of the program.-copy :: (Storable a) => Vector a -> Vector a-copy v =-   unsafeWithStartPtr v $ \f l ->-   create l $ \p ->-   copyArray p f (fromIntegral l)------ ------------------------------------------------------------------------ IO---- | Outputs a 'Vector' to the specified 'Handle'.-hPut :: (Storable a) => Handle -> Vector a -> IO ()-hPut h v =-   when (not (null v)) $-      withStartPtr v $ \ ptrS l ->-         let ptrE = advancePtr ptrS l-             -- use advancePtr and minusPtr in order to respect alignment-         in  hPutBuf h ptrS (minusPtr ptrE ptrS)---- | Read a 'Vector' directly from the specified 'Handle'.  This--- is far more efficient than reading the characters into a list--- and then using 'pack'.----hGet :: (Storable a) => Handle -> Int -> IO (Vector a)-hGet _ 0 = return empty-hGet h l =-   createAndTrim l $ \p ->-      let elemType :: Ptr a -> a-          elemType _ = undefined-          roundUp m n = n + mod (-n) m-          sizeOfElem =-             roundUp-                (alignment (elemType p))-                (sizeOf (elemType p))-      in  fmap (flip div sizeOfElem) $-          hGetBuf h p (l * sizeOfElem)-{--   createAndTrim l $ \p ->-      fmap (flip div (incPtr p `minusPtr` p)) $-      hGetBuf h p (advancePtr p l `minusPtr` p)--}---- | Read an entire file strictly into a 'Vector'.  This is far more--- efficient than reading the characters into a 'String' and then using--- 'pack'.  It also may be more efficient than opening the file and--- reading it using hGet. Files are read using 'binary mode' on Windows.----readFile :: (Storable a) => FilePath -> IO (Vector a)-readFile f =-   bracket (openBinaryFile f ReadMode) hClose-      (\h -> hGet h . fromIntegral =<< hFileSize h)---- | Write a 'Vector' to a file.-writeFile :: (Storable a) => FilePath -> Vector a -> IO ()-writeFile f txt =-   bracket (openBinaryFile f WriteMode) hClose-      (\h -> hPut h txt)---- | Append a 'Vector' to a file.-appendFile :: (Storable a) => FilePath -> Vector a -> IO ()-appendFile f txt =-   bracket (openBinaryFile f AppendMode) hClose-      (\h -> hPut h txt)----- ------------------------------------------------------------------------ Internal utilities----- These definitions of succ and pred do not check for overflow--- and are faster than their counterparts from Enum class.-succ :: Int -> Int-succ n = n+1-{-# INLINE succ #-}--pred :: Int -> Int-pred n = n-1-{-# INLINE pred #-}--unsafeWithStartPtr :: Storable a => Vector a -> (Ptr a -> Int -> IO b) -> b-unsafeWithStartPtr v f =-   Unsafe.performIO (withStartPtr v f)-{-# INLINE unsafeWithStartPtr #-}--foreignPeek :: Storable a => ForeignPtr a -> Int -> a-foreignPeek fp k =-   inlinePerformIO $ withForeignPtr fp $ flip peekElemOff k-{-# INLINE foreignPeek #-}--withNonEmptyVector ::-   String -> (ForeignPtr a -> Int -> Int -> b) -> Vector a -> b-withNonEmptyVector fun f (SV x s l) =-   if l <= 0-     then errorEmpty fun-     else f x s l-{-# INLINE withNonEmptyVector #-}---- Common up near identical calls to `error' to reduce the number--- constant strings created when compiled:-errorEmpty :: String -> a-errorEmpty fun = moduleError fun "empty Vector"-{-# NOINLINE errorEmpty #-}--moduleError :: String -> String -> a-moduleError fun msg = error ("Data.StorableVector." ++ fun ++ ':':' ':msg)-{-# NOINLINE moduleError #-}---- Find from the end of the string using predicate-findFromEndUntil :: (Storable a) => (a -> Bool) -> Vector a -> Int-findFromEndUntil = Strict.arguments2 $ \f ps@(SV x s l) ->-    if null ps then 0-    else if f (last ps) then l-         else findFromEndUntil f (SV x s (l-1))
− Data/StorableVector/Base.hs 
@@ -1,225 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE UnboxedTuples #-}-{-# LANGUAGE DeriveDataTypeable #-}------ Module      : Data.StorableVector.Base--- License     : BSD-style--- Maintainer  : dons@cse.unsw.edu.au--- Stability   : experimental--- Portability : portable, requires ffi and cpp--- Tested with : GHC 6.4.1 and Hugs March 2005--- ---- | A module containing semi-public StorableVector internals. This exposes--- the StorableVector representation and low level construction functions.--- Modules which extend the StorableVector system will need to use this module--- while ideally most users will be able to make do with the public interface--- modules.----module Data.StorableVector.Base (--        -- * The @Vector@ type and representation-        Vector(..),             -- instances: Eq, Ord, Show, Read, Data, Typeable--        -- * Unchecked access-        unsafeHead,             -- :: Vector a -> a-        unsafeTail,             -- :: Vector a -> Vector a-        unsafeLast,             -- :: Vector a -> a-        unsafeInit,             -- :: Vector a -> Vector a-        unsafeIndex,            -- :: Vector a -> Int -> a-        unsafeTake,             -- :: Int -> Vector a -> Vector a-        unsafeDrop,             -- :: Int -> Vector a -> Vector a--        -- * Low level introduction and elimination-        create,                 -- :: Int -> (Ptr a -> IO ()) -> IO (Vector a)-        createAndTrim,          -- :: Int -> (Ptr a -> IO Int) -> IO (Vector a)-        createAndTrim',         -- :: Int -> (Ptr a -> IO (Int, Int, b)) -> IO (Vector a, b)--        unsafeCreate,           -- :: Int -> (Ptr a -> IO ()) ->  Vector a--        fromForeignPtr,         -- :: ForeignPtr a -> Int -> Vector a-        toForeignPtr,           -- :: Vector a -> (ForeignPtr a, Int, Int)-        withStartPtr,           -- :: Vector a -> (Ptr a -> Int -> IO b) -> IO b-        incPtr,                 -- :: Ptr a -> Ptr a--        inlinePerformIO--  ) where--import Foreign.Ptr              (Ptr)-import Foreign.ForeignPtr       (ForeignPtr, withForeignPtr, )-import Foreign.Marshal.Array    (advancePtr, copyArray)-import Foreign.Storable         (Storable(peekElemOff))--import Data.StorableVector.Memory (mallocForeignPtrArray, )--import Control.Exception        (assert)--#if defined(__GLASGOW_HASKELL__)-import Data.Generics            (Data(..), Typeable(..))-import GHC.Base                 (realWorld#)-import GHC.IO                   (IO(IO), )-#endif--import qualified System.Unsafe as Unsafe---- CFILES stuff is Hugs only-{-# CFILES cbits/fpstring.c #-}---- --------------------------------------------------------------------------------- | A space-efficient representation of a vector, supporting many efficient--- operations.------ Instances of Eq, Ord, Read, Show, Data, Typeable----data Vector a = SV {-# UNPACK #-} !(ForeignPtr a)-                   {-# UNPACK #-} !Int                -- offset-                   {-# UNPACK #-} !Int                -- length-#if defined(__GLASGOW_HASKELL__)-    deriving (Data, Typeable)-#endif---- --------------------------------------------------------------------------- Extensions to the basic interface------- | A variety of 'head' for non-empty Vectors. 'unsafeHead' omits the--- check for the empty case, so there is an obligation on the programmer--- to provide a proof that the Vector is non-empty.-unsafeHead :: (Storable a) => Vector a -> a-unsafeHead (SV x s l) = assert (l > 0) $-    inlinePerformIO $ withForeignPtr x $ \p -> peekElemOff p s-{-# INLINE unsafeHead #-}---- | A variety of 'tail' for non-empty Vectors. 'unsafeTail' omits the--- check for the empty case. As with 'unsafeHead', the programmer must--- provide a separate proof that the Vector is non-empty.-unsafeTail :: (Storable a) => Vector a -> Vector a-unsafeTail (SV ps s l) = assert (l > 0) $ SV ps (s+1) (l-1)-{-# INLINE unsafeTail #-}---- | A variety of 'last' for non-empty Vectors. 'unsafeLast' omits the--- check for the empty case, so there is an obligation on the programmer--- to provide a proof that the Vector is non-empty.-unsafeLast :: (Storable a) => Vector a -> a-unsafeLast (SV x s l) = assert (l > 0) $-    inlinePerformIO $ withForeignPtr x $ \p -> peekElemOff p (s+l-1)-{-# INLINE unsafeLast #-}---- | A variety of 'init' for non-empty Vectors. 'unsafeInit' omits the--- check for the empty case. As with 'unsafeLast', the programmer must--- provide a separate proof that the Vector is non-empty.-unsafeInit :: (Storable a) => Vector a -> Vector a-unsafeInit (SV ps s l) = assert (l > 0) $ SV ps s (l-1)-{-# INLINE unsafeInit #-}---- | Unsafe 'Vector' index (subscript) operator, starting from 0, returning a--- single element.  This omits the bounds check, which means there is an--- accompanying obligation on the programmer to ensure the bounds are checked in--- some other way.-unsafeIndex :: (Storable a) => Vector a -> Int -> a-unsafeIndex (SV x s l) i = assert (i >= 0 && i < l) $-    inlinePerformIO $ withForeignPtr x $ \p -> peekElemOff p (s+i)-{-# INLINE unsafeIndex #-}---- | A variety of 'take' which omits the checks on @n@ so there is an--- obligation on the programmer to provide a proof that @0 <= n <= 'length' xs@.-unsafeTake :: (Storable a) => Int -> Vector a -> Vector a-unsafeTake n (SV x s l) = assert (0 <= n && n <= l) $ SV x s n-{-# INLINE unsafeTake #-}---- | A variety of 'drop' which omits the checks on @n@ so there is an--- obligation on the programmer to provide a proof that @0 <= n <= 'length' xs@.-unsafeDrop :: (Storable a) => Int -> Vector a -> Vector a-unsafeDrop n (SV x s l) = assert (0 <= n && n <= l) $ SV x (s+n) (l-n)-{-# INLINE unsafeDrop #-}---instance (Storable a, Show a) => Show (Vector a) where-   showsPrec p xs@(SV _ _ l) =-      showParen (p>=10)-         (showString "Vector.pack " .-          showsPrec 10 (map (unsafeIndex xs) [0..(l-1)]))----- ------------------------------------------------------------------------ Low level constructors---- | /O(1)/ Build a Vector from a ForeignPtr-fromForeignPtr :: ForeignPtr a -> Int -> Vector a-fromForeignPtr fp l = SV fp 0 l---- | /O(1)/ Deconstruct a ForeignPtr from a Vector-toForeignPtr :: Vector a -> (ForeignPtr a, Int, Int)-toForeignPtr (SV ps s l) = (ps, s, l)---- | Run an action that is initialized--- with a pointer to the first element to be used.-withStartPtr :: Storable a => Vector a -> (Ptr a -> Int -> IO b) -> IO b-withStartPtr (SV x s l) f =-   withForeignPtr x $ \p -> f (p `advancePtr` s) l-{-# INLINE withStartPtr #-}--incPtr :: (Storable a) => Ptr a -> Ptr a-incPtr v = advancePtr v 1-{-# INLINE incPtr #-}---- | A way of creating Vectors outside the IO monad. The @Int@--- argument gives the final size of the Vector. Unlike--- 'createAndTrim' the Vector is not reallocated if the final size--- is less than the estimated size.-unsafeCreate :: (Storable a) => Int -> (Ptr a -> IO ()) -> Vector a-unsafeCreate l f = Unsafe.performIO (create l f)-{-# INLINE unsafeCreate #-}---- | Wrapper of mallocForeignPtrArray.-create :: (Storable a) => Int -> (Ptr a -> IO ()) -> IO (Vector a)-create l f = do-    fp <- mallocForeignPtrArray l-    withForeignPtr fp $ \p -> f p-    return $! SV fp 0 l---- | Given the maximum size needed and a function to make the contents--- of a Vector, createAndTrim makes the 'Vector'. The generating--- function is required to return the actual final size (<= the maximum--- size), and the resulting byte array is realloced to this size.------ createAndTrim is the main mechanism for creating custom, efficient--- Vector functions, using Haskell or C functions to fill the space.----createAndTrim :: (Storable a) => Int -> (Ptr a -> IO Int) -> IO (Vector a)-createAndTrim l f = do-    fp <- mallocForeignPtrArray l-    withForeignPtr fp $ \p -> do-        l' <- f p-        if assert (l' <= l) $ l' >= l-            then return $! SV fp 0 l-            else create l' $ \p' -> copyArray p' p l'--createAndTrim' :: (Storable a) => Int -                               -> (Ptr a -> IO (Int, Int, b))-                               -> IO (Vector a, b)-createAndTrim' l f = do-    fp <- mallocForeignPtrArray l-    withForeignPtr fp $ \p -> do-        (off, l', res) <- f p-        if assert (l' <= l) $ l' >= l-            then return $! (SV fp 0 l, res)-            else do ps <- create l' $ \p' -> copyArray p' (p `advancePtr` off) l'-                    return $! (ps, res)---- | Just like Unsafe.performIO, but we inline it. Big performance gains as--- it exposes lots of things to further inlining. /Very unsafe/. In--- particular, you should do no memory allocation inside an--- 'inlinePerformIO' block. On Hugs this is just @Unsafe.performIO@.----{-# INLINE inlinePerformIO #-}-inlinePerformIO :: IO a -> a-#if defined(__GLASGOW_HASKELL__)-inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r-#else-inlinePerformIO = Unsafe.performIO-#endif
− Data/StorableVector/Cursor.hs 
@@ -1,353 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-{- |-Simulate a list with strict elements by a more efficient array structure.--}-module Data.StorableVector.Cursor where--import Control.Exception        (assert, )-import Control.Monad.Trans.State (StateT(StateT), runStateT, )-import Data.IORef               (IORef, newIORef, readIORef, writeIORef, )--import Foreign.Storable         (Storable(peekElemOff, pokeElemOff))-import Foreign.ForeignPtr       (ForeignPtr, withForeignPtr, )--- import Foreign.Ptr              (Ptr)-import Data.StorableVector.Memory (mallocForeignPtrArray, )--import Control.Monad            (when)-import Data.Maybe               (isNothing)--import qualified System.Unsafe as Unsafe--import qualified Data.List.HT as ListHT-import Data.Tuple.HT (mapSnd, )--import Prelude hiding (length, foldr, zipWith, take, drop, )---{--ToDo:-I think that the state should be Storable as well-and that the IORef should be replaced by a ForeignPtr.-I hope that this is more efficient.-With this restriction @s@ cannot be e.g. a function type-but this would kill performance anyway.-Functions that need this flexibility may fall back to other data structures-(lists or chunky StorableVectors) and convert to the Cursor structure later.--}--- | Cf. StreamFusion  Data.Stream-data Generator a =-   forall s. -- Seq s =>-      Generator-         !(StateT s Maybe a)  -- compute next value-         {-# UNPACK #-}-         !(IORef (Maybe s))   -- current state--{- |-This simulates a-@ data StrictList a = Elem !a (StrictList a) | End @-by an array and some unsafe hacks.--}-data Buffer a =-   Buffer {-       memory :: {-# UNPACK #-} !(ForeignPtr a),-       size   :: {-# UNPACK #-} !Int,  -- size of allocated memory, I think I only need it for debugging-       gen    ::                !(Generator a),  -- we need this indirection for the existential type in Generator-       cursor :: {-# UNPACK #-} !(IORef Int)-   }--{- |-Vector is a part of a buffer.--}-data Vector a =-   Vector {-       buffer :: {-# UNPACK #-} !(Buffer a),-       start  :: {-# UNPACK #-} !Int,   -- invariant: start <= cursor-       maxLen :: {-# UNPACK #-} !Int    -- invariant: start+maxLen <= size buffer-   }----- * construction--{-# INLINE create #-}-create :: (Storable a) => Int -> Generator a -> Buffer a-create l g = Unsafe.performIO (createIO l g)---- | Wrapper of mallocForeignPtrArray.-createIO :: (Storable a) => Int -> Generator a -> IO (Buffer a)-createIO l g = do-    fp <- mallocForeignPtrArray l-    cur <- newIORef 0-    return $! Buffer fp l g cur---{- |-@ unfoldrNTerm 20  (\n -> Just (n, succ n)) 'a' @--}-unfoldrNTerm :: (Storable b) =>-   Int -> (a -> Maybe (b, a)) -> a -> Vector b-unfoldrNTerm l f x0 =-   Unsafe.performIO (unfoldrNTermIO l f x0)--unfoldrNTermIO :: (Storable b) =>-   Int -> (a -> Maybe (b, a)) -> a -> IO (Vector b)-unfoldrNTermIO l f x0 =-   do ref <- newIORef (Just x0)-      buf <- createIO l (Generator (StateT f) ref)-      return (Vector buf 0 l)--unfoldrN :: (Storable b) =>-   Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a)-unfoldrN l f x0 =-   Unsafe.performIO (unfoldrNIO l f x0)--unfoldrNIO :: (Storable b) =>-   Int -> (a -> Maybe (b, a)) -> a -> IO (Vector b, Maybe a)-unfoldrNIO l f x0 =-   do ref <- newIORef (Just x0)-      buf <- createIO l (Generator (StateT f) ref)-      s <- Unsafe.interleaveIO $-             do evaluateToIO l buf-                readIORef ref-      return (Vector buf 0 l, s)-{--unfoldrNIO :: (Storable b) =>-   Int -> (a -> Maybe (b, a)) -> a -> IO (Vector b, Maybe a)-unfoldrNIO l f x0 =-   do y <- unfoldrNTermIO l f x0---      evaluateTo l y-      let (Generator _ ref) = gen (buffer y)-      s <- readIORef ref-      return (y, s)--Data/StorableVector/Cursor.hs:98:10:-    My brain just exploded.-    I can't handle pattern bindings for existentially-quantified constructors.-    In the binding group-        (Generator _ ref) = gen (buffer y)-    In the definition of `unfoldrNIO':-        unfoldrNIO l f x0-                     = do-                         y <- unfoldrNTermIO l f x0-                         let (Generator _ ref) = gen (buffer y)-                         s <- readIORef ref-                         return (y, s)--}---{--unfoldrN :: (Storable b) =>-   Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a)-unfoldrN i f x0 =-   let y = unfoldrNTerm i f x0-   in  (y, getFinalState y)--getFinalState :: (Storable b) =>-   Vector b -> Maybe a-getFinalState y =-   Unsafe.performIO $-      ...--}---{-# INLINE pack #-}-pack :: (Storable a) => Int -> [a] -> Vector a-pack n = unfoldrNTerm n ListHT.viewL---{-# INLINE cons #-}-{- |-This is expensive and should not be used to construct lists iteratively!-A recursion-enabling 'cons' would be 'consN'-that allocates a buffer of given size,-initializes the leading cell and sets the buffer pointer to the next cell.--}-cons :: Storable a =>-   a -> Vector a -> Vector a-cons x xs =-   unfoldrNTerm (succ (maxLen xs))-      (\(mx0,xs0) ->-          fmap (mapSnd ((,) Nothing)) $-          maybe-             (viewL xs0)-             (\x0 -> Just (x0, xs0))-             mx0) $-   (Just x, xs)---{-# INLINE zipWith #-}-zipWith :: (Storable a, Storable b, Storable c) =>-   (a -> b -> c) -> Vector a -> Vector b -> Vector c-zipWith f ps0 qs0 =-   zipNWith (min (maxLen ps0) (maxLen qs0)) f ps0 qs0---- zipWith f ps qs = pack $ List.zipWith f (unpack ps) (unpack qs)--{-# INLINE zipNWith #-}-zipNWith :: (Storable a, Storable b, Storable c) =>-   Int -> (a -> b -> c) -> Vector a -> Vector b -> Vector c-zipNWith n f ps0 qs0 =-   unfoldrNTerm n-      (\(ps,qs) ->-         do (ph,pt) <- viewL ps-            (qh,qt) <- viewL qs-            return (f ph qh, (pt,qt)))-      (ps0,qs0)-{--let f2 = zipNWith 15 (+) f0 f1; f1 = cons 1 f2; f0 = cons (0::Int) f1 in f0--*Data.StorableVector.Cursor> let xs = unfoldrNTerm 20  (\n -> Just (n, succ n)) (0::Int)-*Data.StorableVector.Cursor> let ys = unfoldrNTerm 20  (\n -> Just (n, 2*n)) (1::Int)-*Data.StorableVector.Cursor> zipWith (+) xs ys--}------- * inspection---- | evaluate next value in a buffer-advanceIO :: Storable a =>-   Buffer a -> IO (Maybe a)-advanceIO (Buffer p sz (Generator n s) cr) =-   do c <- readIORef cr-      assert (c < sz) $-         do writeIORef cr (succ c)-            ms <- readIORef s-            case ms of-               Nothing -> return Nothing-               Just s0 ->-                  case runStateT n s0 of-                     Nothing ->-                        writeIORef s Nothing >>-                        return Nothing-                     Just (a,s1) ->-                        writeIORef s (Just s1) >>-                        withForeignPtr p (\q -> pokeElemOff q c a) >>-                        return (Just a)--{--It is tempting to turn this into a simple loop without the IORefs.-This could be compiled to an efficient strict loop,-but it would fail if the vector content depends on its own,-like in @fix (consN 1000 'a')@.--}--- | evaluate all values up to a given position-evaluateToIO :: Storable a =>-   Int -> Buffer a -> IO ()-evaluateToIO l buf@(Buffer _p _sz _g cr) =-   whileM-      (fmap (<l) (readIORef cr))-      (advanceIO buf)--whileM :: Monad m => m Bool -> m a -> m ()-whileM p f =-   let recourse =-          do b <- p-             when b (f >> recourse)-   in  recourse--{-# INLINE switchL #-}-switchL :: Storable a => b -> (a -> Vector a -> b) -> Vector a -> b-switchL n j v = maybe n (uncurry j) (viewL v)---{--If it returns False the list can be empty anyway.--}-obviousNullIO :: Vector a -> IO Bool-obviousNullIO (Vector (Buffer _ _ (Generator _ s) _) _ ml) =-   assert (ml >= 0) $-   do b <- readIORef s-      return (ml == 0 || isNothing b)--{--obviousNullIO :: Vector a -> IO Bool-obviousNullIO (Vector (Buffer _ sz (Generator _ s) _) st _) =-   do b <- readIORef s-      return (st >= sz || isNothing b)--}---   assert (l >= 0) $ l <= 0--{-# INLINE viewL #-}-viewL :: Storable a => Vector a -> Maybe (a, Vector a)-viewL v = Unsafe.performIO (viewLIO v)--{-# INLINE viewLIO #-}-viewLIO :: Storable a => Vector a -> IO (Maybe (a, Vector a))-viewLIO (Vector buf st ml) =-   do c <- readIORef (cursor buf)-      fmap (fmap (\a -> (a, Vector buf (succ st) (pred ml)))) $-        assert (st <= c) $-           if st == c-             then advanceIO buf-             else fmap Just $ withForeignPtr (memory buf) (\p -> peekElemOff p st)---{-# INLINE foldr #-}-foldr :: (Storable a) => (a -> b -> b) -> b -> Vector a -> b-foldr k z =-   let recourse = switchL z (\h t -> k h (recourse t))-   in  recourse---- | /O(n)/ Converts a 'Vector a' to a '[a]'.-{-# INLINE unpack #-}-unpack :: (Storable a) => Vector a -> [a]-unpack = foldr (:) []---instance (Show a, Storable a) => Show (Vector a) where-   showsPrec p x = showsPrec p (unpack x)---{-# INLINE null #-}-{--This can hardly be simplified.-In order to check the list for emptiness,-we have to try to calculate the next element.-It is not enough to check whether the state is Nothing,-because when we try to compute the next value, this can be Nothing.--}-null :: Storable a => Vector a -> Bool-null = switchL True (const (const False))---{--toVector :: Storable a => Vector a -> VS.Vector a-toVector v =-   VS.Cons (memory (buffer v)) ()--}---- length--drop :: (Storable a) => Int -> Vector a -> Vector a-drop n v = Unsafe.performIO $ dropIO n v--dropIO :: (Storable a) => Int -> Vector a -> IO (Vector a)-dropIO n v =-   assert (n>=0) $-    let pos = min (maxLen v) (start v + n)-    in  do evaluateToIO pos (buffer v)-           return (Vector (buffer v) pos (max 0 (maxLen v - n)))--take :: (Storable a) => Int -> Vector a -> Vector a-take n v =-   assert (n>=0) $-   v{maxLen = min n (maxLen v)}--{--let x = unfoldrNTerm 10 (\c -> Just (c,succ c)) 'a'-let x = unfoldrNTerm 10 (\c -> Just (sum [c..100000],succ c)) (0::Int)--}---{- |-For the sake of laziness it may allocate considerably more memory than needed,-if it filters out very much.--}-{-# INLINE filter #-}-filter :: (Storable a) => (a -> Bool) -> Vector a -> Vector a-filter p xs0 =-   unfoldrNTerm (maxLen xs0)-      (let recourse = switchL Nothing (\x xs -> if p x then Just (x,xs) else recourse xs)-       in  recourse)-      xs0
− Data/StorableVector/Lazy.hs 
@@ -1,1359 +0,0 @@-{- |-Chunky signal stream build on StorableVector.--Hints for fusion:- - Higher order functions should always be inlined in the end-   in order to turn them into machine loops-   instead of calling a function in an inner loop.--}-module Data.StorableVector.Lazy where--import qualified Data.List as List-import qualified Data.StorableVector as V-import qualified Data.StorableVector.Base as VB-import qualified Data.StorableVector.Lazy.PointerPrivate as Ptr--import qualified Numeric.NonNegative.Class as NonNeg--import qualified Data.List.HT as ListHT-import Data.Tuple.HT (mapPair, mapFst, mapSnd, swap, )-import Data.Maybe.HT (toMaybe, )-import Data.Maybe (fromMaybe, )--import Foreign.Storable (Storable)--import Data.Monoid (Monoid, mempty, mappend, mconcat, )--- import Control.Arrow ((***))-import Control.Monad (liftM, liftM2, liftM3, liftM4, {- guard, -} )---import System.IO (openBinaryFile, IOMode(WriteMode, ReadMode, AppendMode),-                  hClose, Handle)-import Control.Exception (bracket, catch, )--import qualified System.IO.Error as Exc-import qualified System.Unsafe as Unsafe--import Test.QuickCheck (Arbitrary(..))---{--import Prelude hiding-   (length, (++), concat, iterate, foldl, map, repeat, replicate, null,-    zip, zipWith, zipWith3, drop, take, splitAt, takeWhile, dropWhile, reverse)--}--import qualified Prelude as P--import Data.Either (Either(Left, Right), either, )-import Data.Maybe (Maybe(Just, Nothing), maybe, )-import Data.Function (const, flip, ($), (.), )-import Data.Tuple (fst, snd, uncurry, )-import Data.Bool (Bool(True,False), not, (&&), )-import Data.Ord (Ord, (<), (>), (<=), (>=), min, max, )-import Data.Eq (Eq, (==), )-import Control.Monad (mapM_, fmap, (=<<), (>>=), (>>), return, )-import Text.Show (Show, showsPrec, showParen, showString, show, )-import Prelude-   (IO, error, IOError,-    FilePath, String, Char,-    Enum, succ, pred,-    Num, Int, sum, (+), (-), divMod, mod, fromInteger, )----newtype Vector a = SV {chunks :: [V.Vector a]}---instance (Storable a) => Monoid (Vector a) where-    mempty  = empty-    mappend = append-    mconcat = concat--instance (Storable a, Eq a) => Eq (Vector a) where-   (==) = equal--instance (Storable a, Show a) => Show (Vector a) where-   showsPrec p xs =-      showParen (p>=10)-         (showString "VectorLazy.fromChunks " .-          showsPrec 10 (chunks xs))--instance (Storable a, Arbitrary a) => Arbitrary (Vector a) where-   arbitrary = liftM2 pack arbitrary arbitrary----- for a list of chunk sizes see "Data.StorableVector.LazySize".-newtype ChunkSize = ChunkSize Int-   deriving (Eq, Ord, Show)--instance Arbitrary ChunkSize where-   arbitrary = fmap (ChunkSize . max 1 . min 2048) arbitrary--{--ToDo:-Since non-negative-0.1 we have the Monoid superclass for NonNeg.-Maybe we do not need the Num instance anymore.--}-instance Num ChunkSize where-   (ChunkSize x) + (ChunkSize y)  =-       ChunkSize (x+y)-   (-)  =  moduleError "ChunkSize.-" "intentionally unimplemented"-   (*)  =  moduleError "ChunkSize.*" "intentionally unimplemented"-   abs  =  moduleError "ChunkSize.abs" "intentionally unimplemented"-   signum  =  moduleError "ChunkSize.signum" "intentionally unimplemented"-   fromInteger = ChunkSize . fromInteger--instance Monoid ChunkSize where-   mempty = ChunkSize 0-   mappend (ChunkSize x) (ChunkSize y) = ChunkSize (x+y)-   mconcat = ChunkSize . sum . List.map (\(ChunkSize c) -> c)--instance NonNeg.C ChunkSize where-   split = NonNeg.splitDefault (\(ChunkSize c) -> c) ChunkSize--chunkSize :: Int -> ChunkSize-chunkSize x =-   ChunkSize $-      if x>0-        then x-        else moduleError "chunkSize" ("no positive number: " List.++ show x)--defaultChunkSize :: ChunkSize-defaultChunkSize =-   ChunkSize 1024------ * Introducing and eliminating 'Vector's--{-# INLINE empty #-}-empty :: (Storable a) => Vector a-empty = SV []--{-# INLINE singleton #-}-singleton :: (Storable a) => a -> Vector a-singleton x = SV [V.singleton x]--fromChunks :: (Storable a) => [V.Vector a] -> Vector a-fromChunks = SV--pack :: (Storable a) => ChunkSize -> [a] -> Vector a-pack size = unfoldr size ListHT.viewL--unpack :: (Storable a) => Vector a -> [a]-unpack = List.concatMap V.unpack . chunks---{-# INLINE packWith #-}-packWith :: (Storable b) => ChunkSize -> (a -> b) -> [a] -> Vector b-packWith size f =-   unfoldr size (fmap (mapFst f) . ListHT.viewL)--{-# INLINE unpackWith #-}-unpackWith :: (Storable a) => (a -> b) -> Vector a -> [b]-unpackWith f = List.concatMap (V.unpackWith f) . chunks---{-# INLINE unfoldr #-}-unfoldr :: (Storable b) =>-   ChunkSize ->-   (a -> Maybe (b,a)) ->-   a ->-   Vector b-unfoldr (ChunkSize size) f =-   SV .-   List.unfoldr (cancelNullVector . V.unfoldrN size f =<<) .-   Just--{- |-Example:--> *Data.StorableVector.Lazy> unfoldrResult (ChunkSize 5) (\c -> if c>'z' then Left (Char.ord c) else Right (c, succ c)) 'a'-> (VectorLazy.fromChunks [Vector.pack "abcde",Vector.pack "fghij",Vector.pack "klmno",Vector.pack "pqrst",Vector.pack "uvwxy",Vector.pack "z"],123)--}-{-# INLINE unfoldrResult #-}-unfoldrResult :: (Storable b) =>-   ChunkSize ->-   (a -> Either c (b, a)) ->-   a ->-   (Vector b, c)-unfoldrResult (ChunkSize size) f =-   let recourse a0 =-          let (chunk, a1) =-                 V.unfoldrResultN size Right (either (Left . Left) Right . f) a0-          in  either-                 ((,) (if V.null chunk then [] else [chunk]))-                 (mapFst (chunk :) . recourse) a1-   in  mapFst SV . recourse---{-# INLINE sample #-}-sample :: (Storable a) => ChunkSize -> (Int -> a) -> Vector a-sample size f =-   unfoldr size (\i -> Just (f i, succ i)) 0--{-# INLINE sampleN #-}-sampleN :: (Storable a) => ChunkSize -> Int -> (Int -> a) -> Vector a-sampleN size n f =-   unfoldr size (\i -> toMaybe (i<n) (f i, succ i)) 0---{-# INLINE iterate #-}-iterate :: Storable a => ChunkSize -> (a -> a) -> a -> Vector a-iterate size f = unfoldr size (\x -> Just (x, f x))--repeat :: Storable a => ChunkSize -> a -> Vector a-repeat (ChunkSize size) =-   SV . List.repeat . V.replicate size--cycle :: Storable a => Vector a -> Vector a-cycle =-   SV . List.cycle . chunks--replicate :: Storable a => ChunkSize -> Int -> a -> Vector a-replicate (ChunkSize size) n x =-   let (numChunks, rest) = divMod n size-   in  append-          (SV (List.replicate numChunks (V.replicate size x)))-          (fromChunk (V.replicate rest x))------- * Basic interface--{-# INLINE null #-}-null :: (Storable a) => Vector a -> Bool-null = List.null . chunks--length :: Vector a -> Int-length = sum . List.map V.length . chunks--equal :: (Storable a, Eq a) => Vector a -> Vector a -> Bool-equal (SV xs0) (SV ys0) =-   let recourse (x:xs) (y:ys) =-          let l = min (V.length x) (V.length y)-              (xPrefix, xSuffix) = V.splitAt l x-              (yPrefix, ySuffix) = V.splitAt l y-              build z zs =-                 if V.null z then zs else z:zs-          in  xPrefix == yPrefix &&-              recourse (build xSuffix xs) (build ySuffix ys)-       recourse [] [] = True-       -- this requires that chunks will always be non-empty-       recourse _ _ = False-   in  recourse xs0 ys0--index :: (Storable a) => Vector a -> Int -> a-index (SV xs) n =-   if n < 0-     then-        moduleError "index"-           ("negative index: " List.++ show n)-     else-        List.foldr-           (\x k m0 ->-              let m1 = m0 - V.length x-              in  if m1 < 0-                    then VB.unsafeIndex x m0-                    else k m1)-           (\m -> moduleError "index"-                     ("index too large: " List.++ show n-                      List.++ ", length = " List.++ show (n-m)))-           xs n---{-# NOINLINE [0] cons #-}-cons :: Storable a => a -> Vector a -> Vector a-cons x = SV . (V.singleton x :) . chunks--infixr 5 `append`--{-# NOINLINE [0] append #-}-append :: Storable a => Vector a -> Vector a -> Vector a-append (SV xs) (SV ys)  =  SV (xs List.++ ys)---{- |-@extendL size x y@-prepends the chunk @x@ and merges it with the first chunk of @y@-if the total size is at most @size@.-This way you can prepend small chunks-while asserting a reasonable average size for chunks.--}-extendL :: Storable a => ChunkSize -> V.Vector a -> Vector a -> Vector a-extendL (ChunkSize size) x (SV yt) =-   SV $-   maybe-      [x]-      (\(y,ys) ->-          if V.length x + V.length y <= size-            then V.append x y : ys-            else x:yt)-      (ListHT.viewL yt)---concat :: (Storable a) => [Vector a] -> Vector a-concat = SV . List.concat . List.map chunks----- * Transformations--{-# INLINE map #-}-map :: (Storable x, Storable y) =>-      (x -> y)-   -> Vector x-   -> Vector y-map f = SV . List.map (V.map f) . chunks---reverse :: Storable a => Vector a -> Vector a-reverse =-   SV . List.reverse . List.map V.reverse . chunks----- * Reducing 'Vector's--{-# INLINE foldl #-}-foldl :: Storable b => (a -> b -> a) -> a -> Vector b -> a-foldl f x0 = List.foldl (V.foldl f) x0 . chunks--{-# INLINE foldl' #-}-foldl' :: Storable b => (a -> b -> a) -> a -> Vector b -> a-foldl' f x0 = List.foldl' (V.foldl f) x0 . chunks--{-# INLINE foldr #-}-foldr :: Storable b => (b -> a -> a) -> a -> Vector b -> a-foldr f x0 = List.foldr (flip (V.foldr f)) x0 . chunks---{-# INLINE monoidConcatMap #-}-monoidConcatMap :: (Storable a, Monoid m) => (a -> m) -> Vector a -> m-monoidConcatMap f =-   List.foldr (mappend . V.monoidConcatMap f) mempty . chunks--{-# INLINE any #-}-any :: (Storable a) => (a -> Bool) -> Vector a -> Bool-any p = List.any (V.any p) . chunks--{-# INLINE all #-}-all :: (Storable a) => (a -> Bool) -> Vector a -> Bool-all p = List.all (V.all p) . chunks--maximum :: (Storable a, Ord a) => Vector a -> a-maximum =-   List.maximum . List.map V.maximum . chunks---   List.foldl1' max . List.map V.maximum . chunks--minimum :: (Storable a, Ord a) => Vector a -> a-minimum =-   List.minimum . List.map V.minimum . chunks---   List.foldl1' min . List.map V.minimum . chunks--{--sum :: (Storable a, Num a) => Vector a -> a-sum =-   List.sum . List.map V.sum . chunks--product :: (Storable a, Num a) => Vector a -> a-product =-   List.product . List.map V.product . chunks--}----- * inspecting a vector--{-# INLINE pointer #-}-pointer :: Storable a => Vector a -> Ptr.Pointer a-pointer = Ptr.cons . chunks--{-# INLINE viewL #-}-viewL :: Storable a => Vector a -> Maybe (a, Vector a)-viewL (SV xs0) =-   do (x,xs) <- ListHT.viewL xs0-      (y,ys) <- V.viewL x-      return (y, append (fromChunk ys) (SV xs))--{-# INLINE viewR #-}-viewR :: Storable a => Vector a -> Maybe (Vector a, a)-viewR (SV xs0) =-   do xsp <- ListHT.viewR xs0-      let (xs,x) = xsp-{--   do ~(xs,x) <- ListHT.viewR xs0--}-      let (ys,y) = fromMaybe (moduleError "viewR" "last chunk empty") (V.viewR x)-      return (append (SV xs) (fromChunk ys), y)--{-# INLINE switchL #-}-switchL :: Storable a => b -> (a -> Vector a -> b) -> Vector a -> b-switchL n j =-   maybe n (uncurry j) . viewL--{-# INLINE switchR #-}-switchR :: Storable a => b -> (Vector a -> a -> b) -> Vector a -> b-switchR n j =-   maybe n (uncurry j) . viewR---{--viewLSafe :: Storable a => Vector a -> Maybe (a, Vector a)-viewLSafe (SV xs0) =-   -- dropWhile would be unnecessary if we require that all chunks are non-empty-   do (x,xs) <- ListHT.viewL (List.dropWhile V.null xs0)-      (y,ys) <- viewLVector x-      return (y, append (fromChunk ys) (SV xs))--viewRSafe :: Storable a => Vector a -> Maybe (Vector a, a)-viewRSafe (SV xs0) =-   -- dropWhile would be unnecessary if we require that all chunks are non-empty-   do (xs,x) <- ListHT.viewR (dropWhileRev V.null xs0)-      (ys,y) <- V.viewR x-      return (append (SV xs) (fromChunk ys), y)--}---{-# INLINE scanl #-}-scanl :: (Storable a, Storable b) =>-   (a -> b -> a) -> a -> Vector b -> Vector a-scanl f start =-   cons start . snd .-   mapAccumL (\acc -> (\b -> (b,b)) . f acc) start--{-# INLINE mapAccumL #-}-mapAccumL :: (Storable a, Storable b) =>-   (acc -> a -> (acc, b)) -> acc -> Vector a -> (acc, Vector b)-mapAccumL f start =-   mapSnd SV .-   List.mapAccumL (V.mapAccumL f) start .-   chunks--{-# INLINE mapAccumR #-}-mapAccumR :: (Storable a, Storable b) =>-   (acc -> a -> (acc, b)) -> acc -> Vector a -> (acc, Vector b)-mapAccumR f start =-   mapSnd SV .-   List.mapAccumR (V.mapAccumR f) start .-   chunks--{-# INLINE crochetLChunk #-}-crochetLChunk :: (Storable x, Storable y) =>-      (x -> acc -> Maybe (y, acc))-   -> acc-   -> V.Vector x-   -> (V.Vector y, Maybe acc)-crochetLChunk f acc0 x0 =-   mapSnd (fmap fst) $-   V.unfoldrN-      (V.length x0)-      (\(acc,xt) ->-         do (x,xs) <- V.viewL xt-            (y,acc') <- f x acc-            return (y, (acc',xs)))-      (acc0, x0)--{-# INLINE crochetL #-}-crochetL :: (Storable x, Storable y) =>-      (x -> acc -> Maybe (y, acc))-   -> acc-   -> Vector x-   -> Vector y-crochetL f acc0 =-   SV . List.unfoldr (\(xt,acc) ->-       do (x,xs) <- ListHT.viewL xt-          acc' <- acc-          return $ mapSnd ((,) xs) $ crochetLChunk f acc' x) .-   flip (,) (Just acc0) .-   chunks------ * sub-vectors--{-# INLINE take #-}-take :: (Storable a) => Int -> Vector a -> Vector a-{- this order of pattern matches is certainly the most lazy one-> take 4 (pack (chunkSize 2) $ "abcd" List.++ undefined)-VectorLazy.fromChunks [Vector.pack "ab",Vector.pack "cd"]--}-take 0 _ = empty-take _ (SV []) = empty-take n (SV (x:xs)) =-   let m = V.length x-   in  if m<=n-         then SV $ (x:) $ chunks $ take (n-m) $ SV xs-         else fromChunk (V.take n x)--{-# INLINE drop #-}-drop :: (Storable a) => Int -> Vector a -> Vector a-drop _ (SV []) = empty-drop n (SV (x:xs)) =-   let m = V.length x-   in  if m<=n-         then drop (n-m) (SV xs)-         else SV (V.drop n x : xs)--{-# INLINE splitAt #-}-splitAt :: (Storable a) => Int -> Vector a -> (Vector a, Vector a)-splitAt n0 =-   {- this order of pattern matches is certainly the most lazy one-   > splitAt 4 (pack (chunkSize 2) $ "abcd" List.++ undefined)-   (VectorLazy.fromChunks [Vector.pack "ab",Vector.pack "cd"],VectorLazy.fromChunks *** Exception: Prelude.undefined-   -}-   let recourse 0 xs = ([], xs)-       recourse _ [] = ([], [])-       recourse n (x:xs) =-          let m = V.length x-          in  if m<=n-                then mapFst (x:) $ recourse (n-m) xs-                else mapPair ((:[]), (:xs)) $ V.splitAt n x-   in  mapPair (SV, SV) . recourse n0 . chunks----{-# INLINE dropMarginRem #-}--- I have used this in an inner loop thus I prefer inlining-{- |-@dropMarginRem n m xs@-drops at most the first @m@ elements of @xs@-and ensures that @xs@ still contains @n@ elements.-Additionally returns the number of elements that could not be dropped-due to the margin constraint.-That is @dropMarginRem n m xs == (k,ys)@ implies @length xs - m == length ys - k@.-Requires @length xs >= n@.--}-dropMarginRem :: (Storable a) => Int -> Int -> Vector a -> (Int, Vector a)-dropMarginRem n m xs =-   List.foldl'-      (\(mi,xsi) k -> (mi-k, drop k xsi))-      (m,xs)-      (List.map V.length $ chunks $ take m $ drop n xs)--{--This implementation does only walk once through the dropped prefix.-It is maximally lazy and minimally space consuming.--}-{-# INLINE dropMargin #-}-dropMargin :: (Storable a) => Int -> Int -> Vector a -> Vector a-dropMargin n m xs =-   List.foldl' (flip drop) xs-      (List.map V.length $ chunks $ take m $ drop n xs)----{-# INLINE dropWhile #-}-dropWhile :: (Storable a) => (a -> Bool) -> Vector a -> Vector a-dropWhile _ (SV []) = empty-dropWhile p (SV (x:xs)) =-   let y = V.dropWhile p x-   in  if V.null y-         then dropWhile p (SV xs)-         else SV (y:xs)--{-# INLINE takeWhile #-}-takeWhile :: (Storable a) => (a -> Bool) -> Vector a -> Vector a-takeWhile _ (SV []) = empty-takeWhile p (SV (x:xs)) =-   let y = V.takeWhile p x-   in  if V.length y < V.length x-         then fromChunk y-         else SV (x : chunks (takeWhile p (SV xs)))---{-# INLINE span #-}-span :: (Storable a) => (a -> Bool) -> Vector a -> (Vector a, Vector a)-span p =-   let recourse [] = ([],[])-       recourse (x:xs) =-          let (y,z) = V.span p x-          in  if V.null z-                then mapFst (x:) (recourse xs)-                else (chunks $ fromChunk y, (z:xs))-   in  mapPair (SV, SV) . recourse . chunks-{--span _ (SV []) = (empty, empty)-span p (SV (x:xs)) =-   let (y,z) = V.span p x-   in  if V.length y == 0-         then mapFst (SV . (x:) . chunks) (span p (SV xs))-         else (SV [y], SV (z:xs))--}----- * other functions---{-# INLINE filter #-}-filter :: (Storable a) => (a -> Bool) -> Vector a -> Vector a-filter p =-   SV . List.filter (not . V.null) . List.map (V.filter p) . chunks---{- |-Generates laziness breaks-wherever one of the input signals has a chunk boundary.--}-{-# INLINE zipWith #-}-zipWith :: (Storable a, Storable b, Storable c) =>-      (a -> b -> c)-   -> Vector a-   -> Vector b-   -> Vector c-zipWith f as0 bs0 =-   let recourse at@(a:_) bt@(b:_) =-          let z = V.zipWith f a b-              n = V.length z-          in  z : recourse-                     (chunks $ drop n $ fromChunks at)-                     (chunks $ drop n $ fromChunks bt)-       recourse _ _ = []-   in  fromChunks $ recourse (chunks as0) (chunks bs0)--{-# INLINE zipWith3 #-}-zipWith3 :: (Storable a, Storable b, Storable c, Storable d) =>-      (a -> b -> c -> d)-   -> Vector a-   -> Vector b-   -> Vector c-   -> Vector d-zipWith3 f as0 bs0 cs0 =-   let recourse at@(a:_) bt@(b:_) ct@(c:_) =-          let z = V.zipWith3 f a b c-              n = V.length z-          in  z : recourse-                     (chunks $ drop n $ fromChunks at)-                     (chunks $ drop n $ fromChunks bt)-                     (chunks $ drop n $ fromChunks ct)-       recourse _ _ _ = []-   in  fromChunks $ recourse (chunks as0) (chunks bs0) (chunks cs0)--{-# INLINE zipWith4 #-}-zipWith4 :: (Storable a, Storable b, Storable c, Storable d, Storable e) =>-      (a -> b -> c -> d -> e)-   -> Vector a-   -> Vector b-   -> Vector c-   -> Vector d-   -> Vector e-zipWith4 f as0 bs0 cs0 ds0 =-   let recourse at@(a:_) bt@(b:_) ct@(c:_) dt@(d:_) =-          let z = V.zipWith4 f a b c d-              n = V.length z-          in  z : recourse-                     (chunks $ drop n $ fromChunks at)-                     (chunks $ drop n $ fromChunks bt)-                     (chunks $ drop n $ fromChunks ct)-                     (chunks $ drop n $ fromChunks dt)-       recourse _ _ _ _ = []-   in  fromChunks $-       recourse (chunks as0) (chunks bs0) (chunks cs0) (chunks ds0)---{- |-Preserves chunk pattern of the last argument.--}-{-# INLINE zipWithLastPattern #-}-zipWithLastPattern :: (Storable a, Storable b, Storable c) =>-      (a -> b -> c)-   -> Vector a-   -> Vector b-   -> Vector c-zipWithLastPattern f =-   crochetL (\y -> liftM (mapFst (flip f y)) . Ptr.viewL)-    . pointer--{- |-Preserves chunk pattern of the last argument.--}-{-# INLINE zipWithLastPattern3 #-}-zipWithLastPattern3 ::-   (Storable a, Storable b, Storable c, Storable d) =>-   (a -> b -> c -> d) ->-   (Vector a -> Vector b -> Vector c -> Vector d)-zipWithLastPattern3 f s0 s1 =-   crochetL (\z (xt,yt) ->-      liftM2-         (\(x,xs) (y,ys) -> (f x y z, (xs,ys)))-         (Ptr.viewL xt)-         (Ptr.viewL yt))-      (pointer s0, pointer s1)--{- |-Preserves chunk pattern of the last argument.--}-{-# INLINE zipWithLastPattern4 #-}-zipWithLastPattern4 ::-   (Storable a, Storable b, Storable c, Storable d, Storable e) =>-   (a -> b -> c -> d -> e) ->-   (Vector a -> Vector b -> Vector c -> Vector d -> Vector e)-zipWithLastPattern4 f s0 s1 s2 =-   crochetL (\w (xt,yt,zt) ->-      liftM3-         (\(x,xs) (y,ys) (z,zs) -> (f x y z w, (xs,ys,zs)))-         (Ptr.viewL xt)-         (Ptr.viewL yt)-         (Ptr.viewL zt))-      (pointer s0, pointer s1, pointer s2)---{-# INLINE zipWithSize #-}-zipWithSize :: (Storable a, Storable b, Storable c) =>-      ChunkSize-   -> (a -> b -> c)-   -> Vector a-   -> Vector b-   -> Vector c-zipWithSize size f s0 s1 =-   unfoldr size (\(xt,yt) ->-      liftM2-         (\(x,xs) (y,ys) -> (f x y, (xs,ys)))-         (Ptr.viewL xt)-         (Ptr.viewL yt))-      (pointer s0, pointer s1)--{-# INLINE zipWithSize3 #-}-zipWithSize3 ::-   (Storable a, Storable b, Storable c, Storable d) =>-   ChunkSize -> (a -> b -> c -> d) ->-   (Vector a -> Vector b -> Vector c -> Vector d)-zipWithSize3 size f s0 s1 s2 =-   unfoldr size (\(xt,yt,zt) ->-      liftM3-         (\(x,xs) (y,ys) (z,zs) ->-             (f x y z, (xs,ys,zs)))-         (Ptr.viewL xt)-         (Ptr.viewL yt)-         (Ptr.viewL zt))-      (pointer s0, pointer s1, pointer s2)--{-# INLINE zipWithSize4 #-}-zipWithSize4 ::-   (Storable a, Storable b, Storable c, Storable d, Storable e) =>-   ChunkSize -> (a -> b -> c -> d -> e) ->-   (Vector a -> Vector b -> Vector c -> Vector d -> Vector e)-zipWithSize4 size f s0 s1 s2 s3 =-   unfoldr size (\(xt,yt,zt,wt) ->-      liftM4-         (\(x,xs) (y,ys) (z,zs) (w,ws) ->-             (f x y z w, (xs,ys,zs,ws)))-         (Ptr.viewL xt)-         (Ptr.viewL yt)-         (Ptr.viewL zt)-         (Ptr.viewL wt))-      (pointer s0, pointer s1, pointer s2, pointer s3)----- * interleaved vectors--{-# INLINE sieve #-}-sieve :: (Storable a) => Int -> Vector a -> Vector a-sieve n =-   fromChunks . List.filter (not . V.null) . snd .-   List.mapAccumL-      (\offset chunk ->-         (mod (offset - V.length chunk) n,-          V.sieve n $ V.drop offset chunk)) 0 .-   chunks--{-# INLINE deinterleave #-}-deinterleave :: (Storable a) => Int -> Vector a -> [Vector a]-deinterleave n =-   P.map (sieve n) . P.take n . P.iterate (switchL empty (flip const))--{- |-Interleave lazy vectors-while maintaining the chunk pattern of the first vector.-All input vectors must have the same length.--}-{-# INLINE interleaveFirstPattern #-}-interleaveFirstPattern :: (Storable a) => [Vector a] -> Vector a-interleaveFirstPattern [] = empty-interleaveFirstPattern vss@(vs:_) =-   let pattern = List.map V.length $ chunks vs-       split xs =-          snd $-          List.mapAccumL-             (\x n -> swap $ mapFst (V.concat . chunks) $ splitAt n x)-             xs pattern-   in  fromChunks $ List.map V.interleave $-       List.transpose $ List.map split vss--{--interleaveFirstPattern vss@(vs:_) =-   fromChunks . snd .-   List.mapAccumL-      (\xss n ->-         swap $-         mapFst (V.interleave . List.map (V.concat . chunks)) $-         List.unzip $ List.map (splitAt n) xss)-      vss .-   List.map V.length . chunks $ vs--}----{- |-Ensure a minimal length of the list by appending pad values.--}-{- disabled INLINE pad -}-pad :: (Storable a) => ChunkSize -> a -> Int -> Vector a -> Vector a-pad size y n0 =-   let recourse n xt =-          if n<=0-            then xt-            else-              case xt of-                 [] -> chunks $ replicate size n y-                 x:xs -> x : recourse (n - V.length x) xs-   in  SV . recourse n0 . chunks--padAlt :: (Storable a) => ChunkSize -> a -> Int -> Vector a -> Vector a-padAlt size x n xs =-   append xs-      (let m = length xs-       in  if n>m-             then replicate size (n-m) x-             else empty)-------- * Helper functions for StorableVector---{-# INLINE cancelNullVector #-}-cancelNullVector :: (V.Vector a, b) -> Maybe (V.Vector a, b)-cancelNullVector y =-   toMaybe (not (V.null (fst y))) y---- if the chunk has length zero, an empty sequence is generated-{-# INLINE fromChunk #-}-fromChunk :: (Storable a) => V.Vector a -> Vector a-fromChunk x =-   if V.null x-     then empty-     else SV [x]----{--reduceLVector :: Storable x =>-   (x -> acc -> Maybe acc) -> acc -> Vector x -> (acc, Bool)-reduceLVector f acc0 x =-   let recourse i acc =-          if i < V.length x-            then (acc, True)-            else-               maybe-                  (acc, False)-                  (recourse (succ i))-                  (f (V.index x i) acc)-   in  recourse 0 acc0-----{- * Fundamental functions -}--{--Usage of 'unfoldr' seems to be clumsy but that covers all cases,-like different block sizes in source and destination list.--}-crochetLSize :: (Storable x, Storable y) =>-      ChunkSize-   -> (x -> acc -> Maybe (y, acc))-   -> acc-   -> T x-   -> T y-crochetLSize size f =-   curry (unfoldr size (\(acc,xt) ->-      do (x,xs) <- viewL xt-         (y,acc') <- f x acc-         return (y, (acc',xs))))--crochetListL :: (Storable y) =>-      ChunkSize-   -> (x -> acc -> Maybe (y, acc))-   -> acc-   -> [x]-   -> T y-crochetListL size f =-   curry (unfoldr size (\(acc,xt) ->-      do (x,xs) <- ListHT.viewL xt-         (y,acc') <- f x acc-         return (y, (acc',xs))))----{-# NOINLINE [0] crochetFusionListL #-}-crochetFusionListL :: (Storable y) =>-      ChunkSize-   -> (x -> acc -> Maybe (y, acc))-   -> acc-   -> FList.T x-   -> T y-crochetFusionListL size f =-   curry (unfoldr size (\(acc,xt) ->-      do (x,xs) <- FList.viewL xt-         (y,acc') <- f x acc-         return (y, (acc',xs))))---{-# INLINE [0] reduceL #-}-reduceL :: Storable x =>-   (x -> acc -> Maybe acc) -> acc -> Vector x -> acc-reduceL f acc0 =-   let recourse acc xt =-          case xt of-             [] -> acc-             (x:xs) ->-                 let (acc',continue) = reduceLVector f acc x-                 in  if continue-                       then recourse acc' xs-                       else acc'-   in  recourse acc0 . chunks----{- * Basic functions -}---{-# RULEZ-  "Storable.append/repeat/repeat" forall size x.-      append (repeat size x) (repeat size x) = repeat size x ;--  "Storable.append/repeat/replicate" forall size n x.-      append (repeat size x) (replicate size n x) = repeat size x ;--  "Storable.append/replicate/repeat" forall size n x.-      append (replicate size n x) (repeat size x) = repeat size x ;--  "Storable.append/replicate/replicate" forall size n m x.-      append (replicate size n x) (replicate size m x) =-         replicate size (n+m) x ;--  "Storable.mix/repeat/repeat" forall size x y.-      mix (repeat size x) (repeat size y) = repeat size (x+y) ;--  #-}--{-# RULES-  "Storable.length/cons" forall x xs.-      length (cons x xs) = 1 + length xs ;--  "Storable.length/map" forall f xs.-      length (map f xs) = length xs ;--  "Storable.map/cons" forall f x xs.-      map f (cons x xs) = cons (f x) (map f xs) ;--  "Storable.map/repeat" forall size f x.-      map f (repeat size x) = repeat size (f x) ;--  "Storable.map/replicate" forall size f x n.-      map f (replicate size n x) = replicate size n (f x) ;--  "Storable.map/repeat" forall size f x.-      map f (repeat size x) = repeat size (f x) ;--  {--  This can make things worse, if 'map' is applied to replicate,-  since this can use of sharing.-  It can also destroy the more important map/unfoldr fusion in-    take n . map f . unfoldr g--  "Storable.take/map" forall n f x.-      take n (map f x) = map f (take n x) ;-  -}--  "Storable.take/repeat" forall size n x.-      take n (repeat size x) = replicate size n x ;--  "Storable.take/take" forall n m xs.-      take n (take m xs) = take (min n m) xs ;--  "Storable.drop/drop" forall n m xs.-      drop n (drop m xs) = drop (n+m) xs ;--  "Storable.drop/take" forall n m xs.-      drop n (take m xs) = take (max 0 (m-n)) (drop n xs) ;--  "Storable.map/mapAccumL/snd" forall g f acc0 xs.-      map g (snd (mapAccumL f acc0 xs)) =-         snd (mapAccumL (\acc a -> mapSnd g (f acc a)) acc0 xs) ;--  #-}--{- GHC says this is an orphaned rule-  "Storable.map/mapAccumL/mapSnd" forall g f acc0 xs.-      mapSnd (map g) (mapAccumL f acc0 xs) =-         mapAccumL (\acc a -> mapSnd g (f acc a)) acc0 xs ;--}---{- * Fusable functions -}--scanLCrochet :: (Storable a, Storable b) =>-   (a -> b -> a) -> a -> Vector b -> Vector a-scanLCrochet f start =-   cons start .-   crochetL (\x acc -> let y = f acc x in Just (y, y)) start--{-# INLINE mapCrochet #-}-mapCrochet :: (Storable a, Storable b) => (a -> b) -> (Vector a -> Vector b)-mapCrochet f = crochetL (\x _ -> Just (f x, ())) ()--{-# INLINE takeCrochet #-}-takeCrochet :: Storable a => Int -> Vector a -> Vector a-takeCrochet = crochetL (\x n -> toMaybe (n>0) (x, pred n))--{-# INLINE repeatUnfoldr #-}-repeatUnfoldr :: Storable a => ChunkSize -> a -> Vector a-repeatUnfoldr size = iterate size id--{-# INLINE replicateCrochet #-}-replicateCrochet :: Storable a => ChunkSize -> Int -> a -> Vector a-replicateCrochet size n = takeCrochet n . repeat size-----{--The "fromList/drop" rule is not quite accurate-because the chunk borders are moved.-Maybe 'ChunkSize' better is a list of chunks sizes.--}--{-# RULEZ-  "fromList/zipWith"-    forall size f (as :: Storable a => [a]) (bs :: Storable a => [a]).-     fromList size (List.zipWith f as bs) =-        zipWith size f (fromList size as) (fromList size bs) ;--  "fromList/drop" forall as n size.-     fromList size (List.drop n as) =-        drop n (fromList size as) ;-  #-}----{- * Fused functions -}--type Unfoldr s a = (s -> Maybe (a,s), s)--{-# INLINE zipWithUnfoldr2 #-}-zipWithUnfoldr2 :: Storable z =>-      ChunkSize-   -> (x -> y -> z)-   -> Unfoldr a x-   -> Unfoldr b y-   -> T z-zipWithUnfoldr2 size h (f,a) (g,b) =-   unfoldr size-      (\(a0,b0) -> liftM2 (\(x,a1) (y,b1) -> (h x y, (a1,b1))) (f a0) (g b0))---      (uncurry (liftM2 (\(x,a1) (y,b1) -> (h x y, (a1,b1)))) . (f *** g))-      (a,b)--{- done by takeCrochet-{-# INLINE mapUnfoldr #-}-mapUnfoldr :: (Storable x, Storable y) =>-      ChunkSize-   -> (x -> y)-   -> Unfoldr a x-   -> T y-mapUnfoldr size g (f,a) =-   unfoldr size (fmap (mapFst g) . f) a--}--{-# INLINE dropUnfoldr #-}-dropUnfoldr :: Storable x =>-      ChunkSize-   -> Int-   -> Unfoldr a x-   -> T x-dropUnfoldr size n (f,a0) =-   maybe-      empty-      (unfoldr size f)-      (nest n (\a -> fmap snd . f =<< a) (Just a0))---{- done by takeCrochet-{-# INLINE takeUnfoldr #-}-takeUnfoldr :: Storable x =>-      ChunkSize-   -> Int-   -> Unfoldr a x-   -> T x-takeUnfoldr size n0 (f,a0) =-   unfoldr size-      (\(a,n) ->-         do guard (n>0)-            (x,a') <- f a-            return (x, (a', pred n)))-      (a0,n0)--}---lengthUnfoldr :: Storable x =>-      Unfoldr a x-   -> Int-lengthUnfoldr (f,a0) =-   let recourse n a =-          maybe n (recourse (succ n) . snd) (f a)-   in  recourse 0 a0---{-# INLINE zipWithUnfoldr #-}-zipWithUnfoldr ::-   (Storable b, Storable c) =>-      (acc -> Maybe (a, acc))-   -> (a -> b -> c)-   -> acc-   -> T b -> T c-zipWithUnfoldr f h a y =-   crochetL (\y0 a0 ->-       do (x0,a1) <- f a0-          Just (h x0 y0, a1)) a y--{-# INLINE zipWithCrochetL #-}-zipWithCrochetL ::-   (Storable x, Storable b, Storable c) =>-      ChunkSize-   -> (x -> acc -> Maybe (a, acc))-   -> (a -> b -> c)-   -> acc-   -> T x -> T b -> T c-zipWithCrochetL size f h a x y =-   crochetL (\(x0,y0) a0 ->-       do (z0,a1) <- f x0 a0-          Just (h z0 y0, a1))-      a (zip size x y)---{-# INLINE crochetLCons #-}-crochetLCons ::-   (Storable a, Storable b) =>-      (a -> acc -> Maybe (b, acc))-   -> acc-   -> a -> T a -> T b-crochetLCons f a0 x xs =-   maybe-      empty-      (\(y,a1) -> cons y (crochetL f a1 xs))-      (f x a0)--{-# INLINE reduceLCons #-}-reduceLCons ::-   (Storable a) =>-      (a -> acc -> Maybe acc)-   -> acc-   -> a -> T a -> acc-reduceLCons f a0 x xs =-   maybe a0 (flip (reduceL f) xs) (f x a0)------{-# RULES-  "Storable.zipWith/share" forall size (h :: a->a->b) (x :: T a).-     zipWith size h x x = map (\xi -> h xi xi) x ;----  "Storable.map/zipWith" forall size (f::c->d) (g::a->b->c) (x::T a) (y::T b).-  "Storable.map/zipWith" forall size f g x y.-     map f (zipWith size g x y) =-        zipWith size (\xi yi -> f (g xi yi)) x y ;--  -- this rule lets map run on a different block structure-  "Storable.zipWith/map,*" forall size f g x y.-     zipWith size g (map f x) y =-        zipWith size (\xi yi -> g (f xi) yi) x y ;--  "Storable.zipWith/*,map" forall size f g x y.-     zipWith size g x (map f y) =-        zipWith size (\xi yi -> g xi (f yi)) x y ;---  "Storable.drop/unfoldr" forall size f a n.-     drop n (unfoldr size f a) =-        dropUnfoldr size n (f,a) ;--  "Storable.take/unfoldr" forall size f a n.-     take n (unfoldr size f a) =---        takeUnfoldr size n (f,a) ;-        takeCrochet n (unfoldr size f a) ;--  "Storable.length/unfoldr" forall size f a.-     length (unfoldr size f a) = lengthUnfoldr (f,a) ;--  "Storable.map/unfoldr" forall size g f a.-     map g (unfoldr size f a) =---        mapUnfoldr size g (f,a) ;-        mapCrochet g (unfoldr size f a) ;--  "Storable.map/iterate" forall size g f a.-     map g (iterate size f a) =-        mapCrochet g (iterate size f a) ;--{--  "Storable.zipWith/unfoldr,unfoldr" forall sizeA sizeB f g h a b n.-     zipWith n h (unfoldr sizeA f a) (unfoldr sizeB g b) =-        zipWithUnfoldr2 n h (f,a) (g,b) ;--}--  -- block boundaries are changed here, so it changes lazy behaviour-  "Storable.zipWith/unfoldr,*" forall sizeA sizeB f h a y.-     zipWith sizeA h (unfoldr sizeB f a) y =-        zipWithUnfoldr f h a y ;--  -- block boundaries are changed here, so it changes lazy behaviour-  "Storable.zipWith/*,unfoldr" forall sizeA sizeB f h a y.-     zipWith sizeA h y (unfoldr sizeB f a) =-        zipWithUnfoldr f (flip h) a y ;--  "Storable.crochetL/unfoldr" forall size f g a b.-     crochetL g b (unfoldr size f a) =-        unfoldr size (\(a0,b0) ->-            do (y0,a1) <- f a0-               (z0,b1) <- g y0 b0-               Just (z0, (a1,b1))) (a,b) ;--  "Storable.reduceL/unfoldr" forall size f g a b.-     reduceL g b (unfoldr size f a) =-        snd-          (FList.recourse (\(a0,b0) ->-              do (y,a1) <- f a0-                 b1 <- g y b0-                 Just (a1, b1)) (a,b)) ;--  "Storable.crochetL/cons" forall g b x xs.-     crochetL g b (cons x xs) =-        crochetLCons g b x xs ;--  "Storable.reduceL/cons" forall g b x xs.-     reduceL g b (cons x xs) =-        reduceLCons g b x xs ;-----  "Storable.take/crochetL" forall f a x n.-     take n (crochetL f a x) =-        takeCrochet n (crochetL f a x) ;--  "Storable.length/crochetL" forall f a x.-     length (crochetL f a x) = length x ;--  "Storable.map/crochetL" forall g f a x.-     map g (crochetL f a x) =-        mapCrochet g (crochetL f a x) ;--  "Storable.zipWith/crochetL,*" forall size f h a x y.-     zipWith size h (crochetL f a x) y =-        zipWithCrochetL size f h a x y ;--  "Storable.zipWith/*,crochetL" forall size f h a x y.-     zipWith size h y (crochetL f a x) =-        zipWithCrochetL size f (flip h) a x y ;--  "Storable.crochetL/crochetL" forall f g a b x.-     crochetL g b (crochetL f a x) =-        crochetL (\x0 (a0,b0) ->-            do (y0,a1) <- f x0 a0-               (z0,b1) <- g y0 b0-               Just (z0, (a1,b1))) (a,b) x ;--  "Storable.reduceL/crochetL" forall f g a b x.-     reduceL g b (crochetL f a x) =-        snd-          (reduceL (\x0 (a0,b0) ->-              do (y,a1) <- f x0 a0-                 b1 <- g y b0-                 Just (a1, b1)) (a,b) x) ;-  #-}---}--{- * IO -}--{- |-Read the rest of a file lazily and-provide the reason of termination as IOError.-If IOError is EOF (check with @System.Error.isEOFError err@),-then the file was read successfully.-Only access the final IOError after you have consumed the file contents,-since finding out the terminating reason forces to read the entire file.-Make also sure you read the file completely,-because it is only closed when the file end is reached-(or an exception is encountered).--TODO:-In ByteString.Lazy the chunk size is reduced-if data is not immediately available.-Maybe we should adapt that behaviour-but when working with realtime streams-that may mean that the chunks are very small.--}-hGetContentsAsync :: Storable a =>-   ChunkSize -> Handle -> IO (IOError, Vector a)-hGetContentsAsync (ChunkSize size) h =-   let go =-          Unsafe.interleaveIO $-          flip catch (\err -> return (err,[])) $-          do v <- V.hGet h size-             if V.null v-               then hClose h >>-                    return (Exc.mkIOError Exc.eofErrorType-                      "StorableVector.Lazy.hGetContentsAsync" (Just h) Nothing, [])-               else fmap (mapSnd (v:)) go-{--          Unsafe.interleaveIO $-          flip catch (\err -> return (err,[])) $-          liftM2 (\ chunk ~(err,rest) -> (err,chunk:rest))-             (V.hGet h size) go--}-   in  fmap (mapSnd SV) go--hGetContentsSync :: Storable a =>-   ChunkSize -> Handle -> IO (Vector a)-hGetContentsSync (ChunkSize size) h =-   let go =-          do v <- V.hGet h size-             if V.null v-               then return []-               else fmap (v:) go-   in  fmap SV go--hPut :: Storable a => Handle -> Vector a -> IO ()-hPut h = mapM_ (V.hPut h) . chunks--{--*Data.StorableVector.Lazy> print . mapSnd (length :: Vector Data.Int.Int16 -> Int) =<< readFileAsync (ChunkSize 1000) "dist/build/libHSstorablevector-0.1.3.a"-(dist/build/libHSstorablevector-0.1.3.a: hGetBuf: illegal operation (handle is closed),0)--}-{- |-The file can only closed after all values are consumed.-That is you must always assert that you consume all elements of the stream,-and that no values are missed due to lazy evaluation.-This requirement makes this function useless in many applications.--}-readFileAsync :: Storable a => ChunkSize -> FilePath -> IO (IOError, Vector a)-readFileAsync size path =-   openBinaryFile path ReadMode >>= hGetContentsAsync size--writeFile :: Storable a => FilePath -> Vector a -> IO ()-writeFile path =-   bracket (openBinaryFile path WriteMode) hClose . flip hPut--appendFile :: Storable a => FilePath -> Vector a -> IO ()-appendFile path =-   bracket (openBinaryFile path AppendMode) hClose . flip hPut---{-# NOINLINE moduleError #-}-moduleError :: String -> String -> a-moduleError fun msg =-   error ("Data.StorableVector.Lazy." List.++ fun List.++ ':':' ':msg)
− Data/StorableVector/Lazy/Builder.hs 
@@ -1,159 +0,0 @@-{-# LANGUAGE Rank2Types #-}-{- |-Build a lazy storable vector by incrementally adding an element.-This is analogous to Data.Binary.Builder for Data.ByteString.Lazy.--Attention:-This implementation is still almost 3 times slower-than constructing a lazy storable vector using unfoldr-in our Chorus speed test.--}-module Data.StorableVector.Lazy.Builder (-   Builder,-   toLazyStorableVector,-   put,-   flush,-   ) where--import qualified Data.StorableVector as SV-import qualified Data.StorableVector.Lazy as SVL-import qualified Data.StorableVector.ST.Strict as STV--- import qualified Data.StorableVector.ST.Lazy as STVL--import Data.StorableVector.Lazy (ChunkSize, )-import Control.Monad (liftM2, )-import Control.Monad.ST.Strict (ST, runST, )-import Data.Monoid (Monoid(mempty, mappend), )--import Foreign.Storable (Storable, )--import qualified System.Unsafe as Unsafe---{--Given an initial buffer and a function that generates the rest of the vector,-a 'Builder' generates the whole vector.-The idea is inspired by Data.Binary.Builder.--We use the strict ST monad by default-and only rare 'Unsafe.interleaveST',-since this is more efficient than using lazy ST everywhere.--Before that approach I tried to achieve this with a lazy State monad.-I found this more comprehensible but it was very slow-and had a space leak, when the last chunk shall be handled correctly.--}-newtype Builder a =-   Builder {run :: forall s.-      ChunkSize ->-      (Buffer s a -> ST s [SV.Vector a]) ->-      (Buffer s a -> ST s [SV.Vector a])-   }--type Buffer s a = (STV.Vector s a, Int)----- instance Monoid (Builder a) where-{--Storable constraint not needed in the current implementation,-but who knows what will be in future ...--}-instance Storable a => Monoid (Builder a) where-   {-# INLINE mempty #-}-   {-# INLINE mappend #-}-   mempty = Builder (\_ -> id)-   mappend x y = Builder (\cs -> run x cs . run y cs)---{- |-> toLazyStorableVector (ChunkSize 7) $ Data.Monoid.mconcat $ map put ['a'..'z']--}-{-# INLINE toLazyStorableVector #-}-toLazyStorableVector :: Storable a =>-   ChunkSize -> Builder a -> SVL.Vector a-toLazyStorableVector cs bld =-   SVL.fromChunks $-   runST (run bld cs (fmap (:[]) . fixVector) =<< newChunk cs)---{-# INLINE put #-}-put :: Storable a => a -> Builder a-put a =-   Builder (\cs cont (v0,i0) ->-      do STV.unsafeWrite v0 i0 a-         let i1 = succ i0-         if i1 < STV.length v0-           then-             cont (v0, i1)-           else-             liftM2 (:)-                -- we could call 'flush' here, but this requires an extra 'SV.take'-                (STV.unsafeFreeze v0)-                (Unsafe.interleaveST $-                 cont =<< newChunk cs)-   )--{--put :: Storable a => a -> Builder a-put a =-   Builder (\cs cont (v0,i0) ->-      if i0 < STV.length v0-        then-          do STV.write v0 i0 a-             cont (v0, succ i0)-        else-          liftM2 (:)-             -- we could call 'flush' here, but this requires an extra 'SV.take'-             (STV.unsafeFreeze v0)-             (Unsafe.interleaveST $-              do (v1,i1) <- newChunk cs-                 STV.write v1 i1 a-                 cont (v1, succ i1))-   )--}--{--          lazyToStrictST $-          liftM2 (:)-             -- we could call 'flush' here, but this requires an extra 'SV.take'-             (STVL.unsafeFreeze v0)-             (strictToLazyST $-              do (v1,i1) <- newChunk cs-                 STV.write v1 i1 a-                 cont (v1, succ i1))--}--{--Prelude Control.Monad.ST.Lazy> Control.Monad.ST.runST (lazyToStrictST $ Monad.liftM2 (,) (strictToLazyST $ return 'a') (strictToLazyST (undefined::Monad m => m Char)))-*** Exception: Prelude.undefined--}--{- |-Set a laziness break.--}-{-# INLINE flush #-}-flush :: Storable a => Builder a-flush =-   Builder (\cs cont vi0 ->-      liftM2 (:)-         (fixVector vi0)-         (Unsafe.interleaveST $ cont =<< newChunk cs)-{--      lazyToStrictST $-      liftM2 (:)-         (strictToLazyST $ fixVector vi0)-         (strictToLazyST $ cont =<< newChunk cs)--}-   )--{-# INLINE newChunk #-}-newChunk :: (Storable a) =>-   ChunkSize -> ST s (Buffer s a)-newChunk (SVL.ChunkSize size) =-   fmap (flip (,) 0) $ STV.new_ size--{-# INLINE fixVector #-}-fixVector :: (Storable a) =>-   Buffer s a -> ST s (SV.Vector a)-fixVector ~(v1,i1) =-   fmap (SV.take i1) $ STV.unsafeFreeze v1
− Data/StorableVector/Lazy/Pattern.hs 
@@ -1,371 +0,0 @@-{- |-Functions for 'StorableVector' that allow control of the size of individual chunks.--This is import for an application like the following:-You want to mix audio signals that are relatively shifted.-The structure of chunks of three streams may be illustrated as:--> [____] [____] [____] [____] ...->   [____] [____] [____] [____] ...->     [____] [____] [____] [____] ...--When we mix the streams (@zipWith3 (\x y z -> x+y+z)@)-with respect to the chunk structure of the first signal,-computing the first chunk requires full evaluation of all leading chunks of the stream.-However the last value of the third leading chunk-is much later in time than the last value of the first leading chunk.-We like to reduce these dependencies using a different chunk structure,-say--> [____] [____] [____] [____] ...->   [__] [____] [____] [____] ...->     [] [____] [____] [____] ...---}-module Data.StorableVector.Lazy.Pattern (-   Vector,-   ChunkSize,-   chunkSize,-   defaultChunkSize,-   LazySize,--   empty,-   singleton,-   pack,-   unpack,-   packWith,-   unpackWith,-   unfoldrN,-   iterateN,-   cycle,-   replicate,-   null,-   length,-   cons,-   append,-   concat,-   map,-   reverse,-   foldl,-   foldl',-   any,-   all,-   maximum,-   minimum,-   viewL,-   viewR,-   switchL,-   switchR,-   scanl,-   mapAccumL,-   mapAccumR,-   crochetL,-   take,-   drop,-   splitAt,-   takeVectorPattern,-   splitAtVectorPattern,-   dropMarginRem,-   dropMargin,-   dropWhile,-   takeWhile,-   span,-   filter,-   zipWith,-   zipWith3,-   zipWith4,-   zipWithSize,-   zipWithSize3,-   zipWithSize4,-{--   pad,-   cancelNullVector,--}-   ) where--import Numeric.NonNegative.Class ((-|))-import qualified Numeric.NonNegative.Chunky as LS-import qualified Data.StorableVector.Lazy as LSV-import qualified Data.StorableVector as V--import Data.StorableVector.Lazy (Vector(SV), ChunkSize(ChunkSize))--import Data.StorableVector.Lazy (-   chunkSize, defaultChunkSize,-   empty, singleton, unpack, unpackWith, cycle,-   null, cons, append, concat, map, reverse,-   foldl, foldl', any, all, maximum, minimum,-   viewL, viewR, switchL, switchR,-   scanl, mapAccumL, mapAccumR, crochetL,-   dropMarginRem, dropMargin,-   dropWhile, takeWhile, span, filter, -   zipWith, zipWith3, zipWith4, -   )--import qualified Data.List as List--import qualified Data.List.HT as ListHT-import Data.Tuple.HT (mapPair, mapFst, forcePair, swap, )--import Control.Monad (liftM2, liftM3, liftM4, guard, )--import Foreign.Storable (Storable)--import Prelude hiding-   (length, (++), iterate, foldl, map, repeat, replicate, null,-    zip, zipWith, zipWith3, drop, take, splitAt, takeWhile, dropWhile, reverse,-    any, all, concat, cycle, filter, maximum, minimum, scanl, span, )-{--import Data.Maybe (Maybe(Just, Nothing), )-import Prelude (Int, (.), ($), fst, snd, (<=), flip, curry, return, fmap, not, uncurry, )--}---type LazySize = LS.T ChunkSize---- * Introducing and eliminating 'Vector's--{--Actually, this is lazy enough:--> LSV.unpack $ pack (LS.fromChunks [10,15]) (['a'..'y'] List.++ Prelude.undefined)-"abcdefghijklmnopqrstuvwxy"--}-pack :: (Storable a) => LazySize -> [a] -> Vector a-pack size =-   fst . unfoldrN size ListHT.viewL---{-# INLINE packWith #-}-packWith :: (Storable b) => LazySize -> (a -> b) -> [a] -> Vector b-packWith size f =-   fst . unfoldrN size (fmap (mapFst f) . ListHT.viewL)---{--{-# INLINE unfoldrNAlt #-}-unfoldrNAlt :: (Storable b) =>-      LazySize-   -> (a -> Maybe (b,a))-   -> a-   -> (Vector b, Maybe a)-unfoldrNAlt (LS.Cons size) f x =-   let go sz y =-          case sz of-             [] -> ([], y)-             (ChunkSize s : ss) ->-                maybe-                   ([], Nothing)-                   ((\(c,a1) -> mapFst (c:) $ go ss a1) .-                    V.unfoldrN s (fmap (mapSnd f)))-                   (f y)-   in  mapFst SV $ go size (Just x)--}--{-# INLINE unfoldrN #-}-unfoldrN :: (Storable b) =>-      LazySize-   -> (a -> Maybe (b,a))-   -> a-   -> (Vector b, Maybe a)-unfoldrN size f =-   let go sz y =-          forcePair $-          case sz of-             [] -> ([], y)-             (ChunkSize s : ss) ->-                let m =-                       do a0 <- y-                          let p = V.unfoldrN s f a0-                          guard (not (V.null (fst p)))-                          return p-                in  case m of-                       Nothing -> ([], Nothing)-                       Just (c,a1) -> mapFst (c:) $ go ss a1-   in  mapFst SV . go (LS.toChunks size) . Just---{-# INLINE iterateN #-}-iterateN :: Storable a => LazySize -> (a -> a) -> a -> Vector a-iterateN size f =-   fst . unfoldrN size (\x -> Just (x, f x))--{--Tries to be time and memory efficient-by reusing subvectors of a chunk-until a larger chunk is needed.-However, it can be a memory leak-if a huge chunk is followed by many little ones.--}-replicate :: Storable a => LazySize -> a -> Vector a-replicate size x =-   SV $ snd $-   List.mapAccumL-      (\v (ChunkSize m) ->-         if m <= V.length v-           then (v, V.take m v)-           else let v1 = V.replicate m x-                in  (v1,v1))-      V.empty $-   LS.toChunks size--{--replicate :: Storable a => LazySize -> a -> Vector a-replicate size x =-   SV $ List.map (\(ChunkSize m) -> V.replicate m x) (LS.toChunks size)--}----- * Basic interface--length :: Vector a -> LazySize-length = LS.fromChunks . List.map chunkLength . LSV.chunks--chunkLength :: V.Vector a -> ChunkSize-chunkLength = ChunkSize . V.length--decrementLimit :: V.Vector a -> LazySize -> LazySize-decrementLimit x y =-   y -| LS.fromNumber (chunkLength x)--intFromChunkSize :: ChunkSize -> Int-intFromChunkSize (ChunkSize x) = x--intFromLazySize :: LazySize -> Int-intFromLazySize =-   List.sum . List.map intFromChunkSize . LS.toChunks------ * sub-vectors--{- |-Generates laziness breaks-wherever either the lazy length number or the vector has a chunk boundary.--}-{-# INLINE take #-}-take :: (Storable a) => LazySize -> Vector a -> Vector a-take n = fst . splitAt n--{- |-Preserves the chunk pattern of the lazy vector.--}-{-# INLINE takeVectorPattern #-}-takeVectorPattern :: (Storable a) => LazySize -> Vector a -> Vector a-takeVectorPattern _ (SV []) = empty-takeVectorPattern n (SV (x:xs)) =-   if List.null (LS.toChunks n)-     then empty-     else-       let remain = decrementLimit x n-       in  SV $ uncurry (:) $-           if LS.isNull remain-             then (V.take (intFromLazySize n) x, [])-             else-               (x, LSV.chunks $ take remain $ LSV.fromChunks xs)--{-# INLINE drop #-}-drop :: (Storable a) => LazySize -> Vector a -> Vector a-drop size xs =-   List.foldl (flip (LSV.drop . intFromChunkSize)) xs (LS.toChunks size)--{-# INLINE splitAt #-}-splitAt ::-   (Storable a) => LazySize -> Vector a -> (Vector a, Vector a)-splitAt size xs =-   mapFst LSV.concat $ swap $-   List.mapAccumL-      (\xs0 n ->-         swap $ LSV.splitAt (intFromChunkSize n) xs0)-      xs (LS.toChunks size)--{-# INLINE splitAtVectorPattern #-}-splitAtVectorPattern ::-   (Storable a) => LazySize -> Vector a -> (Vector a, Vector a)-splitAtVectorPattern n0 =-   forcePair .-   if List.null (LS.toChunks n0)-     then (,) empty-     else-       let recourse n xt =-              forcePair $-              case xt of-                 [] -> ([], [])-                 (x:xs) ->-                    let remain = decrementLimit x n-                    in  if LS.isNull remain-                          then mapPair ((:[]), (:xs)) $-                               V.splitAt (intFromLazySize n) x-                          else mapFst (x:) $ recourse remain xs-       in  mapPair (SV, SV) . recourse n0 . LSV.chunks---{-# INLINE [0] zipWithSize #-}-zipWithSize :: (Storable a, Storable b, Storable c) =>-      LazySize-   -> (a -> b -> c)-   -> Vector a-   -> Vector b-   -> Vector c-zipWithSize size f =-   curry (fst . unfoldrN size (\(xt,yt) ->-      liftM2-         (\(x,xs) (y,ys) -> (f x y, (xs,ys)))-         (viewL xt)-         (viewL yt)))--{-# INLINE zipWithSize3 #-}-zipWithSize3 ::-   (Storable a, Storable b, Storable c, Storable d) =>-   LazySize -> (a -> b -> c -> d) ->-   (Vector a -> Vector b -> Vector c -> Vector d)-zipWithSize3 size f s0 s1 s2 =-   fst $ unfoldrN size (\(xt,yt,zt) ->-      liftM3-         (\(x,xs) (y,ys) (z,zs) ->-             (f x y z, (xs,ys,zs)))-         (viewL xt)-         (viewL yt)-         (viewL zt))-      (s0,s1,s2)--{-# INLINE zipWithSize4 #-}-zipWithSize4 ::-   (Storable a, Storable b, Storable c, Storable d, Storable e) =>-   LazySize -> (a -> b -> c -> d -> e) ->-   (Vector a -> Vector b -> Vector c -> Vector d -> Vector e)-zipWithSize4 size f s0 s1 s2 s3 =-   fst $ unfoldrN size (\(xt,yt,zt,wt) ->-      liftM4-         (\(x,xs) (y,ys) (z,zs) (w,ws) ->-             (f x y z w, (xs,ys,zs,ws)))-         (viewL xt)-         (viewL yt)-         (viewL zt)-         (viewL wt))-      (s0,s1,s2,s3)--{--{- |-Ensure a minimal length of the list by appending pad values.--}-{-# ONLINE pad #-}-pad :: (Storable a) => ChunkSize -> a -> Int -> Vector a -> Vector a-pad size y n0 =-   let recourse n xt =-          if n<=0-            then xt-            else-              case xt of-                 [] -> chunks $ replicate size n y-                 x:xs -> x : recourse (n - V.length x) xs-   in  SV . recourse n0 . chunks--padAlt :: (Storable a) => ChunkSize -> a -> Int -> Vector a -> Vector a-padAlt size x n xs =-   append xs-      (let m = length xs-       in  if n>m-             then replicate size (n-m) x-             else empty)--}
− Data/StorableVector/Lazy/Pointer.hs 
@@ -1,20 +0,0 @@-{- |-In principle you can traverse through a lazy storable vector-using repeated calls to @viewL@.-However this needs a bit of pointer arrangement and allocation.-This data structure makes the inner loop faster,-that consists of traversing through a chunk.--}-module Data.StorableVector.Lazy.Pointer (-   Pointer, cons, viewL, switchL,-   ) where--import Data.StorableVector.Lazy.PointerPrivate (Pointer(..), viewL, switchL, )-import qualified Data.StorableVector.Lazy as VL--import Foreign.Storable (Storable)---{-# INLINE cons #-}-cons :: Storable a => VL.Vector a -> Pointer a-cons = VL.pointer
− Data/StorableVector/Lazy/PointerPrivate.hs 
@@ -1,42 +0,0 @@-module Data.StorableVector.Lazy.PointerPrivate where--import qualified Data.StorableVector.Pointer as VP-import qualified Data.StorableVector as V-import qualified Data.StorableVector.Base as VB--import Foreign.Storable (Storable)---data Pointer a =-   Pointer {-      chunks :: [VB.Vector a],-      ptr    :: {-# UNPACK #-} !(VP.Pointer a)-   }---empty :: Storable a => Pointer a-empty =-   Pointer [] (VP.cons V.empty)--{-# INLINE cons #-}-cons :: Storable a => [VB.Vector a] -> Pointer a-cons [] = empty-cons (c:cs) = Pointer cs (VP.cons c)--{-# INLINE viewL #-}-viewL :: Storable a => Pointer a -> Maybe (a, Pointer a)-viewL = switchL Nothing (curry Just)--{-# INLINE switchL #-}-switchL :: Storable a =>-   b -> (a -> Pointer a -> b) -> Pointer a -> b-switchL n j =-   let recourse p =-          let ct = chunks p-          in  VP.switchL-                 (case ct of-                    [] -> n-                    (c:cs) -> recourse (Pointer cs (VP.cons c)))-                 (\a cp -> j a (Pointer ct cp))-                 (ptr p)-   in  recourse
− Data/StorableVector/Lazy/PointerPrivateIndex.hs 
@@ -1,38 +0,0 @@-{--Alternative to PointerPrivate implemented at a higher level.--}-module Data.StorableVector.Lazy.PointerPrivateIndex where--import qualified Data.StorableVector as V-import qualified Data.StorableVector.Base as VB--import Foreign.Storable (Storable)---data Pointer a =-   Pointer {chunks :: ![VB.Vector a], index :: !Int}---{-# INLINE cons #-}-cons :: Storable a => [VB.Vector a] -> Pointer a-cons = flip Pointer 0--{-# INLINE viewL #-}-viewL :: Storable a => Pointer a -> Maybe (a, Pointer a)-viewL = switchL Nothing (curry Just)--{-# INLINE switchL #-}-switchL :: Storable a =>-   b -> (a -> Pointer a -> b) -> Pointer a -> b-switchL n j =-   let recourse p =-          let s = chunks p-          in  case s of-                 [] -> n-                 (c:cs) ->-                    let i = index p-                        d = i - V.length c-                    in  if d < 0-                          then j (VB.unsafeIndex c i) (Pointer s (i+1))-                          else recourse (Pointer cs d)-   in  recourse
− Data/StorableVector/Pointer.hs 
@@ -1,52 +0,0 @@-{- |-In principle you can traverse through a storable vector-using repeated calls to @viewL@ or using @index@.-However this needs a bit of pointer arrangement and allocation.-This data structure should make loops optimally fast.--}-module Data.StorableVector.Pointer where---- import qualified Data.StorableVector as V-import qualified Data.StorableVector.Base as VB--import qualified Foreign.ForeignPtr as FPtr-import Foreign.Marshal.Array (advancePtr, )-import Foreign.Storable (Storable, peek, )-import Foreign (Ptr, )-import qualified System.Unsafe as Unsafe---{--The reference to the ForeignPtr asserts,-that the array is maintained and thus is not garbage collected.-The Ptr we use for traversing would not achieve this.--}-{- |-We might have name the data type iterator.--}-data Pointer a =-   Pointer {-      fptr :: {-# UNPACK #-} !(FPtr.ForeignPtr a),-      ptr  :: {-# UNPACK #-} !(Ptr a),-      left :: {-# UNPACK #-} !Int-   }---{-# INLINE cons #-}-cons :: Storable a => VB.Vector a -> Pointer a-cons (VB.SV fp s l) =-   Pointer fp (advancePtr (Unsafe.foreignPtrToPtr fp) s) l---{-# INLINE viewL #-}-viewL :: Storable a => Pointer a -> Maybe (a, Pointer a)-viewL = switchL Nothing (curry Just)--{-# INLINE switchL #-}-switchL :: Storable a =>-   b -> (a -> Pointer a -> b) -> Pointer a -> b-switchL n j (Pointer fp p l) =-   if l<=0-     then n-     else j (VB.inlinePerformIO (peek p)) (Pointer fp (advancePtr p 1) (l-1))--- Unsafe.performIO at this place would make SpeedPointer test 0.5 s slower
− Data/StorableVector/Private.hs 
@@ -1,151 +0,0 @@-{- |-Functions that may be useful, but I'm uncertain.--}-module Data.StorableVector.Private where---import Data.StorableVector (empty, unfoldrN, viewL, length, )-import Data.StorableVector.Base--import qualified Data.Strictness.HT as Strict--import Foreign.Storable         (Storable(..))--import qualified System.Unsafe as Unsafe--import Control.DeepSeq (NFData, rnf, deepseq, )--import Prelude hiding (length, )----{- |-This implementation is based on viewL-and thus not as fast as possible.--}-zipWithViewL :: (Storable a, Storable b, Storable c) =>-   (a -> b -> c) -> Vector a -> Vector b -> Vector c-zipWithViewL f ps0 qs0 =-   fst $ unfoldrN-      (min (length ps0) (length qs0))-      (\(ps,qs) ->-         do (ph,pt) <- viewL ps-            (qh,qt) <- viewL qs-            return (f ph qh, (pt,qt)))-      (ps0,qs0)---zipWithIndex :: (Storable a, Storable b, Storable c) =>-   (a -> b -> c) -> Vector a -> Vector b -> Vector c-zipWithIndex f ps qs =-   fst $ unfoldrN-      (min (length ps) (length qs))-      (\i -> Just (f (unsafeIndex ps i) (unsafeIndex qs i), succ i))-      0---unfoldrStrictN :: (Storable b, NFData a) => Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a)--- unfoldrStrictN :: (Storable b) => Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a)-unfoldrStrictN i f x0 =-   if i <= 0-     then (empty, Just x0)-     else Unsafe.performIO $ createAndTrim' i $ \p -> go p 0 x0-       {--       go must not be strict in the accumulator-       since otherwise packN would be too strict.-       -}-       where-          go = Strict.arguments3 $ \p n -> \x ->-             if n == i-               then return (0, n, Just x)-               else-                 case f x of-                   Nothing     -> return (0, n, Nothing)-                   Just (w,x') -> do poke p w---                                     go (incPtr p) (n+1) $! x'-                                     go (incPtr p) (n+1) (x' `deepseq` x')---                                     seq (rnf x') (((go $! incPtr p) $! n+1) $! x')-{-# INLINE unfoldrStrictN #-}--unfoldrTransitionN :: (Storable b) => Int -> (a -> a) -> (a -> Maybe b) -> a -> (Vector b, a)-unfoldrTransitionN n trans emit x =-   if n <= 0-     then (empty, x)-     else Unsafe.performIO $ createAndTrim' n $ \p ->-       case emit x of-         Nothing -> return (0, n, x)-         Just y0 -> poke p y0 >>-           {--           go must not be strict in the accumulator-           since otherwise packN would be too strict.-           -}-           let go = Strict.arguments2 $ \p0 i0 -> \x0 ->-                  {--                  We run 'emit' in order to evaluate the new state.-                  We need to return this new state-                  also in case the array is full.-                  The drawback is, that the whole vector becomes undefined-                  if only the state after the last element is undefined.-                  This is the same situation as in an unfoldr with strict state.-                  -}-                  let i1 = i0-1-                      x1 = trans x0-                  in  case emit x1 of-                         Nothing -> return (0, n-i1, x1)-                         Just y1 ->-                            if i1 == 0-                              then return (0, n, x1)-                              else-                                let p1 = incPtr p0-                                in  do poke p1 y1-                                       go p1 i1 x1-{--                  let i1 = i0-1-                  in  if i1 == 0-                        then return (0, n, x0)-                        else-                          let x1 = trans x0-                              p1 = incPtr p0-                          in  case emit x1 of-                                Nothing -> return (0, n-i1, x1)-                                Just y1 -> do poke p1 y1-                                              go p1 i1 x1--}-           in  go p n x-{-# INLINE unfoldrTransitionN #-}---- | /O(n)/ Like 'unfoldrN' this function builds a 'Vector' from a seed--- value.  However, it does always return a state value.--- The vector construction can be aborted either by reaching--- the given maximum size or by returning 'Nothing' as element.------ The following equation relates 'unfoldrN' and 'unfoldrStateN':------ > unfoldrN n f s ==--- >    unfoldrStateN n--- >       (maybe (error "state will be always Just")--- >           ((\a -> (fmap fst a, fmap snd a)) . f))--- >       (Just s)------ It is not possible to express 'unfoldrNState' in terms of 'unfoldrN'.----unfoldrStateN :: (Storable b) => Int -> (a -> (Maybe b, a)) -> a -> (Vector b, a)-unfoldrStateN i f x0 =-   if i <= 0-     then (empty, x0)-     else Unsafe.performIO $ createAndTrim' i $ \p -> go p 0 x0-       {--       go must not be strict in the accumulator-       since otherwise packN would be too strict.-       -}-       where-          go = Strict.arguments2 $ \p n -> \x ->-             if n == i-               then return (0, n, x)-               else-                 let (my,x') = f x-                 in  case my of-                       Nothing -> return (0, n, x)-                       Just w  -> do poke p w-                                     go (incPtr p) (n+1) x'-{-# INLINE unfoldrStateN #-}
− Data/StorableVector/ST/Lazy.hs 
@@ -1,152 +0,0 @@-{-# LANGUAGE Rank2Types #-}-{- |-Module      : Data.StorableVector.ST.Strict-License     : BSD-style-Maintainer  : haskell@henning-thielemann.de-Stability   : experimental-Portability : portable, requires ffi-Tested with : GHC 6.4.1--Interface for access to a mutable StorableVector.--}-module Data.StorableVector.ST.Lazy (-        Vector,-        new,-        new_,-        read,-        write,-        modify,-        unsafeRead,-        unsafeWrite,-        unsafeModify,-        freeze,-        unsafeFreeze,-        thaw,-        VST.length,-        runSTVector,-        mapST,-        mapSTLazy,-        ) where---- import qualified Data.StorableVector.Base as V-import qualified Data.StorableVector as VS-import qualified Data.StorableVector.Lazy as VL--import qualified Data.StorableVector.ST.Strict as VST--import Data.StorableVector.ST.Strict (Vector)---import qualified Control.Monad.ST.Lazy as ST-import Control.Monad.ST.Lazy (ST)--import Foreign.Storable         (Storable)---- import Prelude (Int, ($), (+), return, const, )-import Prelude hiding (read, length, )------ * access to mutable storable vector--{-# INLINE new #-}-new :: (Storable e) =>-   Int -> e -> ST s (Vector s e)-new n x = ST.strictToLazyST (VST.new n x)--{-# INLINE new_ #-}-new_ :: (Storable e) =>-   Int -> ST s (Vector s e)-new_ n  =  ST.strictToLazyST (VST.new_ n)--{- |-> Control.Monad.ST.runST (do arr <- new_ 10; Monad.zipWithM_ (write arr) [9,8..0] ['a'..]; read arr 3)--}-{-# INLINE read #-}-read :: (Storable e) =>-   Vector s e -> Int -> ST s e-read xs n = ST.strictToLazyST (VST.read xs n)--{- |-> VS.unpack $ runSTVector (do arr <- new_ 10; Monad.zipWithM_ (write arr) [9,8..0] ['a'..]; return arr)--}-{-# INLINE write #-}-write :: (Storable e) =>-   Vector s e -> Int -> e -> ST s ()-write xs n x = ST.strictToLazyST (VST.write xs n x)--{-# INLINE modify #-}-modify :: (Storable e) =>-   Vector s e -> Int -> (e -> e) -> ST s ()-modify xs n f = ST.strictToLazyST (VST.modify xs n f)---{-# INLINE unsafeRead #-}-unsafeRead :: (Storable e) =>-   Vector s e -> Int -> ST s e-unsafeRead xs n = ST.strictToLazyST (VST.unsafeRead xs n)--{-# INLINE unsafeWrite #-}-unsafeWrite :: (Storable e) =>-   Vector s e -> Int -> e -> ST s ()-unsafeWrite xs n x = ST.strictToLazyST (VST.unsafeWrite xs n x)--{-# INLINE unsafeModify #-}-unsafeModify :: (Storable e) =>-   Vector s e -> Int -> (e -> e) -> ST s ()-unsafeModify xs n f = ST.strictToLazyST (VST.unsafeModify xs n f)---{-# INLINE freeze #-}-freeze :: (Storable e) =>-   Vector s e -> ST s (VS.Vector e)-freeze xs = ST.strictToLazyST (VST.freeze xs)--{-# INLINE unsafeFreeze #-}-unsafeFreeze :: (Storable e) =>-   Vector s e -> ST s (VS.Vector e)-unsafeFreeze xs = ST.strictToLazyST (VST.unsafeFreeze xs)--{-# INLINE thaw #-}-thaw :: (Storable e) =>-   VS.Vector e -> ST s (Vector s e)-thaw xs = ST.strictToLazyST (VST.thaw xs)----{-# INLINE runSTVector #-}-runSTVector :: (Storable e) =>-   (forall s. ST s (Vector s e)) -> VS.Vector e-runSTVector m = VST.runSTVector (ST.lazyToStrictST m)------ * operations on immutable storable vector within ST monad--{- |-> :module + Data.STRef-> VS.unpack $ Control.Monad.ST.runST (do ref <- newSTRef 'a'; mapST (\ _n -> do c <- readSTRef ref; modifySTRef ref succ; return c) (VS.pack [1,2,3,4::Data.Int.Int16]))--}-{-# INLINE mapST #-}-mapST :: (Storable a, Storable b) =>-   (a -> ST s b) -> VS.Vector a -> ST s (VS.Vector b)-mapST f xs =-   ST.strictToLazyST (VST.mapST (ST.lazyToStrictST . f) xs)---{- |-> *Data.StorableVector.ST.Strict Data.STRef> VL.unpack $ Control.Monad.ST.runST (do ref <- newSTRef 'a'; mapSTLazy (\ _n -> do c <- readSTRef ref; modifySTRef ref succ; return c) (VL.pack VL.defaultChunkSize [1,2,3,4::Data.Int.Int16]))-> "abcd"--The following should not work on infinite streams,-since we are in 'ST' with strict '>>='.-But it works. Why?--> *Data.StorableVector.ST.Strict Data.STRef.Lazy> VL.unpack $ Control.Monad.ST.Lazy.runST (do ref <- newSTRef 'a'; mapSTLazy (\ _n -> do c <- readSTRef ref; modifySTRef ref succ; return c) (VL.pack VL.defaultChunkSize [0::Data.Int.Int16 ..]))-> "Interrupted.--}-{-# INLINE mapSTLazy #-}-mapSTLazy :: (Storable a, Storable b) =>-   (a -> ST s b) -> VL.Vector a -> ST s (VL.Vector b)-mapSTLazy f (VL.SV xs) =-   fmap VL.SV $ mapM (mapST f) xs
− Data/StorableVector/ST/Private.hs 
@@ -1,54 +0,0 @@-{- |-Module      : Data.StorableVector.ST.Strict-License     : BSD-style-Maintainer  : haskell@henning-thielemann.de-Stability   : experimental-Portability : portable, requires ffi-Tested with : GHC 6.4.1---}-module Data.StorableVector.ST.Private where--import qualified Data.StorableVector.Base as V--import Data.StorableVector.Memory (mallocForeignPtrArray, )--import Control.Monad.ST.Strict (ST, )--import Foreign.Ptr        (Ptr, )-import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, )-import Foreign.Storable   (Storable, )--import qualified System.Unsafe as Unsafe---- import Prelude (Int, ($), (+), return, const, )-import Prelude hiding (read, length, )---data Vector s a =-   SV {-# UNPACK #-} !(ForeignPtr a)-      {-# UNPACK #-} !Int                -- length----- | Wrapper of mallocForeignPtrArray.-create :: (Storable a) => Int -> (Ptr a -> IO ()) -> IO (Vector s a)-create l f = do-    fp <- mallocForeignPtrArray l-    withForeignPtr fp f-    return $! SV fp l--{-# INLINE unsafeCreate #-}-unsafeCreate :: (Storable a) => Int -> (Ptr a -> IO ()) -> ST s (Vector s a)-unsafeCreate l f = Unsafe.ioToST $ create l f--{--This function must be in ST monad,-since it is usually called-as termination of a series of write accesses to the vector.-We must assert that no read access to the V.Vector can happen-before the end of the write accesses.-(And the caller must assert, that he actually never writes again into that vector.)--}-{-# INLINE unsafeToVector #-}-unsafeToVector :: Vector s a -> ST s (V.Vector a)-unsafeToVector (SV x l) = return (V.SV x 0 l)
− Data/StorableVector/ST/Strict.hs 
@@ -1,287 +0,0 @@-{-# LANGUAGE Rank2Types #-}-{- |-Module      : Data.StorableVector.ST.Strict-License     : BSD-style-Maintainer  : haskell@henning-thielemann.de-Stability   : experimental-Portability : portable, requires ffi-Tested with : GHC 6.4.1--Interface for access to a mutable StorableVector.--}-module Data.StorableVector.ST.Strict (-        Vector,-        new,-        new_,-        read,-        write,-        modify,-        maybeRead,-        maybeWrite,-        maybeModify,-        unsafeRead,-        unsafeWrite,-        unsafeModify,-        freeze,-        unsafeFreeze,-        thaw,-        length,-        runSTVector,-        mapST,-        mapSTLazy,-        ) where--import Data.StorableVector.ST.Private-          (Vector(SV), create, unsafeCreate, unsafeToVector, )-import qualified Data.StorableVector.Base as V-import qualified Data.StorableVector as VS-import qualified Data.StorableVector.Lazy as VL--import Control.Monad.ST.Strict (ST, runST, )--import Foreign.Ptr              (Ptr, )-import Foreign.ForeignPtr       (withForeignPtr, )-import Foreign.Storable         (Storable(peek, poke))-import Foreign.Marshal.Array    (advancePtr, copyArray, )-import qualified System.Unsafe as Unsafe--import qualified Data.Traversable as Traversable-import Data.Maybe.HT (toMaybe, )-import Data.Maybe (isJust, )---- import Prelude (Int, ($), (+), return, const, )-import Prelude hiding (read, length, )----- * access to mutable storable vector--{-# INLINE new #-}-new :: (Storable e) =>-   Int -> e -> ST s (Vector s e)-new n x =-   unsafeCreate n $-   let {-# INLINE go #-}-       go m p =-         if m>0-           then poke p x >> go (pred m) (V.incPtr p)-           else return ()-   in  go n--{-# INLINE new_ #-}-new_ :: (Storable e) =>-   Int -> ST s (Vector s e)-new_ n =-   unsafeCreate n (const (return ()))---{- |-> Control.Monad.ST.runST (do arr <- new_ 10; Monad.zipWithM_ (write arr) [9,8..0] ['a'..]; read arr 3)--}-{-# INLINE read #-}-read :: (Storable e) =>-   Vector s e -> Int -> ST s e-read v n =-   access "read" v n $ unsafeRead v n--{- |-> VS.unpack $ runSTVector (do arr <- new_ 10; Monad.zipWithM_ (write arr) [9,8..0] ['a'..]; return arr)--}-{-# INLINE write #-}-write :: (Storable e) =>-   Vector s e -> Int -> e -> ST s ()-write v n x =-   access "write" v n $ unsafeWrite v n x--{- |-> VS.unpack $ runSTVector (do arr <- new 10 'a'; Monad.mapM_ (\n -> modify arr (mod n 8) succ) [0..10]; return arr)--}-{-# INLINE modify #-}-modify :: (Storable e) =>-   Vector s e -> Int -> (e -> e) -> ST s ()-modify v n f =-   access "modify" v n $ unsafeModify v n f--{-# INLINE access #-}-access :: (Storable e) =>-   String -> Vector s e -> Int -> ST s a -> ST s a-access name (SV _v l) n act =-   if 0<=n && n<l-     then act-     else error ("StorableVector.ST." ++ name ++ ": index out of range")---{- |-Returns @Just e@, when the element @e@ could be read-and 'Nothing' if the index was out of range.-This way you can avoid duplicate index checks-that may be needed when using 'read'.--> Control.Monad.ST.runST (do arr <- new_ 10; Monad.zipWithM_ (write arr) [9,8..0] ['a'..]; read arr 3)--In future 'maybeRead' will replace 'read'.--}-{-# INLINE maybeRead #-}-maybeRead :: (Storable e) =>-   Vector s e -> Int -> ST s (Maybe e)-maybeRead v n =-   maybeAccess v n $ unsafeRead v n--{- |-Returns 'True' if the element could be written-and 'False' if the index was out of range.--> runSTVector (do arr <- new_ 10; foldr (\c go i -> maybeWrite arr i c >>= \cont -> if cont then go (succ i) else return arr) (error "unreachable") ['a'..] 0)--In future 'maybeWrite' will replace 'write'.--}-{-# INLINE maybeWrite #-}-maybeWrite :: (Storable e) =>-   Vector s e -> Int -> e -> ST s Bool-maybeWrite v n x =-   fmap isJust $ maybeAccess v n $ unsafeWrite v n x--{- |-Similar to 'maybeWrite'.--In future 'maybeModify' will replace 'modify'.--}-{-# INLINE maybeModify #-}-maybeModify :: (Storable e) =>-   Vector s e -> Int -> (e -> e) -> ST s Bool-maybeModify v n f =-   fmap isJust $ maybeAccess v n $ unsafeModify v n f--{-# INLINE maybeAccess #-}-maybeAccess :: (Storable e) =>-   Vector s e -> Int -> ST s a -> ST s (Maybe a)-maybeAccess (SV _v l) n act =-   Traversable.sequence $ toMaybe (0<=n && n<l) act-{--   if 0<=n && n<l-     then fmap Just act-     else return Nothing--}--{-# INLINE unsafeRead #-}-unsafeRead :: (Storable e) =>-   Vector s e -> Int -> ST s e-unsafeRead v n =-   unsafeAccess v n $ peek--{-# INLINE unsafeWrite #-}-unsafeWrite :: (Storable e) =>-   Vector s e -> Int -> e -> ST s ()-unsafeWrite v n x =-   unsafeAccess v n $ \p -> poke p x--{-# INLINE unsafeModify #-}-unsafeModify :: (Storable e) =>-   Vector s e -> Int -> (e -> e) -> ST s ()-unsafeModify v n f =-   unsafeAccess v n $ \p -> poke p . f =<< peek p--{-# INLINE unsafeAccess #-}-unsafeAccess :: (Storable e) =>-   Vector s e -> Int -> (Ptr e -> IO a) -> ST s a-unsafeAccess (SV v _l) n act =-   Unsafe.ioToST (withForeignPtr v $ \p -> act (advancePtr p n))---{-# INLINE freeze #-}-freeze :: (Storable e) =>-   Vector s e -> ST s (VS.Vector e)-freeze (SV x l) =-   Unsafe.ioToST $-   V.create l $ \p ->-   withForeignPtr x $ \f ->-   copyArray p f (fromIntegral l)--{- |-This is like 'freeze' but it does not copy the vector.-You must make sure that you never write again to the array.-It is best to use 'unsafeFreeze' only at the end of a block,-that is run by 'runST'.--}-{-# INLINE unsafeFreeze #-}-unsafeFreeze :: (Storable e) =>-   Vector s e -> ST s (VS.Vector e)-unsafeFreeze = unsafeToVector---{-# INLINE thaw #-}-thaw :: (Storable e) =>-   VS.Vector e -> ST s (Vector s e)-thaw v =-   Unsafe.ioToST $-   V.withStartPtr v $ \f l ->-   create l $ \p ->-   copyArray p f (fromIntegral l)---{-# INLINE length #-}-length ::-   Vector s e -> Int-length (SV _v l) = l---{-# INLINE runSTVector #-}-runSTVector :: (Storable e) =>-   (forall s. ST s (Vector s e)) -> VS.Vector e-runSTVector m =-   runST (unsafeToVector =<< m)------ * operations on immutable storable vector within ST monad--{- |-> :module + Data.STRef-> VS.unpack $ Control.Monad.ST.runST (do ref <- newSTRef 'a'; mapST (\ _n -> do c <- readSTRef ref; modifySTRef ref succ; return c) (VS.pack [1,2,3,4::Data.Int.Int16]))--}-{-# INLINE mapST #-}-mapST :: (Storable a, Storable b) =>-   (a -> ST s b) -> VS.Vector a -> ST s (VS.Vector b)-mapST f (V.SV px sx n) =-   let {-# INLINE go #-}-       go l q p =-          if l>0-            then-               do Unsafe.ioToST . poke p =<< f =<< Unsafe.ioToST (peek q)-                  go (pred l) (advancePtr q 1) (advancePtr p 1)-            else return ()-   in  do ys@(SV py _) <- new_ n-          go n-              (Unsafe.foreignPtrToPtr px `advancePtr` sx)-              (Unsafe.foreignPtrToPtr py)-          unsafeToVector ys--{--mapST f xs@(V.SV v s l) =-   let go l q p =-          if l>0-            then-               do poke p =<< stToIO . f =<< peek q-                  go (pred l) (advancePtr q 1) (advancePtr p 1)-            else return ()-       n = VS.length xs-   in  return $ V.unsafeCreate n $ \p ->-          withForeignPtr v $ \q -> go n (advancePtr q s) p--}---{- |-> *Data.StorableVector.ST.Strict Data.STRef> VL.unpack $ Control.Monad.ST.runST (do ref <- newSTRef 'a'; mapSTLazy (\ _n -> do c <- readSTRef ref; modifySTRef ref succ; return c) (VL.pack VL.defaultChunkSize [1,2,3,4::Data.Int.Int16]))-> "abcd"--The following should not work on infinite streams,-since we are in 'ST' with strict '>>='.-But it works. Why?--> *Data.StorableVector.ST.Strict Data.STRef> VL.unpack $ Control.Monad.ST.runST (do ref <- newSTRef 'a'; mapSTLazy (\ _n -> do c <- readSTRef ref; modifySTRef ref succ; return c) (VL.pack VL.defaultChunkSize [0::Data.Int.Int16 ..]))-> "Interrupted.--}-{-# INLINE mapSTLazy #-}-mapSTLazy :: (Storable a, Storable b) =>-   (a -> ST s b) -> VL.Vector a -> ST s (VL.Vector b)-mapSTLazy f (VL.SV xs) =-   fmap VL.SV $ mapM (mapST f) xs
+ speedtest/Data/StorableVector/Private.hs view
@@ -0,0 +1,151 @@+{- |+Functions that may be useful, but I'm uncertain.+-}+module Data.StorableVector.Private where+++import Data.StorableVector (empty, unfoldrN, viewL, length, )+import Data.StorableVector.Base++import qualified Data.Strictness.HT as Strict++import Foreign.Storable         (Storable(..))++import qualified System.Unsafe as Unsafe++import Control.DeepSeq (NFData, rnf, deepseq, )++import Prelude hiding (length, )++++{- |+This implementation is based on viewL+and thus not as fast as possible.+-}+zipWithViewL :: (Storable a, Storable b, Storable c) =>+   (a -> b -> c) -> Vector a -> Vector b -> Vector c+zipWithViewL f ps0 qs0 =+   fst $ unfoldrN+      (min (length ps0) (length qs0))+      (\(ps,qs) ->+         do (ph,pt) <- viewL ps+            (qh,qt) <- viewL qs+            return (f ph qh, (pt,qt)))+      (ps0,qs0)+++zipWithIndex :: (Storable a, Storable b, Storable c) =>+   (a -> b -> c) -> Vector a -> Vector b -> Vector c+zipWithIndex f ps qs =+   fst $ unfoldrN+      (min (length ps) (length qs))+      (\i -> Just (f (unsafeIndex ps i) (unsafeIndex qs i), succ i))+      0+++unfoldrStrictN :: (Storable b, NFData a) => Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a)+-- unfoldrStrictN :: (Storable b) => Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a)+unfoldrStrictN i f x0 =+   if i <= 0+     then (empty, Just x0)+     else Unsafe.performIO $ createAndTrim' i $ \p -> go p 0 x0+       {-+       go must not be strict in the accumulator+       since otherwise packN would be too strict.+       -}+       where+          go = Strict.arguments3 $ \p n -> \x ->+             if n == i+               then return (0, n, Just x)+               else+                 case f x of+                   Nothing     -> return (0, n, Nothing)+                   Just (w,x') -> do poke p w+--                                     go (incPtr p) (n+1) $! x'+                                     go (incPtr p) (n+1) (x' `deepseq` x')+--                                     seq (rnf x') (((go $! incPtr p) $! n+1) $! x')+{-# INLINE unfoldrStrictN #-}++unfoldrTransitionN :: (Storable b) => Int -> (a -> a) -> (a -> Maybe b) -> a -> (Vector b, a)+unfoldrTransitionN n trans emit x =+   if n <= 0+     then (empty, x)+     else Unsafe.performIO $ createAndTrim' n $ \p ->+       case emit x of+         Nothing -> return (0, n, x)+         Just y0 -> poke p y0 >>+           {-+           go must not be strict in the accumulator+           since otherwise packN would be too strict.+           -}+           let go = Strict.arguments2 $ \p0 i0 -> \x0 ->+                  {-+                  We run 'emit' in order to evaluate the new state.+                  We need to return this new state+                  also in case the array is full.+                  The drawback is, that the whole vector becomes undefined+                  if only the state after the last element is undefined.+                  This is the same situation as in an unfoldr with strict state.+                  -}+                  let i1 = i0-1+                      x1 = trans x0+                  in  case emit x1 of+                         Nothing -> return (0, n-i1, x1)+                         Just y1 ->+                            if i1 == 0+                              then return (0, n, x1)+                              else+                                let p1 = incPtr p0+                                in  do poke p1 y1+                                       go p1 i1 x1+{-+                  let i1 = i0-1+                  in  if i1 == 0+                        then return (0, n, x0)+                        else+                          let x1 = trans x0+                              p1 = incPtr p0+                          in  case emit x1 of+                                Nothing -> return (0, n-i1, x1)+                                Just y1 -> do poke p1 y1+                                              go p1 i1 x1+-}+           in  go p n x+{-# INLINE unfoldrTransitionN #-}++-- | /O(n)/ Like 'unfoldrN' this function builds a 'Vector' from a seed+-- value.  However, it does always return a state value.+-- The vector construction can be aborted either by reaching+-- the given maximum size or by returning 'Nothing' as element.+--+-- The following equation relates 'unfoldrN' and 'unfoldrStateN':+--+-- > unfoldrN n f s ==+-- >    unfoldrStateN n+-- >       (maybe (error "state will be always Just")+-- >           ((\a -> (fmap fst a, fmap snd a)) . f))+-- >       (Just s)+--+-- It is not possible to express 'unfoldrNState' in terms of 'unfoldrN'.+--+unfoldrStateN :: (Storable b) => Int -> (a -> (Maybe b, a)) -> a -> (Vector b, a)+unfoldrStateN i f x0 =+   if i <= 0+     then (empty, x0)+     else Unsafe.performIO $ createAndTrim' i $ \p -> go p 0 x0+       {-+       go must not be strict in the accumulator+       since otherwise packN would be too strict.+       -}+       where+          go = Strict.arguments2 $ \p n -> \x ->+             if n == i+               then return (0, n, x)+               else+                 let (my,x') = f x+                 in  case my of+                       Nothing -> return (0, n, x)+                       Just w  -> do poke p w+                                     go (incPtr p) (n+1) x'+{-# INLINE unfoldrStateN #-}
+ src/Data/StorableVector.hs view
@@ -0,0 +1,1571 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+--+-- Module      : StorableVector+-- Copyright   : (c) The University of Glasgow 2001,+--               (c) David Roundy 2003-2005,+--               (c) Simon Marlow 2005+--               (c) Don Stewart 2005-2006+--               (c) Bjorn Bringert 2006+--               (c) Spencer Janssen 2006+--               (c) Henning Thielemann 2008-2013+--+--+-- License     : BSD-style+--+-- Maintainer  : Henning Thielemann+-- Stability   : experimental+-- Portability : portable, requires ffi and cpp+-- Tested with : GHC 6.4.1 and Hugs March 2005+--++--+-- | A time and space-efficient implementation of vectors using+-- packed arrays, suitable for high performance use, both in terms+-- of large data quantities, or high speed requirements. Vectors+-- are encoded as strict arrays, held in a 'ForeignPtr',+-- and can be passed between C and Haskell with little effort.+--+-- This module is intended to be imported @qualified@, to avoid name+-- clashes with "Prelude" functions.  eg.+--+-- > import qualified Data.StorableVector as V+--+-- Original GHC implementation by Bryan O\'Sullivan. Rewritten to use+-- UArray by Simon Marlow. Rewritten to support slices and use+-- ForeignPtr by David Roundy. Polished and extended by Don Stewart.+-- Generalized to any Storable value by Spencer Janssen.+-- Chunky lazy stream, also with chunk pattern control,+-- mutable access in ST monad, Builder monoid by Henning Thieleman.++module Data.StorableVector (++        -- * The @Vector@ type+        Vector,++        -- * Introducing and eliminating 'Vector's+        empty,+        singleton,+        pack,+        unpack,+        packN,+        packWith,+        unpackWith,++        -- * Basic interface+        cons,+        snoc,+        append,+        head,+        last,+        tail,+        init,+        null,+        length,+        viewL,+        viewR,+        switchL,+        switchR,++        -- * Transforming 'Vector's+        map,+        reverse,+        intersperse,+        transpose,++        -- * Reducing 'Vector's (folds)+        foldl,+        foldl',+        foldl1,+        foldl1',+        foldr,+        foldr1,++        -- ** Special folds+        concat,+        concatMap,+        monoidConcatMap,+        any,+        all,+        maximum,+        minimum,++        -- * Building 'Vector's+        -- ** Scans+        scanl,+        scanl1,+        scanr,+        scanr1,++        -- ** Accumulating maps+        mapAccumL,+        mapAccumR,+        mapIndexed,++        -- ** Unfolding 'Vector's+        replicate,+        iterateN,+        unfoldr,+        unfoldrN,+        unfoldrResultN,+        sample,++        -- * Substrings++        -- ** Breaking strings+        take,+        drop,+        splitAt,+        takeWhile,+        dropWhile,+        span,+        spanEnd,+        break,+        breakEnd,+        group,+        groupBy,+        inits,+        tails,++        -- ** Breaking into many substrings+        split,+        splitWith,+        tokens,++        -- ** Joining strings+        join,++        -- * Predicates+        isPrefixOf,+        isSuffixOf,++        -- * Searching 'Vector's++        -- ** Searching by equality+        elem,+        notElem,++        -- ** Searching with a predicate+        find,+        filter,++        -- * Indexing 'Vector's+        index,+        elemIndex,+        elemIndices,+        elemIndexEnd,+        findIndex,+        findIndices,+        count,+        findIndexOrEnd,++        -- * Zipping and unzipping 'Vector's+        zip,+        zipWith,+        zipWith3,+        zipWith4,+        unzip,+        copy,++        -- * Interleaved 'Vector's+        sieve,+        deinterleave,+        interleave,++        -- * IO+        hGet,+        hPut,+        readFile,+        writeFile,+        appendFile,++  ) where++import Data.StorableVector.Base++import qualified System.Unsafe as Unsafe++import Control.Exception        (assert, bracket, )+import System.IO                (IO, FilePath, Handle, IOMode(..),+                                 openBinaryFile, hClose, hFileSize,+                                 hGetBuf, hPutBuf, )++import Foreign.ForeignPtr       (ForeignPtr, withForeignPtr, )+import Foreign.Marshal.Array    (advancePtr, copyArray, withArray, )+import Foreign.Ptr              (Ptr, minusPtr, )+import Foreign.Storable         (Storable(..))++import qualified Test.QuickCheck as QC++import qualified Control.Monad.Trans.Cont as MC+import Control.Monad            (mplus, guard, when, liftM2, liftM3, liftM4,+                                 mapM, sequence_, return, (=<<), (>>=), (>>), )+import Data.Functor             (fmap, )+import Data.Monoid              (Monoid, mempty, mappend, mconcat, )++import qualified Data.List as List+import qualified Data.List.HT as ListHT+import qualified Data.Strictness.HT as Strict+import Text.Show (show, )+import Data.Function (flip, id, const, ($), (.), )+import Data.List (and, (++), )+import Data.Tuple.HT (mapSnd, )+import Data.Tuple (uncurry, curry, fst, snd, )+import Data.Either (Either(Left, Right), )+import Data.Maybe.HT (toMaybe, )+import Data.Maybe (Maybe(Just, Nothing), maybe, fromMaybe, isJust, )+import Data.Bool.HT (if', )+import Data.Bool (Bool(False, True), not, otherwise, (&&), (||), )+import Data.Ord (Ord, min, max, (<), (<=), (>), (>=), )+import Data.Eq (Eq, (==), (/=), )++import qualified Prelude as P+import Prelude+          (String, Int, (*), (-), (+), div, mod,+           fromIntegral, error, undefined, )+++-- -----------------------------------------------------------------------------++instance (Storable a, Eq a) => Eq (Vector a) where+    (==) = equal++instance (Storable a) => Monoid (Vector a) where+    mempty  = empty+    mappend = append+    mconcat = concat++instance (Storable a, QC.Arbitrary a) => QC.Arbitrary (Vector a) where+    arbitrary = pack `fmap` QC.arbitrary++-- | /O(n)/ Equality on the 'Vector' type.+equal :: (Storable a, Eq a) => Vector a -> Vector a -> Bool+equal a b =+   Unsafe.performIO $+   withStartPtr a $ \paf la ->+   withStartPtr b $ \pbf lb ->+    if la /= lb+      then+        return False+      else+        if paf == pbf+          then return True+          else+            let go = Strict.arguments3 $ \p q l ->+                   if l==0+                     then return True+                     else+                       do x <- peek p+                          y <- peek q+                          if x==y+                            then go (incPtr p) (incPtr q) (l-1)+                            else return False+            in  go paf pbf la+{-# INLINE equal #-}++-- -----------------------------------------------------------------------------+-- Introducing and eliminating 'Vector's++-- | /O(1)/ The empty 'Vector'+empty :: (Storable a) => Vector a+empty = unsafeCreate 0 $ const $ return ()+{-# NOINLINE empty #-}++-- | /O(1)/ Construct a 'Vector' containing a single element+singleton :: (Storable a) => a -> Vector a+singleton c = unsafeCreate 1 $ \p -> poke p c+{-# INLINE singleton #-}++-- | /O(n)/ Convert a '[a]' into a 'Vector a'.+--+pack :: (Storable a) => [a] -> Vector a+pack str = unsafeCreate (P.length str) $ \p -> go p str+    where+      go = Strict.arguments2 $ \p ->+        ListHT.switchL+           (return ())+           (\x xs -> poke p x >> go (incPtr p) xs)++-- | /O(n)/ Convert first @n@ elements of a '[a]' into a 'Vector a'.+--+packN :: (Storable a) => Int -> [a] -> (Vector a, [a])+packN n =+   mapSnd (fromMaybe []) . unfoldrN n ListHT.viewL++-- | /O(n)/ Converts a 'Vector a' to a '[a]'.+unpack :: (Storable a) => Vector a -> [a]+unpack = foldr (:) []+{-# INLINE unpack #-}++------------------------------------------------------------------------++-- | /O(n)/ Convert a list into a 'Vector' using a conversion function+packWith :: (Storable b) => (a -> b) -> [a] -> Vector b+packWith k str = unsafeCreate (P.length str) $ \p -> go p str+    where+      go = Strict.arguments2 $ \p ->+        ListHT.switchL+           (return ())+           (\x xs -> poke p (k x) >> go (incPtr p) xs)+                          -- less space than pokeElemOff+{-# INLINE packWith #-}++{-+*Data.StorableVector> List.take 10 $ unpackWith id $ pack [0..10000000::Int]+[0,1,2,3,4,5,6,7,8,9]+(19.18 secs, 2327851592 bytes)+-}+-- | /O(n)/ Convert a 'Vector' into a list using a conversion function+unpackWith :: (Storable a) => (a -> b) -> Vector a -> [b]+unpackWith f = foldr ((:) . f) []+{-# INLINE unpackWith #-}++{-+That's too inefficient, since it builds the list from back to front,+that is, in a too strict manner.++-- | /O(n)/ Convert a 'Vector' into a list using a conversion function+unpackWith :: (Storable a) => (a -> b) -> Vector a -> [b]+unpackWith _ (SV _  _ 0) = []+unpackWith k v@(SV ps s l) = inlinePerformIO $ withStartPtr v $ \p ->+        go p (l - 1) []+    where+        STRICT3(go)+        go p 0 acc = peek p          >>= \e -> return (k e : acc)+        go p n acc = peekElemOff p n >>= \e -> go p (n-1) (k e : acc)+{-# INLINE unpackWith #-}+++*Data.StorableVector> List.take 10 $ unpack $ pack [0..10000000::Int]+[0,1,2,3,4,5,6,7,8,9]+(18.57 secs, 2323959948 bytes)+*Data.StorableVector> unpack $ take 10 $ pack [0..10000000::Int]+[0,1,2,3,4,5,6,7,8,9]+(18.40 secs, 2324002120 bytes)+*Data.StorableVector> List.take 10 $ unpackWith id $ pack [0..10000000::Int]+Interrupted.+-}++-- ---------------------------------------------------------------------+-- Basic interface++-- | /O(1)/ Test whether a 'Vector' is empty.+null :: Vector a -> Bool+null (SV _ _ l) = assert (l >= 0) $ l <= 0+{-# INLINE null #-}++-- ---------------------------------------------------------------------+-- | /O(1)/ 'length' returns the length of a 'Vector' as an 'Int'.+length :: Vector a -> Int+length (SV _ _ l) = assert (l >= 0) $ l++--+-- length/loop fusion. When taking the length of any fuseable loop,+-- rewrite it as a foldl', and thus avoid allocating the result buffer+-- worth around 10% in speed testing.+--++{-# INLINE [1] length #-}++------------------------------------------------------------------------++-- | /O(n)/ 'cons' is analogous to (:) for lists, but of different+-- complexity, as it requires a memcpy.+cons :: (Storable a) => a -> Vector a -> Vector a+cons c v =+   unsafeWithStartPtr v $ \f l ->+   create (l + 1) $ \p -> do+      poke p c+      copyArray (incPtr p) f (fromIntegral l)+{-# INLINE cons #-}++-- | /O(n)/ Append an element to the end of a 'Vector'+snoc :: (Storable a) => Vector a -> a -> Vector a+snoc v c =+   unsafeWithStartPtr v $ \f l ->+   create (l + 1) $ \p -> do+      copyArray p f l+      pokeElemOff p l c+{-# INLINE snoc #-}++-- | /O(1)/ Extract the first element of a 'Vector', which must be non-empty.+-- An exception will be thrown in the case of an empty 'Vector'.+head :: (Storable a) => Vector a -> a+head =+   withNonEmptyVector "head" $ \ p s _l -> foreignPeek p s+{-# INLINE head #-}++-- | /O(1)/ Extract the elements after the head of a 'Vector', which must be non-empty.+-- An exception will be thrown in the case of an empty 'Vector'.+tail :: (Storable a) => Vector a -> Vector a+tail =+   withNonEmptyVector "tail" $ \ p s l -> SV p (s+1) (l-1)+{-# INLINE tail #-}++laxTail :: (Storable a) => Vector a -> Vector a+laxTail v@(SV fp s l) =+   if l<=0+     then v+     else SV fp (s+1) (l-1)+{-# INLINE laxTail #-}++-- | /O(1)/ Extract the last element of a 'Vector', which must be finite and non-empty.+-- An exception will be thrown in the case of an empty 'Vector'.+last :: (Storable a) => Vector a -> a+last =+   withNonEmptyVector "last" $ \ p s l -> foreignPeek p (s+l-1)+{-# INLINE last #-}++-- | /O(1)/ Return all the elements of a 'Vector' except the last one.+-- An exception will be thrown in the case of an empty 'Vector'.+init :: Vector a -> Vector a+init =+   withNonEmptyVector "init" $ \ p s l -> SV p s (l-1)+{-# INLINE init #-}++-- | /O(n)/ Append two Vectors+append :: (Storable a) => Vector a -> Vector a -> Vector a+append xs ys =+   if' (null xs) ys $+   if' (null ys) xs $+   concat [xs,ys]+{-# INLINE append #-}++-- ---------------------------------------------------------------------+-- Transformations++-- | /O(n)/ 'map' @f xs@ is the 'Vector' obtained by applying @f@ to each+-- element of @xs@.+map :: (Storable a, Storable b) => (a -> b) -> Vector a -> Vector b+map f v =+   unsafeWithStartPtr v $ \a len ->+   create len $ \p ->+      let go = Strict.arguments3 $+             \ n p1 p2 ->+               when (n>0) $+                 do poke p2 . f =<< peek p1+                    go (n-1) (incPtr p1) (incPtr p2)+      in  go len a p+{-# INLINE map #-}++{-+mapByIndex :: (Storable a, Storable b) => (a -> b) -> Vector a -> Vector b+mapByIndex f v = inlinePerformIO $ withStartPtr v $ \a len ->+    create len $ \p2 ->+       let go = Strict.arguments1 $ \ n ->+              when (n<len) $+                do pokeElemOff p2 n . f =<< peekElemOff a n+                   go (n+1)+       in  go 0+-}++-- | /O(n)/ 'reverse' @xs@ efficiently returns the elements of @xs@ in reverse order.+reverse :: (Storable a) => Vector a -> Vector a+reverse v =+   unsafeWithStartPtr v $ \f l ->+   create l $ \p ->+   sequence_ [peekElemOff f i >>= pokeElemOff p (l - i - 1)+                 | i <- [0 .. l - 1]]++-- | /O(n)/ The 'intersperse' function takes a element and a+-- 'Vector' and \`intersperses\' that element between the elements of+-- the 'Vector'.  It is analogous to the intersperse function on+-- Lists.+intersperse :: (Storable a) => a -> Vector a -> Vector a+intersperse c = pack . List.intersperse c . unpack++-- | The 'transpose' function transposes the rows and columns of its+-- 'Vector' argument.+transpose :: (Storable a) => [Vector a] -> [Vector a]+transpose ps = P.map pack (List.transpose (P.map unpack ps))++-- ---------------------------------------------------------------------+-- Reducing 'Vector's++-- | 'foldl', applied to a binary operator, a starting value (typically+-- the left-identity of the operator), and a Vector, reduces the+-- 'Vector' using the binary operator, from left to right.+-- This function is subject to array fusion.+foldl :: (Storable a) => (b -> a -> b) -> b -> Vector a -> b+foldl f v xs =+   foldr (\x k acc -> k (f acc x)) id xs v+{-# INLINE foldl #-}++-- | 'foldl\'' is like 'foldl', but strict in the accumulator.+foldl' :: (Storable a) => (b -> a -> b) -> b -> Vector a -> b+foldl' f b v =+   Unsafe.performIO $ withStartPtr v $ \ptr l ->+      let q  = ptr `advancePtr` l+          go = Strict.arguments2 $ \p z ->+             if p == q+               then return z+               else go (incPtr p) . f z =<< peek p+      in  go ptr b+{-# INLINE foldl' #-}++-- | 'foldr', applied to a binary operator, a starting value+-- (typically the right-identity of the operator), and a 'Vector',+-- reduces the 'Vector' using the binary operator, from right to left.+-- However, it is not the same as 'foldl' applied to the reversed vector.+-- Actually 'foldr' starts processing with the first element,+-- and thus can be used for efficiently building a singly linked list+-- by @foldr (:) [] vec@.+-- Unfortunately 'foldr' is quite slow for low-level loops,+-- since GHC (up to 6.12.1) cannot detect the loop.+foldr :: (Storable a) => (a -> b -> b) -> b -> Vector a -> b+foldr = foldrByLoop+{-# INLINE foldr #-}++{-+*Data.StorableVector> List.length $ foldrBySwitch (:) [] $ replicate 1000000 'a'+1000000+(11.29 secs, 1183476300 bytes)+*Data.StorableVector> List.length $ foldrByIO (:) [] $ replicate 1000000 'a'+1000000+(7.86 secs, 1033901140 bytes)+*Data.StorableVector> List.length $ foldrByIndex (:) [] $ replicate 1000000 'a'+1000000+(7.86 secs, 914340420 bytes)+*Data.StorableVector> List.length $ foldrByLoop (:) [] $ replicate 1000000 'a'+1000000+(6.38 secs, 815355460 bytes)+-}+{-+We cannot simply increment the pointer,+since ForeignPtr cannot be incremented.+We also cannot convert from ForeignPtr to Ptr+and increment that instead,+because we need to keep the reference to ForeignPtr,+otherwise memory might be freed.+We can also not perform loop entirely in strict IO,+since this eat up the stack quickly+and 'foldr' might be used to build a list lazily.+-}+foldrByLoop :: (Storable a) => (a -> b -> b) -> b -> Vector a -> b+foldrByLoop f z (SV fp s l) =+   let end = s+l+       go = Strict.arguments1 $ \k ->+          if k<end+            then f (foreignPeek fp k) (go (succ k))+            else z+   in  go s+{-# INLINE foldrByLoop #-}++{-+foldrByIO :: (Storable a) => (a -> b -> b) -> b -> Vector a -> b+foldrByIO f z v@(SV fp _ _) =+   unsafeWithStartPtr v $+   let go = Strict.arguments2 $ \p l ->+          Unsafe.interleaveIO $+          if l>0+            then liftM2 f (peek p) (go (incPtr p) (pred l))+            else touchForeignPtr fp >> return z+   in  go+{-# INLINE foldrByIO #-}++foldrByIndex :: (Storable a) => (a -> b -> b) -> b -> Vector a -> b+foldrByIndex k z xs =+   let recourse n =+          if n < length xs+            then k (unsafeIndex xs n) (recourse (succ n))+            else z+   in  recourse 0+{-# INLINE foldrByIndex #-}++{-+This implementation is a bit inefficient,+since switchL creates a new Vector structure+instead of just incrementing an index.+-}+foldrBySwitch :: (Storable a) => (a -> b -> b) -> b -> Vector a -> b+foldrBySwitch k z =+   let recourse = switchL z (\h t -> k h (recourse t))+   in  recourse+{-# INLINE foldrBySwitch #-}+-}+++-- | 'foldl1' is a variant of 'foldl' that has no starting value+-- argument, and thus must be applied to non-empty 'Vector's.+-- This function is subject to array fusion.+-- An exception will be thrown in the case of an empty 'Vector'.+foldl1 :: (Storable a) => (a -> a -> a) -> Vector a -> a+foldl1 f =+   switchL+      (errorEmpty "foldl1")+      (foldl f)+{-# INLINE foldl1 #-}++-- | 'foldl1\'' is like 'foldl1', but strict in the accumulator.+-- An exception will be thrown in the case of an empty 'Vector'.+foldl1' :: (Storable a) => (a -> a -> a) -> Vector a -> a+foldl1' f =+   switchL+      (errorEmpty "foldl1'")+      (foldl' f)+{-# INLINE foldl1' #-}++-- | 'foldr1' is a variant of 'foldr' that has no starting value argument,+-- and thus must be applied to non-empty 'Vector's+-- An exception will be thrown in the case of an empty 'Vector'.+foldr1 :: (Storable a) => (a -> a -> a) -> Vector a -> a+foldr1 f =+   switchR+      (errorEmpty "foldr1")+      (flip (foldr f))+{-# INLINE foldr1 #-}++-- ---------------------------------------------------------------------+-- Special folds++-- | /O(n)/ Concatenate a list of 'Vector's.+concat :: (Storable a) => [Vector a] -> Vector a+concat []     = empty+concat [ps]   = ps+concat xs     = unsafeCreate len $ \ptr -> go ptr xs+  where len = P.sum . P.map length $ xs+        go =+          Strict.arguments2 $ \ptr ->+             ListHT.switchL+                (return ())+                (\v ps -> do+                   withStartPtr v $ copyArray ptr+                   go (ptr `advancePtr` length v) ps)++-- | Map a function over a 'Vector' and concatenate the results+concatMap :: (Storable a, Storable b) => (a -> Vector b) -> Vector a -> Vector b+concatMap f = concat . unpackWith f+{-# INLINE concatMap #-}++-- | This is like @mconcat . map f@,+-- but in many cases the result of @f@ will not be storable.+monoidConcatMap :: (Storable a, Monoid m) => (a -> m) -> Vector a -> m+monoidConcatMap f =+   foldr (mappend . f) mempty+{-# INLINE monoidConcatMap #-}++-- | /O(n)/ Applied to a predicate and a 'Vector', 'any' determines if+-- any element of the 'Vector' satisfies the predicate.+any :: (Storable a) => (a -> Bool) -> Vector a -> Bool+any f = foldr ((||) . f) False+{-# INLINE any #-}++-- | /O(n)/ Applied to a predicate and a 'Vector', 'all' determines+-- if all elements of the 'Vector' satisfy the predicate.+all :: (Storable a) => (a -> Bool) -> Vector a -> Bool+all f = foldr ((&&) . f) True+{-# INLINE all #-}++------------------------------------------------------------------------++-- | /O(n)/ 'maximum' returns the maximum value from a 'Vector'+-- This function will fuse.+-- An exception will be thrown in the case of an empty 'Vector'.+maximum :: (Storable a, Ord a) => Vector a -> a+maximum = foldl1' max++-- | /O(n)/ 'minimum' returns the minimum value from a 'Vector'+-- This function will fuse.+-- An exception will be thrown in the case of an empty 'Vector'.+minimum :: (Storable a, Ord a) => Vector a -> a+minimum = foldl1' min++------------------------------------------------------------------------++switchL :: Storable a => b -> (a -> Vector a -> b) -> Vector a -> b+switchL n j x =+   if null x+     then n+     else j (unsafeHead x) (unsafeTail x)+{-# INLINE switchL #-}++switchR :: Storable a => b -> (Vector a -> a -> b) -> Vector a -> b+switchR n j x =+   if null x+     then n+     else j (unsafeInit x) (unsafeLast x)+{-# INLINE switchR #-}++viewL :: Storable a => Vector a -> Maybe (a, Vector a)+viewL = switchL Nothing (curry Just)+{-# INLINE viewL #-}++viewR :: Storable a => Vector a -> Maybe (Vector a, a)+viewR = switchR Nothing (curry Just)+{-# INLINE viewR #-}++-- | The 'mapAccumL' function behaves like a combination of 'map' and+-- 'foldl'; it applies a function to each element of a 'Vector',+-- passing an accumulating parameter from left to right, and returning a+-- final value of this accumulator together with the new list.+mapAccumL :: (Storable a, Storable b) => (acc -> a -> (acc, b)) -> acc -> Vector a -> (acc, Vector b)+mapAccumL f acc0 as0 =+   let (bs, Just (acc2, _)) =+          unfoldrN (length as0)+             (\(acc,as) ->+                 fmap+                    (\(asHead,asTail) ->+                        let (acc1,b) = f acc asHead+                        in  (b, (acc1, asTail)))+                    (viewL as))+             (acc0,as0)+   in  (acc2, bs)+{-# INLINE mapAccumL #-}++-- | The 'mapAccumR' function behaves like a combination of 'map' and+-- 'foldr'; it applies a function to each element of a 'Vector',+-- passing an accumulating parameter from right to left, and returning a+-- final value of this accumulator together with the new 'Vector'.+mapAccumR :: (Storable a, Storable b) => (acc -> a -> (acc, b)) -> acc -> Vector a -> (acc, Vector b)+mapAccumR f acc0 as0 =+   let (bs, Just (acc2, _)) =+          unfoldlN (length as0)+             (\(acc,as) ->+                 fmap+                    (\(asInit,asLast) ->+                        let (acc1,b) = f acc asLast+                        in  (b, (acc1, asInit)))+                    (viewR as))+             (acc0,as0)+   in  (acc2, bs)+{-# INLINE mapAccumR #-}++-- | /O(n)/ map functions, provided with the index at each position+mapIndexed :: (Storable a, Storable b) => (Int -> a -> b) -> Vector a -> Vector b+mapIndexed f = snd . mapAccumL (\i e -> (i + 1, f i e)) 0+{-# INLINE mapIndexed #-}++-- ---------------------------------------------------------------------+-- Building 'Vector's++-- | 'scanl' is similar to 'foldl', but returns a list of successive+-- reduced values from the left. This function will fuse.+--+-- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]+--+-- Note that+--+-- > last (scanl f z xs) == foldl f z xs.+scanl :: (Storable a, Storable b) => (a -> b -> a) -> a -> Vector b -> Vector a+scanl f acc0 as0 =+   fst $+      unfoldrN (succ (length as0))+         (fmap $ \(acc,as) ->+             (acc,+              fmap+                 (\(asHead,asTail) ->+                     (f acc asHead, asTail))+                 (viewL as)))+         (Just (acc0, as0))++-- less efficient but much more comprehensible+-- scanl f z ps =+--   cons z (snd (mapAccumL (\acc a -> let b = f acc a in (b,b)) z ps))++    -- n.b. haskell's List scan returns a list one bigger than the+    -- input, so we need to snoc here to get some extra space, however,+    -- it breaks map/up fusion (i.e. scanl . map no longer fuses)+{-# INLINE scanl #-}++-- | 'scanl1' is a variant of 'scanl' that has no starting value argument.+-- This function will fuse.+--+-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]+scanl1 :: (Storable a) => (a -> a -> a) -> Vector a -> Vector a+scanl1 f = switchL empty (scanl f)+{-# INLINE scanl1 #-}++-- | scanr is the right-to-left dual of scanl.+scanr :: (Storable a, Storable b) => (a -> b -> b) -> b -> Vector a -> Vector b+scanr f acc0 as0 =+   fst $+      unfoldlN (succ (length as0))+         (fmap $ \(acc,as) ->+             (acc,+              fmap+                 (\(asInit,asLast) ->+                     (f asLast acc, asInit))+                 (viewR as)))+         (Just (acc0, as0))+{-# INLINE scanr #-}++-- | 'scanr1' is a variant of 'scanr' that has no starting value argument.+scanr1 :: (Storable a) => (a -> a -> a) -> Vector a -> Vector a+scanr1 f = switchR empty (flip (scanl f))+{-# INLINE scanr1 #-}++-- ---------------------------------------------------------------------+-- Unfolds and replicates++-- | /O(n)/ 'replicate' @n x@ is a 'Vector' of length @n@ with @x@+-- the value of every element.+--+{- nice implementation+replicate :: (Storable a) => Int -> a -> Vector a+replicate n c =+   fst $ unfoldrN n (const $ Just (c, ())) ()+-}++{-+fast implementation++Maybe it could be made even faster by plainly copying the bit pattern of the first element.+Since there is no function like 'memset',+we could not warrant that the implementation is really efficient+for the actual machine we run on.+-}+replicate :: (Storable a) => Int -> a -> Vector a+replicate n c =+   if n <= 0+     then empty+     else unsafeCreate n $+       let go = Strict.arguments2 $ \i p ->+              if i == 0+                then return ()+                else poke p c >> go (pred i) (incPtr p)+       in  go n+{-# INLINE replicate #-}+{-+For 'replicate 10000000 (42::Int)' generates:++Main_zdwa_info:+	movl (%ebp),%eax+	testl %eax,%eax+	jne .LcfIQ+	movl $ghczmprim_GHCziUnit_Z0T_closure+1,%esi+	addl $8,%ebp+	jmp *(%ebp)+.LcfIQ:+	movl 4(%ebp),%ecx+	movl $42,(%ecx)+	decl %eax+	addl $4,4(%ebp)+	movl %eax,(%ebp)+	jmp Main_zdwa_info++that is, the inner loop consists of 9 instructions,+where I would write something like:+	# counter in %ecx+	testl %ecx+	jz skip_loop+	movl $42,%ebx+start_loop:+	movl %ebx,(%edx)+	addl $4,%edx+	loop start_loop+skip_loop:++and need only 3 instructions in the loop.+-}+++-- | /O(n)/ 'iterateN' @n f x@ is a 'Vector' of length @n@+-- where the elements of @x@ are generated by repeated application of @f@.+--+iterateN :: (Storable a) => Int -> (a -> a) -> a -> Vector a+iterateN n f =+   fst . unfoldrN n (\a -> Just (a, f a))+{-# INLINE iterateN #-}++-- | /O(n)/, where /n/ is the length of the result.  The 'unfoldr'+-- function is analogous to the List \'unfoldr\'.  'unfoldr' builds a+-- 'Vector' from a seed value.  The function takes the element and+-- returns 'Nothing' if it is done producing the 'Vector or returns+-- 'Just' @(a,b)@, in which case, @a@ is the next element in the 'Vector',+-- and @b@ is the seed value for further production.+--+-- Examples:+--+-- >    unfoldr (\x -> if x <= 5 then Just (x, x + 1) else Nothing) 0+-- > == pack [0, 1, 2, 3, 4, 5]+--+unfoldr :: (Storable b) => (a -> Maybe (b, a)) -> a -> Vector b+unfoldr f = concat . unfoldChunk 32 64+  where unfoldChunk n n' x =+          case unfoldrN n f x of+            (s, mx) -> s : maybe [] (unfoldChunk n' (n+n')) mx+{-# INLINE unfoldr #-}++-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a 'Vector' from a seed+-- value.  However, the length of the result is limited by the first+-- argument to 'unfoldrN'.  This function is more efficient than 'unfoldr'+-- when the maximum length of the result is known.+--+-- The following equation relates 'unfoldrN' and 'unfoldr':+--+-- > fst (unfoldrN n f s) == take n (unfoldr f s)+--+unfoldrN :: (Storable b) => Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a)+unfoldrN n f x0 =+   if n <= 0+     then (empty, Just x0)+     else Unsafe.performIO $ createAndTrim' n $ \p -> go p n x0+       {-+       go must not be strict in the accumulator+       since otherwise packN would be too strict.+       -}+       where+          go = Strict.arguments2 $ \p i -> \x ->+             if i == 0+               then return (0, n-i, Just x)+               else+                 case f x of+                   Nothing     -> return (0, n-i, Nothing)+                   Just (w,x') -> do poke p w+                                     go (incPtr p) (i-1) x'+{-# INLINE unfoldrN #-}++{-+Examples:++f i = Just (i::Char, succ i)++f i = toMaybe (i<='p') (i::Char, succ i)++-}+-- | /O(n)/ Like 'unfoldrN' this function builds a 'Vector'+-- from a seed value with limited size.+-- Additionally it returns a value, that depends on the state,+-- but is not necessarily the state itself.+-- If end of vector and end of the generator coincide,+-- then the result is as if only the end of vector is reached.+--+-- Example:+--+-- > unfoldrResultN 30 Char.ord (\c -> if c>'z' then Left 1000 else Right (c, succ c)) 'a'+--+-- The following equation relates 'unfoldrN' and 'unfoldrResultN':+--+-- > unfoldrN n f s ==+-- >    unfoldrResultN n Just+-- >       (maybe (Left Nothing) Right . f) s+--+-- It is not possible to express 'unfoldrResultN' in terms of 'unfoldrN'.+--+unfoldrResultN :: (Storable b) => Int -> (a -> c) -> (a -> Either c (b, a)) -> a -> (Vector b, c)+unfoldrResultN i g f x0 =+   if i <= 0+     then (empty, g x0)+     else Unsafe.performIO $ createAndTrim' i $ \p -> go p 0 x0+       {-+       go must not be strict in the accumulator+       since otherwise packN would be too strict.+       -}+       where+          go = Strict.arguments2 $ \p n -> \a0 ->+             if n == i+               then return (0, n, g a0)+               else+                 case f a0 of+                   Left c -> return (0, n, c)+                   Right (b,a1) -> do poke p b+                                      go (incPtr p) (n+1) a1+{-# INLINE unfoldrResultN #-}++unfoldlN :: (Storable b) => Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a)+unfoldlN i f x0+    | i < 0     = (empty, Just x0)+    | otherwise = Unsafe.performIO $ createAndTrim' i $ \p -> go (p `advancePtr` i) i x0+  where go = Strict.arguments2 $ \p n -> \x ->+           if n == 0+             then return (n, i, Just x)+             else+               case f x of+                 Nothing     -> return (n, i, Nothing)+                 Just (w,x') ->+                    let p' = p `advancePtr` (-1)+                    in  do poke p' w+                           go p' (n-1) x'+{-# INLINE unfoldlN #-}+++-- | /O(n)/, where /n/ is the length of the result.+-- This function constructs a vector by evaluating a function+-- that depends on the element index.+-- It is a special case of 'unfoldrN' and can in principle be parallelized.+--+-- Examples:+--+-- >    sample 26 (\x -> chr(ord 'a'+x))+-- > == pack "abcdefghijklmnopqrstuvwxyz"+--+sample :: (Storable a) => Int -> (Int -> a) -> Vector a+sample n f =+   fst $ unfoldrN n (\i -> Just (f i, succ i)) 0+{-# INLINE sample #-}+++-- ---------------------------------------------------------------------+-- Substrings++-- | /O(1)/ 'take' @n@, applied to a 'Vector' @xs@, returns the prefix+-- of @xs@ of length @n@, or @xs@ itself if @n > 'length' xs@.+take :: (Storable a) => Int -> Vector a -> Vector a+take n ps@(SV x s l)+    | n <= 0    = empty+    | n >= l    = ps+    | otherwise = SV x s n+{-# INLINE take #-}++-- | /O(1)/ 'drop' @n xs@ returns the suffix of @xs@ after the first @n@+-- elements, or 'empty' if @n > 'length' xs@.+drop  :: (Storable a) => Int -> Vector a -> Vector a+drop n ps@(SV x s l)+    | n <= 0    = ps+    | n >= l    = empty+    | otherwise = SV x (s+n) (l-n)+{-# INLINE drop #-}++-- | /O(1)/ 'splitAt' @n xs@ is equivalent to @('take' n xs, 'drop' n xs)@.+splitAt :: (Storable a) => Int -> Vector a -> (Vector a, Vector a)+splitAt n ps@(SV x s l)+    | n <= 0    = (empty, ps)+    | n >= l    = (ps, empty)+    | otherwise = (SV x s n, SV x (s+n) (l-n))+{-# INLINE splitAt #-}++-- | 'takeWhile', applied to a predicate @p@ and a 'Vector' @xs@,+-- returns the longest prefix (possibly empty) of @xs@ of elements that+-- satisfy @p@.+takeWhile :: (Storable a) => (a -> Bool) -> Vector a -> Vector a+takeWhile f ps = unsafeTake (findIndexOrEnd (not . f) ps) ps+{-# INLINE takeWhile #-}++-- | 'dropWhile' @p xs@ returns the suffix remaining after 'takeWhile' @p xs@.+dropWhile :: (Storable a) => (a -> Bool) -> Vector a -> Vector a+dropWhile f ps = unsafeDrop (findIndexOrEnd (not . f) ps) ps+{-# INLINE dropWhile #-}++-- | 'break' @p@ is equivalent to @'span' ('not' . p)@.+break :: (Storable a) => (a -> Bool) -> Vector a -> (Vector a, Vector a)+break p ps = case findIndexOrEnd p ps of n -> (unsafeTake n ps, unsafeDrop n ps)+{-# INLINE break #-}++-- | 'breakEnd' behaves like 'break' but from the end of the 'Vector'+--+-- breakEnd p == spanEnd (not.p)+breakEnd :: (Storable a) => (a -> Bool) -> Vector a -> (Vector a, Vector a)+breakEnd  p ps = splitAt (findFromEndUntil p ps) ps++-- | 'span' @p xs@ breaks the 'Vector' into two segments. It is+-- equivalent to @('takeWhile' p xs, 'dropWhile' p xs)@+span :: (Storable a) => (a -> Bool) -> Vector a -> (Vector a, Vector a)+span p ps = break (not . p) ps+{-# INLINE span #-}++-- | 'spanEnd' behaves like 'span' but from the end of the 'Vector'.+-- We have+--+-- > spanEnd (not.isSpace) "x y z" == ("x y ","z")+--+-- and+--+-- > spanEnd (not . isSpace) ps+-- >    ==+-- > let (x,y) = span (not.isSpace) (reverse ps) in (reverse y, reverse x)+--+spanEnd :: (Storable a) => (a -> Bool) -> Vector a -> (Vector a, Vector a)+spanEnd  p ps = splitAt (findFromEndUntil (not.p) ps) ps++-- | /O(n)/ Splits a 'Vector' into components delimited by+-- separators, where the predicate returns True for a separator element.+-- The resulting components do not contain the separators.  Two adjacent+-- separators result in an empty component in the output.  eg.+--+-- > splitWith (=='a') "aabbaca" == ["","","bb","c",""]+-- > splitWith (=='a') []        == []+--+splitWith :: (Storable a) => (a -> Bool) -> Vector a -> [Vector a]+splitWith _ (SV _ _ 0) = []+splitWith p ps = loop ps+    where+        loop =+           uncurry (:) .+           mapSnd (switchL [] (\ _ t -> loop t)) .+           break p+{-# INLINE splitWith #-}++-- | /O(n)/ Break a 'Vector' into pieces separated by the+-- argument, consuming the delimiter. I.e.+--+-- > split '\n' "a\nb\nd\ne" == ["a","b","d","e"]+-- > split 'a'  "aXaXaXa"    == ["","X","X","X"]+-- > split 'x'  "x"          == ["",""]+--+-- and+--+-- > join [c] . split c == id+-- > split == splitWith . (==)+--+-- As for all splitting functions in this library, this function does+-- not copy the substrings, it just constructs new 'Vector's that+-- are slices of the original.+--+split :: (Storable a, Eq a) => a -> Vector a -> [Vector a]+split w v = splitWith (w==) v+{-# INLINE split #-}++-- | Like 'splitWith', except that sequences of adjacent separators are+-- treated as a single separator. eg.+--+-- > tokens (=='a') "aabbaca" == ["bb","c"]+--+tokens :: (Storable a) => (a -> Bool) -> Vector a -> [Vector a]+tokens f = P.filter (not.null) . splitWith f+{-# INLINE tokens #-}++-- | The 'group' function takes a 'Vector' and returns a list of+-- 'Vector's such that the concatenation of the result is equal to the+-- argument.  Moreover, each sublist in the result contains only equal+-- elements.  For example,+--+-- > group "Mississippi" = ["M","i","ss","i","ss","i","pp","i"]+--+-- It is a special case of 'groupBy', which allows the programmer to+-- supply their own equality test. It is about 40% faster than+-- /groupBy (==)/+group :: (Storable a, Eq a) => Vector a -> [Vector a]+group xs =+   switchL []+      (\ h _ ->+          let (ys, zs) = span (== h) xs+          in  ys : group zs)+      xs++-- | The 'groupBy' function is the non-overloaded version of 'group'.+groupBy :: (Storable a) => (a -> a -> Bool) -> Vector a -> [Vector a]+groupBy k xs =+   switchL []+      (\ h t ->+          let n = 1 + findIndexOrEnd (not . k h) t+          in  unsafeTake n xs : groupBy k (unsafeDrop n xs))+      xs+{-# INLINE groupBy #-}+++-- | /O(n)/ The 'join' function takes a 'Vector' and a list of+-- 'Vector's and concatenates the list after interspersing the first+-- argument between each element of the list.+join :: (Storable a) => Vector a -> [Vector a] -> Vector a+join s = concat . List.intersperse s+{-# INLINE join #-}++-- ---------------------------------------------------------------------+-- Indexing 'Vector's++-- | /O(1)/ 'Vector' index (subscript) operator, starting from 0.+index :: (Storable a) => Vector a -> Int -> a+index ps n+    | n < 0          = moduleError "index" ("negative index: " ++ show n)+    | n >= length ps = moduleError "index" ("index too large: " ++ show n+                                         ++ ", length = " ++ show (length ps))+    | otherwise      = ps `unsafeIndex` n+{-# INLINE index #-}++-- | /O(n)/ The 'elemIndex' function returns the index of the first+-- element in the given 'Vector' which is equal to the query+-- element, or 'Nothing' if there is no such element.+elemIndex :: (Storable a, Eq a) => a -> Vector a -> Maybe Int+elemIndex c = findIndex (c==)+{-# INLINE elemIndex #-}++-- | /O(n)/ The 'elemIndexEnd' function returns the last index of the+-- element in the given 'Vector' which is equal to the query+-- element, or 'Nothing' if there is no such element. The following+-- holds:+--+-- > elemIndexEnd c xs ==+-- > (-) (length xs - 1) `fmap` elemIndex c (reverse xs)+--+elemIndexEnd :: (Storable a, Eq a) => a -> Vector a -> Maybe Int+elemIndexEnd c =+   fst .+   foldl+      (\(ri,i) x -> (if c==x then Just i else ri, succ i))+      (Nothing,0)+{-# INLINE elemIndexEnd #-}++-- | /O(n)/ The 'elemIndices' function extends 'elemIndex', by returning+-- the indices of all elements equal to the query element, in ascending order.+elemIndices :: (Storable a, Eq a) => a -> Vector a -> [Int]+elemIndices c = findIndices (c==)+{-# INLINE elemIndices #-}++-- | count returns the number of times its argument appears in the 'Vector'+--+-- > count = length . elemIndices+--+-- But more efficiently than using length on the intermediate list.+count :: (Storable a, Eq a) => a -> Vector a -> Int+count w =+   foldl (flip $ \c -> if c==w then succ else id) 0+{-+count w sv =+   List.length $ elemIndices w sv+-}+{-# INLINE count #-}++-- | The 'findIndex' function takes a predicate and a 'Vector' and+-- returns the index of the first element in the 'Vector'+-- satisfying the predicate.+findIndex :: (Storable a) => (a -> Bool) -> Vector a -> Maybe Int+findIndex p xs =+   {- The implementation is in principle the same as for findIndices,+      but we use the First monoid, instead of the List/append monoid.+      We could also implement findIndex in terms of monoidConcatMap. -}+   foldr+      (\x k n ->+         toMaybe (p x) n `mplus` k (succ n))+      (const Nothing) xs 0+{-# INLINE findIndex #-}++-- | The 'findIndices' function extends 'findIndex', by returning the+-- indices of all elements satisfying the predicate, in ascending order.+findIndices :: (Storable a) => (a -> Bool) -> Vector a -> [Int]+findIndices p xs =+   foldr+      (\x k n ->+         (if p x then (n:) else id)+            (k (succ n)))+      (const []) xs 0+{-# INLINE findIndices #-}++-- | 'findIndexOrEnd' is a variant of findIndex, that returns the length+-- of the string if no element is found, rather than Nothing.+findIndexOrEnd :: (Storable a) => (a -> Bool) -> Vector a -> Int+findIndexOrEnd p xs =+   foldr+      (\x k n ->+         if p x then n else k (succ n))+      id xs 0+{-# INLINE findIndexOrEnd #-}++-- ---------------------------------------------------------------------+-- Searching Vectors++-- | /O(n)/ 'elem' is the 'Vector' membership predicate.+elem :: (Storable a, Eq a) => a -> Vector a -> Bool+elem c ps = isJust $ elemIndex c ps+{-# INLINE elem #-}++-- | /O(n)/ 'notElem' is the inverse of 'elem'+notElem :: (Storable a, Eq a) => a -> Vector a -> Bool+notElem c ps = not (elem c ps)+{-# INLINE notElem #-}++-- | /O(n)/ 'filter', applied to a predicate and a 'Vector',+-- returns a 'Vector' containing those elements that satisfy the+-- predicate. This function is subject to array fusion.+filter :: (Storable a) => (a -> Bool) -> Vector a -> Vector a+filter p (SV fp s l) =+   let end = s+l+   in  fst $+       unfoldrN l+          (let go = Strict.arguments1 $ \k0 ->+                  do guard (k0<end)+                     let x = foreignPeek fp k0+                         k1 = succ k0+                     if p x+                       then Just (x,k1)+                       else go k1+           in  go)+          s+{-# 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 == unsafeTake l1 y++-- | /O(n)/ The 'isSuffixOf' function takes two 'Vector's and returns 'True'+-- iff the first is a suffix of the second.+--+-- The following holds:+--+-- > isSuffixOf x y == reverse x `isPrefixOf` reverse y+--+isSuffixOf :: (Storable a, Eq a) => Vector a -> Vector a -> Bool+isSuffixOf x@(SV _ _ l1) y@(SV _ _ l2) =+    l1 <= l2 && x == unsafeDrop (l2 - l1) y++-- ---------------------------------------------------------------------+-- Zipping++-- | /O(n)/ 'zip' takes two 'Vector's and returns a list of+-- corresponding pairs of elements. If one input 'Vector' is short,+-- excess elements of the longer 'Vector' are discarded. This is+-- equivalent to a pair of 'unpack' operations.+zip :: (Storable a, Storable b) => Vector a -> Vector b -> [(a, b)]+zip ps qs =+   maybe [] id $+      do (ph,pt) <- viewL ps+         (qh,qt) <- viewL qs+         return ((ph,qh) : zip pt qt)++-- | 'zipWith' generalises 'zip' by zipping with the function given as+-- the first argument, instead of a tupling function.  For example,+-- @'zipWith' (+)@ is applied to two 'Vector's to produce the list of+-- corresponding sums.+zipWith :: (Storable a, Storable b, Storable c) =>+   (a -> b -> c) -> Vector a -> Vector b -> Vector c+zipWith f as bs =+   unsafeWithStartPtr as $ \pa0 la ->+   withStartPtr       bs $ \pb0 lb ->+   let len = min la lb+   in  create len $ \p0 ->+       let go = Strict.arguments4 $ \n p pa pb ->+              when (n>0) $+                 liftM2 f (peek pa) (peek pb) >>= poke p >>+                 go (pred n) (incPtr p) (incPtr pa) (incPtr pb)+       in  go len p0 pa0 pb0+++-- zipWith f ps qs = pack $ List.zipWith f (unpack ps) (unpack qs)+{-# INLINE zipWith #-}++-- | Like 'zipWith' but for three input vectors+zipWith3 :: (Storable a, Storable b, Storable c, Storable d) =>+   (a -> b -> c -> d) -> Vector a -> Vector b -> Vector c -> Vector d+zipWith3 f as bs cs =+   unsafeWithStartPtr as $ \pa0 la ->+   withStartPtr       bs $ \pb0 lb ->+   withStartPtr       cs $ \pc0 lc ->+   let len = la `min` lb `min` lc+   in  create len $ \p0 ->+       let go = Strict.arguments5 $ \n p pa pb pc ->+              when (n>0) $+                 liftM3 f (peek pa) (peek pb) (peek pc) >>= poke p >>+                 go (pred n) (incPtr p) (incPtr pa) (incPtr pb) (incPtr pc)+       in  go len p0 pa0 pb0 pc0+{-# INLINE zipWith3 #-}++-- | Like 'zipWith' but for four input vectors+-- If you need even more input vectors,+-- you might write a function yourselve using unfoldrN and viewL.+zipWith4 :: (Storable a, Storable b, Storable c, Storable d, Storable e) =>+   (a -> b -> c -> d -> e) -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e+zipWith4 f as bs cs ds =+   unsafeWithStartPtr as $ \pa0 la ->+   withStartPtr       bs $ \pb0 lb ->+   withStartPtr       cs $ \pc0 lc ->+   withStartPtr       ds $ \pd0 ld ->+   let len = la `min` lb `min` lc `min` ld+   in  create len $ \p0 ->+       let go =+              Strict.arguments2 $ \n p ->+              Strict.arguments4 $ \pa pb pc pd ->+              when (n>0) $+                 liftM4 f (peek pa) (peek pb) (peek pc) (peek pd) >>= poke p >>+                 go (pred n) (incPtr p) (incPtr pa) (incPtr pb) (incPtr pc) (incPtr pd)+       in  go len p0 pa0 pb0 pc0 pd0+{-# INLINE zipWith4 #-}++-- | /O(n)/ 'unzip' transforms a list of pairs of elements into a pair of+-- 'Vector's. Note that this performs two 'pack' operations.+unzip :: (Storable a, Storable b) => [(a, b)] -> (Vector a, Vector b)+unzip ls = (pack (P.map fst ls), pack (P.map snd ls))+{-# INLINE unzip #-}++-- ---------------------------------------------------------------------+-- Interleaved 'Vector's++-- | /O(l/n)/ 'sieve' selects every 'n'th element.+sieve :: (Storable a) => Int -> Vector a -> Vector a+sieve n (SV fp s l) =+   let end = s+l+   in  fst $+       unfoldrN (- div (-l) n)+          (Strict.arguments1 $ \k0 ->+              do guard (k0<end)+                 Just (foreignPeek fp k0, k0 + n))+          s+{-# INLINE sieve #-}++-- | /O(n)/+-- Returns n sieved vectors with successive starting elements.+-- @deinterleave 3 (pack ['a'..'k']) = [pack "adgj", pack "behk", pack "cfi"]@+-- This is the same as 'Data.List.HT.sliceHorizontal'.+deinterleave :: (Storable a) => Int -> Vector a -> [Vector a]+deinterleave n =+   P.map (sieve n) . P.take n . P.iterate laxTail++-- | /O(n)/+-- Almost the inverse of deinterleave.+-- Restriction is that all input vector must have equal length.+-- @interleave [pack "adgj", pack "behk", pack "cfil"] = pack ['a'..'l']@+interleave :: (Storable a) => [Vector a] -> Vector a+interleave vs =+   Unsafe.performIO $+   MC.runContT+      (do+         pls <- mapM (\v -> MC.ContT (withStartPtr v . curry)) vs+         let (ps,ls) = P.unzip pls+         ptrs <- MC.ContT (withArray ps)+         if and (ListHT.mapAdjacent (==) ls)+           then return (ptrs, P.sum ls)+           else moduleError "interleave" "all input vectors must have the same length")+      (\(ptrs, totalLength) -> create totalLength $ \p ->+         let n = P.length vs+             pEnd = advancePtr p totalLength+             go = Strict.arguments3 $ \k0 j p0 -> do+                poke p0 =<< flip peekElemOff j =<< peekElemOff ptrs k0+                let p1 = advancePtr p0 1+                    k1 = succ k0+                when (p1 < pEnd) $+                   if k1 < n+                     then go k1 j p1+                     else go 0 (succ j) p1+         in  go 0 0 p)+{-# INLINE interleave #-}+++-- ---------------------------------------------------------------------+-- Special lists++-- | /O(n)/ Return all initial segments of the given 'Vector', shortest first.+inits :: (Storable a) => Vector a -> [Vector a]+inits (SV x s l) = List.map (SV x s) [0..l]++-- | /O(n)/ Return all final segments of the given 'Vector', longest first.+tails :: (Storable a) => Vector a -> [Vector a]+tails p =+   switchL [empty] (\ _ t -> p : tails t) p++-- ---------------------------------------------------------------------+-- ** Ordered 'Vector's++-- ---------------------------------------------------------------------+-- Low level constructors++-- | /O(n)/ Make a copy of the 'Vector' with its own storage.+--   This is mainly useful to allow the rest of the data pointed+--   to by the 'Vector' to be garbage collected, for example+--   if a large string has been read in, and only a small part of it+--   is needed in the rest of the program.+copy :: (Storable a) => Vector a -> Vector a+copy v =+   unsafeWithStartPtr v $ \f l ->+   create l $ \p ->+   copyArray p f (fromIntegral l)++++-- ---------------------------------------------------------------------+-- IO++-- | Outputs a 'Vector' to the specified 'Handle'.+hPut :: (Storable a) => Handle -> Vector a -> IO ()+hPut h v =+   when (not (null v)) $+      withStartPtr v $ \ ptrS l ->+         let ptrE = advancePtr ptrS l+             -- use advancePtr and minusPtr in order to respect alignment+         in  hPutBuf h ptrS (minusPtr ptrE ptrS)++-- | Read a 'Vector' directly from the specified 'Handle'.  This+-- is far more efficient than reading the characters into a list+-- and then using 'pack'.+--+hGet :: (Storable a) => Handle -> Int -> IO (Vector a)+hGet _ 0 = return empty+hGet h l =+   createAndTrim l $ \p ->+      let elemType :: Ptr a -> a+          elemType _ = undefined+          roundUp m n = n + mod (-n) m+          sizeOfElem =+             roundUp+                (alignment (elemType p))+                (sizeOf (elemType p))+      in  fmap (flip div sizeOfElem) $+          hGetBuf h p (l * sizeOfElem)+{-+   createAndTrim l $ \p ->+      fmap (flip div (incPtr p `minusPtr` p)) $+      hGetBuf h p (advancePtr p l `minusPtr` p)+-}++-- | Read an entire file strictly into a 'Vector'.  This is far more+-- efficient than reading the characters into a 'String' and then using+-- 'pack'.  It also may be more efficient than opening the file and+-- reading it using hGet. Files are read using 'binary mode' on Windows.+--+readFile :: (Storable a) => FilePath -> IO (Vector a)+readFile f =+   bracket (openBinaryFile f ReadMode) hClose+      (\h -> hGet h . fromIntegral =<< hFileSize h)++-- | Write a 'Vector' to a file.+writeFile :: (Storable a) => FilePath -> Vector a -> IO ()+writeFile f txt =+   bracket (openBinaryFile f WriteMode) hClose+      (\h -> hPut h txt)++-- | Append a 'Vector' to a file.+appendFile :: (Storable a) => FilePath -> Vector a -> IO ()+appendFile f txt =+   bracket (openBinaryFile f AppendMode) hClose+      (\h -> hPut h txt)+++-- ---------------------------------------------------------------------+-- Internal utilities+++-- These definitions of succ and pred do not check for overflow+-- and are faster than their counterparts from Enum class.+succ :: Int -> Int+succ n = n+1+{-# INLINE succ #-}++pred :: Int -> Int+pred n = n-1+{-# INLINE pred #-}++unsafeWithStartPtr :: Storable a => Vector a -> (Ptr a -> Int -> IO b) -> b+unsafeWithStartPtr v f =+   Unsafe.performIO (withStartPtr v f)+{-# INLINE unsafeWithStartPtr #-}++foreignPeek :: Storable a => ForeignPtr a -> Int -> a+foreignPeek fp k =+   inlinePerformIO $ withForeignPtr fp $ flip peekElemOff k+{-# INLINE foreignPeek #-}++withNonEmptyVector ::+   String -> (ForeignPtr a -> Int -> Int -> b) -> Vector a -> b+withNonEmptyVector fun f (SV x s l) =+   if l <= 0+     then errorEmpty fun+     else f x s l+{-# INLINE withNonEmptyVector #-}++-- Common up near identical calls to `error' to reduce the number+-- constant strings created when compiled:+errorEmpty :: String -> a+errorEmpty fun = moduleError fun "empty Vector"+{-# NOINLINE errorEmpty #-}++moduleError :: String -> String -> a+moduleError fun msg = error ("Data.StorableVector." ++ fun ++ ':':' ':msg)+{-# NOINLINE moduleError #-}++-- Find from the end of the string using predicate+findFromEndUntil :: (Storable a) => (a -> Bool) -> Vector a -> Int+findFromEndUntil = Strict.arguments2 $ \f ps@(SV x s l) ->+    if null ps then 0+    else if f (last ps) then l+         else findFromEndUntil f (SV x s (l-1))
+ src/Data/StorableVector/Base.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE DeriveDataTypeable #-}+--+-- Module      : Data.StorableVector.Base+-- License     : BSD-style+-- Maintainer  : dons@cse.unsw.edu.au+-- Stability   : experimental+-- Portability : portable, requires ffi and cpp+-- Tested with : GHC 6.4.1 and Hugs March 2005+-- ++-- | A module containing semi-public StorableVector internals. This exposes+-- the StorableVector representation and low level construction functions.+-- Modules which extend the StorableVector system will need to use this module+-- while ideally most users will be able to make do with the public interface+-- modules.+--+module Data.StorableVector.Base (++        -- * The @Vector@ type and representation+        Vector(..),             -- instances: Eq, Ord, Show, Read, Data, Typeable++        -- * Unchecked access+        unsafeHead,             -- :: Vector a -> a+        unsafeTail,             -- :: Vector a -> Vector a+        unsafeLast,             -- :: Vector a -> a+        unsafeInit,             -- :: Vector a -> Vector a+        unsafeIndex,            -- :: Vector a -> Int -> a+        unsafeTake,             -- :: Int -> Vector a -> Vector a+        unsafeDrop,             -- :: Int -> Vector a -> Vector a++        -- * Low level introduction and elimination+        create,                 -- :: Int -> (Ptr a -> IO ()) -> IO (Vector a)+        createAndTrim,          -- :: Int -> (Ptr a -> IO Int) -> IO (Vector a)+        createAndTrim',         -- :: Int -> (Ptr a -> IO (Int, Int, b)) -> IO (Vector a, b)++        unsafeCreate,           -- :: Int -> (Ptr a -> IO ()) ->  Vector a++        fromForeignPtr,         -- :: ForeignPtr a -> Int -> Vector a+        toForeignPtr,           -- :: Vector a -> (ForeignPtr a, Int, Int)+        withStartPtr,           -- :: Vector a -> (Ptr a -> Int -> IO b) -> IO b+        incPtr,                 -- :: Ptr a -> Ptr a++        inlinePerformIO++  ) where++import Foreign.Ptr              (Ptr)+import Foreign.ForeignPtr       (ForeignPtr, withForeignPtr, )+import Foreign.Marshal.Array    (advancePtr, copyArray)+import Foreign.Storable         (Storable(peekElemOff))++import Data.StorableVector.Memory (mallocForeignPtrArray, )++import Control.Exception        (assert)++#if defined(__GLASGOW_HASKELL__)+import Data.Generics            (Data, Typeable)+import GHC.Base                 (realWorld#)+import GHC.IO                   (IO(IO), )+#endif++import qualified System.Unsafe as Unsafe++-- CFILES stuff is Hugs only+{-# CFILES cbits/fpstring.c #-}++-- -----------------------------------------------------------------------------++-- | A space-efficient representation of a vector, supporting many efficient+-- operations.+--+-- Instances of Eq, Ord, Read, Show, Data, Typeable+--+data Vector a = SV {-# UNPACK #-} !(ForeignPtr a)+                   {-# UNPACK #-} !Int                -- offset+                   {-# UNPACK #-} !Int                -- length+#if defined(__GLASGOW_HASKELL__)+    deriving (Data, Typeable)+#endif++-- ---------------------------------------------------------------------+--+-- Extensions to the basic interface+--++-- | A variety of 'head' for non-empty Vectors. 'unsafeHead' omits the+-- check for the empty case, so there is an obligation on the programmer+-- to provide a proof that the Vector is non-empty.+unsafeHead :: (Storable a) => Vector a -> a+unsafeHead (SV x s l) = assert (l > 0) $+    inlinePerformIO $ withForeignPtr x $ \p -> peekElemOff p s+{-# INLINE unsafeHead #-}++-- | A variety of 'tail' for non-empty Vectors. 'unsafeTail' omits the+-- check for the empty case. As with 'unsafeHead', the programmer must+-- provide a separate proof that the Vector is non-empty.+unsafeTail :: (Storable a) => Vector a -> Vector a+unsafeTail (SV ps s l) = assert (l > 0) $ SV ps (s+1) (l-1)+{-# INLINE unsafeTail #-}++-- | A variety of 'last' for non-empty Vectors. 'unsafeLast' omits the+-- check for the empty case, so there is an obligation on the programmer+-- to provide a proof that the Vector is non-empty.+unsafeLast :: (Storable a) => Vector a -> a+unsafeLast (SV x s l) = assert (l > 0) $+    inlinePerformIO $ withForeignPtr x $ \p -> peekElemOff p (s+l-1)+{-# INLINE unsafeLast #-}++-- | A variety of 'init' for non-empty Vectors. 'unsafeInit' omits the+-- check for the empty case. As with 'unsafeLast', the programmer must+-- provide a separate proof that the Vector is non-empty.+unsafeInit :: (Storable a) => Vector a -> Vector a+unsafeInit (SV ps s l) = assert (l > 0) $ SV ps s (l-1)+{-# INLINE unsafeInit #-}++-- | Unsafe 'Vector' index (subscript) operator, starting from 0, returning a+-- single element.  This omits the bounds check, which means there is an+-- accompanying obligation on the programmer to ensure the bounds are checked in+-- some other way.+unsafeIndex :: (Storable a) => Vector a -> Int -> a+unsafeIndex (SV x s l) i = assert (i >= 0 && i < l) $+    inlinePerformIO $ withForeignPtr x $ \p -> peekElemOff p (s+i)+{-# INLINE unsafeIndex #-}++-- | A variety of 'take' which omits the checks on @n@ so there is an+-- obligation on the programmer to provide a proof that @0 <= n <= 'length' xs@.+unsafeTake :: (Storable a) => Int -> Vector a -> Vector a+unsafeTake n (SV x s l) = assert (0 <= n && n <= l) $ SV x s n+{-# INLINE unsafeTake #-}++-- | A variety of 'drop' which omits the checks on @n@ so there is an+-- obligation on the programmer to provide a proof that @0 <= n <= 'length' xs@.+unsafeDrop :: (Storable a) => Int -> Vector a -> Vector a+unsafeDrop n (SV x s l) = assert (0 <= n && n <= l) $ SV x (s+n) (l-n)+{-# INLINE unsafeDrop #-}+++instance (Storable a, Show a) => Show (Vector a) where+   showsPrec p xs@(SV _ _ l) =+      showParen (p>=10)+         (showString "Vector.pack " .+          showsPrec 10 (map (unsafeIndex xs) [0..(l-1)]))+++-- ---------------------------------------------------------------------+-- Low level constructors++-- | /O(1)/ Build a Vector from a ForeignPtr+fromForeignPtr :: ForeignPtr a -> Int -> Vector a+fromForeignPtr fp l = SV fp 0 l++-- | /O(1)/ Deconstruct a ForeignPtr from a Vector+toForeignPtr :: Vector a -> (ForeignPtr a, Int, Int)+toForeignPtr (SV ps s l) = (ps, s, l)++-- | Run an action that is initialized+-- with a pointer to the first element to be used.+withStartPtr :: Storable a => Vector a -> (Ptr a -> Int -> IO b) -> IO b+withStartPtr (SV x s l) f =+   withForeignPtr x $ \p -> f (p `advancePtr` s) l+{-# INLINE withStartPtr #-}++incPtr :: (Storable a) => Ptr a -> Ptr a+incPtr v = advancePtr v 1+{-# INLINE incPtr #-}++-- | A way of creating Vectors outside the IO monad. The @Int@+-- argument gives the final size of the Vector. Unlike+-- 'createAndTrim' the Vector is not reallocated if the final size+-- is less than the estimated size.+unsafeCreate :: (Storable a) => Int -> (Ptr a -> IO ()) -> Vector a+unsafeCreate l f = Unsafe.performIO (create l f)+{-# INLINE unsafeCreate #-}++-- | Wrapper of mallocForeignPtrArray.+create :: (Storable a) => Int -> (Ptr a -> IO ()) -> IO (Vector a)+create l f = do+    fp <- mallocForeignPtrArray l+    withForeignPtr fp $ \p -> f p+    return $! SV fp 0 l++-- | Given the maximum size needed and a function to make the contents+-- of a Vector, createAndTrim makes the 'Vector'. The generating+-- function is required to return the actual final size (<= the maximum+-- size), and the resulting byte array is realloced to this size.+--+-- createAndTrim is the main mechanism for creating custom, efficient+-- Vector functions, using Haskell or C functions to fill the space.+--+createAndTrim :: (Storable a) => Int -> (Ptr a -> IO Int) -> IO (Vector a)+createAndTrim l f = do+    fp <- mallocForeignPtrArray l+    withForeignPtr fp $ \p -> do+        l' <- f p+        if assert (l' <= l) $ l' >= l+            then return $! SV fp 0 l+            else create l' $ \p' -> copyArray p' p l'++createAndTrim' :: (Storable a) => Int +                               -> (Ptr a -> IO (Int, Int, b))+                               -> IO (Vector a, b)+createAndTrim' l f = do+    fp <- mallocForeignPtrArray l+    withForeignPtr fp $ \p -> do+        (off, l', res) <- f p+        if assert (l' <= l) $ l' >= l+            then return $! (SV fp 0 l, res)+            else do ps <- create l' $ \p' -> copyArray p' (p `advancePtr` off) l'+                    return $! (ps, res)++-- | Just like Unsafe.performIO, but we inline it. Big performance gains as+-- it exposes lots of things to further inlining. /Very unsafe/. In+-- particular, you should do no memory allocation inside an+-- 'inlinePerformIO' block. On Hugs this is just @Unsafe.performIO@.+--+{-# INLINE inlinePerformIO #-}+inlinePerformIO :: IO a -> a+#if defined(__GLASGOW_HASKELL__)+inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r+#else+inlinePerformIO = Unsafe.performIO+#endif
+ src/Data/StorableVector/Cursor.hs view
@@ -0,0 +1,353 @@+{-# LANGUAGE ExistentialQuantification #-}+{- |+Simulate a list with strict elements by a more efficient array structure.+-}+module Data.StorableVector.Cursor where++import Control.Exception        (assert, )+import Control.Monad.Trans.State (StateT(StateT), runStateT, )+import Data.IORef               (IORef, newIORef, readIORef, writeIORef, )++import Foreign.Storable         (Storable(peekElemOff, pokeElemOff))+import Foreign.ForeignPtr       (ForeignPtr, withForeignPtr, )+-- import Foreign.Ptr              (Ptr)+import Data.StorableVector.Memory (mallocForeignPtrArray, )++import Control.Monad            (when)+import Data.Maybe               (isNothing)++import qualified System.Unsafe as Unsafe++import qualified Data.List.HT as ListHT+import Data.Tuple.HT (mapSnd, )++import Prelude hiding (length, foldr, zipWith, take, drop, )+++{-+ToDo:+I think that the state should be Storable as well+and that the IORef should be replaced by a ForeignPtr.+I hope that this is more efficient.+With this restriction @s@ cannot be e.g. a function type+but this would kill performance anyway.+Functions that need this flexibility may fall back to other data structures+(lists or chunky StorableVectors) and convert to the Cursor structure later.+-}+-- | Cf. StreamFusion  Data.Stream+data Generator a =+   forall s. -- Seq s =>+      Generator+         !(StateT s Maybe a)  -- compute next value+         {-# UNPACK #-}+         !(IORef (Maybe s))   -- current state++{- |+This simulates a+@ data StrictList a = Elem !a (StrictList a) | End @+by an array and some unsafe hacks.+-}+data Buffer a =+   Buffer {+       memory :: {-# UNPACK #-} !(ForeignPtr a),+       size   :: {-# UNPACK #-} !Int,  -- size of allocated memory, I think I only need it for debugging+       gen    ::                !(Generator a),  -- we need this indirection for the existential type in Generator+       cursor :: {-# UNPACK #-} !(IORef Int)+   }++{- |+Vector is a part of a buffer.+-}+data Vector a =+   Vector {+       buffer :: {-# UNPACK #-} !(Buffer a),+       start  :: {-# UNPACK #-} !Int,   -- invariant: start <= cursor+       maxLen :: {-# UNPACK #-} !Int    -- invariant: start+maxLen <= size buffer+   }+++-- * construction++{-# INLINE create #-}+create :: (Storable a) => Int -> Generator a -> Buffer a+create l g = Unsafe.performIO (createIO l g)++-- | Wrapper of mallocForeignPtrArray.+createIO :: (Storable a) => Int -> Generator a -> IO (Buffer a)+createIO l g = do+    fp <- mallocForeignPtrArray l+    cur <- newIORef 0+    return $! Buffer fp l g cur+++{- |+@ unfoldrNTerm 20  (\n -> Just (n, succ n)) 'a' @+-}+unfoldrNTerm :: (Storable b) =>+   Int -> (a -> Maybe (b, a)) -> a -> Vector b+unfoldrNTerm l f x0 =+   Unsafe.performIO (unfoldrNTermIO l f x0)++unfoldrNTermIO :: (Storable b) =>+   Int -> (a -> Maybe (b, a)) -> a -> IO (Vector b)+unfoldrNTermIO l f x0 =+   do ref <- newIORef (Just x0)+      buf <- createIO l (Generator (StateT f) ref)+      return (Vector buf 0 l)++unfoldrN :: (Storable b) =>+   Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a)+unfoldrN l f x0 =+   Unsafe.performIO (unfoldrNIO l f x0)++unfoldrNIO :: (Storable b) =>+   Int -> (a -> Maybe (b, a)) -> a -> IO (Vector b, Maybe a)+unfoldrNIO l f x0 =+   do ref <- newIORef (Just x0)+      buf <- createIO l (Generator (StateT f) ref)+      s <- Unsafe.interleaveIO $+             do evaluateToIO l buf+                readIORef ref+      return (Vector buf 0 l, s)+{-+unfoldrNIO :: (Storable b) =>+   Int -> (a -> Maybe (b, a)) -> a -> IO (Vector b, Maybe a)+unfoldrNIO l f x0 =+   do y <- unfoldrNTermIO l f x0+--      evaluateTo l y+      let (Generator _ ref) = gen (buffer y)+      s <- readIORef ref+      return (y, s)++Data/StorableVector/Cursor.hs:98:10:+    My brain just exploded.+    I can't handle pattern bindings for existentially-quantified constructors.+    In the binding group+        (Generator _ ref) = gen (buffer y)+    In the definition of `unfoldrNIO':+        unfoldrNIO l f x0+                     = do+                         y <- unfoldrNTermIO l f x0+                         let (Generator _ ref) = gen (buffer y)+                         s <- readIORef ref+                         return (y, s)+-}+++{-+unfoldrN :: (Storable b) =>+   Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a)+unfoldrN i f x0 =+   let y = unfoldrNTerm i f x0+   in  (y, getFinalState y)++getFinalState :: (Storable b) =>+   Vector b -> Maybe a+getFinalState y =+   Unsafe.performIO $+      ...+-}+++{-# INLINE pack #-}+pack :: (Storable a) => Int -> [a] -> Vector a+pack n = unfoldrNTerm n ListHT.viewL+++{-# INLINE cons #-}+{- |+This is expensive and should not be used to construct lists iteratively!+A recursion-enabling 'cons' would be 'consN'+that allocates a buffer of given size,+initializes the leading cell and sets the buffer pointer to the next cell.+-}+cons :: Storable a =>+   a -> Vector a -> Vector a+cons x xs =+   unfoldrNTerm (succ (maxLen xs))+      (\(mx0,xs0) ->+          fmap (mapSnd ((,) Nothing)) $+          maybe+             (viewL xs0)+             (\x0 -> Just (x0, xs0))+             mx0) $+   (Just x, xs)+++{-# INLINE zipWith #-}+zipWith :: (Storable a, Storable b, Storable c) =>+   (a -> b -> c) -> Vector a -> Vector b -> Vector c+zipWith f ps0 qs0 =+   zipNWith (min (maxLen ps0) (maxLen qs0)) f ps0 qs0++-- zipWith f ps qs = pack $ List.zipWith f (unpack ps) (unpack qs)++{-# INLINE zipNWith #-}+zipNWith :: (Storable a, Storable b, Storable c) =>+   Int -> (a -> b -> c) -> Vector a -> Vector b -> Vector c+zipNWith n f ps0 qs0 =+   unfoldrNTerm n+      (\(ps,qs) ->+         do (ph,pt) <- viewL ps+            (qh,qt) <- viewL qs+            return (f ph qh, (pt,qt)))+      (ps0,qs0)+{-+let f2 = zipNWith 15 (+) f0 f1; f1 = cons 1 f2; f0 = cons (0::Int) f1 in f0++*Data.StorableVector.Cursor> let xs = unfoldrNTerm 20  (\n -> Just (n, succ n)) (0::Int)+*Data.StorableVector.Cursor> let ys = unfoldrNTerm 20  (\n -> Just (n, 2*n)) (1::Int)+*Data.StorableVector.Cursor> zipWith (+) xs ys+-}+++++-- * inspection++-- | evaluate next value in a buffer+advanceIO :: Storable a =>+   Buffer a -> IO (Maybe a)+advanceIO (Buffer p sz (Generator n s) cr) =+   do c <- readIORef cr+      assert (c < sz) $+         do writeIORef cr (succ c)+            ms <- readIORef s+            case ms of+               Nothing -> return Nothing+               Just s0 ->+                  case runStateT n s0 of+                     Nothing ->+                        writeIORef s Nothing >>+                        return Nothing+                     Just (a,s1) ->+                        writeIORef s (Just s1) >>+                        withForeignPtr p (\q -> pokeElemOff q c a) >>+                        return (Just a)++{-+It is tempting to turn this into a simple loop without the IORefs.+This could be compiled to an efficient strict loop,+but it would fail if the vector content depends on its own,+like in @fix (consN 1000 'a')@.+-}+-- | evaluate all values up to a given position+evaluateToIO :: Storable a =>+   Int -> Buffer a -> IO ()+evaluateToIO l buf@(Buffer _p _sz _g cr) =+   whileM+      (fmap (<l) (readIORef cr))+      (advanceIO buf)++whileM :: Monad m => m Bool -> m a -> m ()+whileM p f =+   let recourse =+          do b <- p+             when b (f >> recourse)+   in  recourse++{-# INLINE switchL #-}+switchL :: Storable a => b -> (a -> Vector a -> b) -> Vector a -> b+switchL n j v = maybe n (uncurry j) (viewL v)+++{-+If it returns False the list can be empty anyway.+-}+obviousNullIO :: Vector a -> IO Bool+obviousNullIO (Vector (Buffer _ _ (Generator _ s) _) _ ml) =+   assert (ml >= 0) $+   do b <- readIORef s+      return (ml == 0 || isNothing b)++{-+obviousNullIO :: Vector a -> IO Bool+obviousNullIO (Vector (Buffer _ sz (Generator _ s) _) st _) =+   do b <- readIORef s+      return (st >= sz || isNothing b)+-}+--   assert (l >= 0) $ l <= 0++{-# INLINE viewL #-}+viewL :: Storable a => Vector a -> Maybe (a, Vector a)+viewL v = Unsafe.performIO (viewLIO v)++{-# INLINE viewLIO #-}+viewLIO :: Storable a => Vector a -> IO (Maybe (a, Vector a))+viewLIO (Vector buf st ml) =+   do c <- readIORef (cursor buf)+      fmap (fmap (\a -> (a, Vector buf (succ st) (pred ml)))) $+        assert (st <= c) $+           if st == c+             then advanceIO buf+             else fmap Just $ withForeignPtr (memory buf) (\p -> peekElemOff p st)+++{-# INLINE foldr #-}+foldr :: (Storable a) => (a -> b -> b) -> b -> Vector a -> b+foldr k z =+   let recourse = switchL z (\h t -> k h (recourse t))+   in  recourse++-- | /O(n)/ Converts a 'Vector a' to a '[a]'.+{-# INLINE unpack #-}+unpack :: (Storable a) => Vector a -> [a]+unpack = foldr (:) []+++instance (Show a, Storable a) => Show (Vector a) where+   showsPrec p x = showsPrec p (unpack x)+++{-# INLINE null #-}+{-+This can hardly be simplified.+In order to check the list for emptiness,+we have to try to calculate the next element.+It is not enough to check whether the state is Nothing,+because when we try to compute the next value, this can be Nothing.+-}+null :: Storable a => Vector a -> Bool+null = switchL True (const (const False))+++{-+toVector :: Storable a => Vector a -> VS.Vector a+toVector v =+   VS.Cons (memory (buffer v)) ()+-}++-- length++drop :: (Storable a) => Int -> Vector a -> Vector a+drop n v = Unsafe.performIO $ dropIO n v++dropIO :: (Storable a) => Int -> Vector a -> IO (Vector a)+dropIO n v =+   assert (n>=0) $+    let pos = min (maxLen v) (start v + n)+    in  do evaluateToIO pos (buffer v)+           return (Vector (buffer v) pos (max 0 (maxLen v - n)))++take :: (Storable a) => Int -> Vector a -> Vector a+take n v =+   assert (n>=0) $+   v{maxLen = min n (maxLen v)}++{-+let x = unfoldrNTerm 10 (\c -> Just (c,succ c)) 'a'+let x = unfoldrNTerm 10 (\c -> Just (sum [c..100000],succ c)) (0::Int)+-}+++{- |+For the sake of laziness it may allocate considerably more memory than needed,+if it filters out very much.+-}+{-# INLINE filter #-}+filter :: (Storable a) => (a -> Bool) -> Vector a -> Vector a+filter p xs0 =+   unfoldrNTerm (maxLen xs0)+      (let recourse = switchL Nothing (\x xs -> if p x then Just (x,xs) else recourse xs)+       in  recourse)+      xs0
+ src/Data/StorableVector/Lazy.hs view
@@ -0,0 +1,1371 @@+{- |+Chunky signal stream build on StorableVector.++Hints for fusion:+ - Higher order functions should always be inlined in the end+   in order to turn them into machine loops+   instead of calling a function in an inner loop.+-}+module Data.StorableVector.Lazy where++import qualified Data.List as List+import qualified Data.StorableVector as V+import qualified Data.StorableVector.Base as VB+import qualified Data.StorableVector.Lazy.PointerPrivate as Ptr++import qualified Numeric.NonNegative.Class as NonNeg++import qualified Data.List.HT as ListHT+import Data.Tuple.HT (mapPair, mapFst, mapSnd, swap, )+import Data.Maybe.HT (toMaybe, )+import Data.Maybe (fromMaybe, )++import Foreign.Storable (Storable)++import Data.Monoid (Monoid, mempty, mappend, mconcat, )+-- import Control.Arrow ((***))+import Control.Monad (liftM, liftM2, liftM3, liftM4, {- guard, -} )+++import System.IO (openBinaryFile, IOMode(WriteMode, ReadMode, AppendMode),+                  hClose, Handle)+import Control.Exception (bracket, catch, )++import qualified System.IO.Error as Exc+import qualified System.Unsafe as Unsafe++import Test.QuickCheck (Arbitrary(..))+++{-+import Prelude hiding+   (length, (++), concat, iterate, foldl, map, repeat, replicate, null,+    zip, zipWith, zipWith3, drop, take, splitAt, takeWhile, dropWhile, reverse)+-}++import qualified Prelude as P++import Data.Either (Either(Left, Right), either, )+import Data.Maybe (Maybe(Just, Nothing), maybe, )+import Data.Function (const, flip, ($), (.), )+import Data.Tuple (fst, snd, uncurry, )+import Data.Bool (Bool(True,False), not, (&&), )+import Data.Ord (Ord, (<), (>), (<=), (>=), min, max, )+import Data.Eq (Eq, (==), )+import Control.Monad (mapM_, fmap, (=<<), (>>=), (>>), return, )+import Text.Show (Show, showsPrec, showParen, showString, show, )+import Prelude+   (IO, error, IOError,+    FilePath, String, succ,+    Num, Int, sum, (+), (-), divMod, mod, fromInteger, )++++newtype Vector a = SV {chunks :: [V.Vector a]}+++instance (Storable a) => Monoid (Vector a) where+    mempty  = empty+    mappend = append+    mconcat = concat++instance (Storable a, Eq a) => Eq (Vector a) where+   (==) = equal++instance (Storable a, Show a) => Show (Vector a) where+   showsPrec p xs =+      showParen (p>=10)+         (showString "VectorLazy.fromChunks " .+          showsPrec 10 (chunks xs))++instance (Storable a, Arbitrary a) => Arbitrary (Vector a) where+   arbitrary = liftM2 pack arbitrary arbitrary+++-- for a list of chunk sizes see "Data.StorableVector.LazySize".+newtype ChunkSize = ChunkSize Int+   deriving (Eq, Ord, Show)++instance Arbitrary ChunkSize where+   arbitrary = fmap (ChunkSize . max 1 . min 2048) arbitrary++{-+ToDo:+Since non-negative-0.1 we have the Monoid superclass for NonNeg.+Maybe we do not need the Num instance anymore.+-}+instance Num ChunkSize where+   (ChunkSize x) + (ChunkSize y)  =+       ChunkSize (x+y)+   (-)  =  moduleError "ChunkSize.-" "intentionally unimplemented"+   (*)  =  moduleError "ChunkSize.*" "intentionally unimplemented"+   abs  =  moduleError "ChunkSize.abs" "intentionally unimplemented"+   signum  =  moduleError "ChunkSize.signum" "intentionally unimplemented"+   fromInteger = ChunkSize . fromInteger++instance Monoid ChunkSize where+   mempty = ChunkSize 0+   mappend (ChunkSize x) (ChunkSize y) = ChunkSize (x+y)+   mconcat = ChunkSize . sum . List.map (\(ChunkSize c) -> c)++instance NonNeg.C ChunkSize where+   split = NonNeg.splitDefault (\(ChunkSize c) -> c) ChunkSize++chunkSize :: Int -> ChunkSize+chunkSize x =+   ChunkSize $+      if x>0+        then x+        else moduleError "chunkSize" ("no positive number: " List.++ show x)++defaultChunkSize :: ChunkSize+defaultChunkSize =+   ChunkSize 1024++++-- * Introducing and eliminating 'Vector's++{-# INLINE empty #-}+empty :: (Storable a) => Vector a+empty = SV []++{-# INLINE singleton #-}+singleton :: (Storable a) => a -> Vector a+singleton x = SV [V.singleton x]++fromChunks :: (Storable a) => [V.Vector a] -> Vector a+fromChunks = SV++pack :: (Storable a) => ChunkSize -> [a] -> Vector a+pack size = unfoldr size ListHT.viewL++unpack :: (Storable a) => Vector a -> [a]+unpack = List.concatMap V.unpack . chunks+++{-# INLINE packWith #-}+packWith :: (Storable b) => ChunkSize -> (a -> b) -> [a] -> Vector b+packWith size f =+   unfoldr size (fmap (mapFst f) . ListHT.viewL)++{-# INLINE unpackWith #-}+unpackWith :: (Storable a) => (a -> b) -> Vector a -> [b]+unpackWith f = List.concatMap (V.unpackWith f) . chunks+++{-# INLINE unfoldr #-}+unfoldr :: (Storable b) =>+   ChunkSize ->+   (a -> Maybe (b,a)) ->+   a ->+   Vector b+unfoldr (ChunkSize size) f =+   SV .+   List.unfoldr (cancelNullVector . V.unfoldrN size f =<<) .+   Just++{- |+Example:++> *Data.StorableVector.Lazy> unfoldrResult (ChunkSize 5) (\c -> if c>'z' then Left (Char.ord c) else Right (c, succ c)) 'a'+> (VectorLazy.fromChunks [Vector.pack "abcde",Vector.pack "fghij",Vector.pack "klmno",Vector.pack "pqrst",Vector.pack "uvwxy",Vector.pack "z"],123)+-}+{-# INLINE unfoldrResult #-}+unfoldrResult :: (Storable b) =>+   ChunkSize ->+   (a -> Either c (b, a)) ->+   a ->+   (Vector b, c)+unfoldrResult (ChunkSize size) f =+   let recourse a0 =+          let (chunk, a1) =+                 V.unfoldrResultN size Right (either (Left . Left) Right . f) a0+          in  either+                 ((,) (if V.null chunk then [] else [chunk]))+                 (mapFst (chunk :) . recourse) a1+   in  mapFst SV . recourse+++{-# INLINE sample #-}+sample :: (Storable a) => ChunkSize -> (Int -> a) -> Vector a+sample size f =+   unfoldr size (\i -> Just (f i, succ i)) 0++{-# INLINE sampleN #-}+sampleN :: (Storable a) => ChunkSize -> Int -> (Int -> a) -> Vector a+sampleN size n f =+   unfoldr size (\i -> toMaybe (i<n) (f i, succ i)) 0+++{-# INLINE iterate #-}+iterate :: Storable a => ChunkSize -> (a -> a) -> a -> Vector a+iterate size f = unfoldr size (\x -> Just (x, f x))++repeat :: Storable a => ChunkSize -> a -> Vector a+repeat (ChunkSize size) =+   SV . List.repeat . V.replicate size++cycle :: Storable a => Vector a -> Vector a+cycle =+   SV . List.cycle . chunks++replicate :: Storable a => ChunkSize -> Int -> a -> Vector a+replicate (ChunkSize size) n x =+   let (numChunks, rest) = divMod n size+   in  append+          (SV (List.replicate numChunks (V.replicate size x)))+          (fromChunk (V.replicate rest x))+++++-- * Basic interface++{-# INLINE null #-}+null :: (Storable a) => Vector a -> Bool+null = List.null . chunks++length :: Vector a -> Int+length = sum . List.map V.length . chunks++equal :: (Storable a, Eq a) => Vector a -> Vector a -> Bool+equal (SV xs0) (SV ys0) =+   let recourse (x:xs) (y:ys) =+          let l = min (V.length x) (V.length y)+              (xPrefix, xSuffix) = V.splitAt l x+              (yPrefix, ySuffix) = V.splitAt l y+              build z zs =+                 if V.null z then zs else z:zs+          in  xPrefix == yPrefix &&+              recourse (build xSuffix xs) (build ySuffix ys)+       recourse [] [] = True+       -- this requires that chunks will always be non-empty+       recourse _ _ = False+   in  recourse xs0 ys0++index :: (Storable a) => Vector a -> Int -> a+index (SV xs) n =+   if n < 0+     then+        moduleError "index"+           ("negative index: " List.++ show n)+     else+        List.foldr+           (\x k m0 ->+              let m1 = m0 - V.length x+              in  if m1 < 0+                    then VB.unsafeIndex x m0+                    else k m1)+           (\m -> moduleError "index"+                     ("index too large: " List.++ show n+                      List.++ ", length = " List.++ show (n-m)))+           xs n+++{-# NOINLINE [0] cons #-}+cons :: Storable a => a -> Vector a -> Vector a+cons x = SV . (V.singleton x :) . chunks++infixr 5 `append`++{-# NOINLINE [0] append #-}+append :: Storable a => Vector a -> Vector a -> Vector a+append (SV xs) (SV ys)  =  SV (xs List.++ ys)+++{- |+@extendL size x y@+prepends the chunk @x@ and merges it with the first chunk of @y@+if the total size is at most @size@.+This way you can prepend small chunks+while asserting a reasonable average size for chunks.+-}+extendL :: Storable a => ChunkSize -> V.Vector a -> Vector a -> Vector a+extendL (ChunkSize size) x (SV yt) =+   SV $+   maybe+      [x]+      (\(y,ys) ->+          if V.length x + V.length y <= size+            then V.append x y : ys+            else x:yt)+      (ListHT.viewL yt)+++concat :: (Storable a) => [Vector a] -> Vector a+concat = SV . List.concat . List.map chunks+++-- * Transformations++{-# INLINE map #-}+map :: (Storable x, Storable y) =>+      (x -> y)+   -> Vector x+   -> Vector y+map f = SV . List.map (V.map f) . chunks+++reverse :: Storable a => Vector a -> Vector a+reverse =+   SV . List.reverse . List.map V.reverse . chunks+++-- * Reducing 'Vector's++{-# INLINE foldl #-}+foldl :: Storable b => (a -> b -> a) -> a -> Vector b -> a+foldl f x0 = List.foldl (V.foldl f) x0 . chunks++{-# INLINE foldl' #-}+foldl' :: Storable b => (a -> b -> a) -> a -> Vector b -> a+foldl' f x0 = List.foldl' (V.foldl f) x0 . chunks++{-# INLINE foldr #-}+foldr :: Storable b => (b -> a -> a) -> a -> Vector b -> a+foldr f x0 = List.foldr (flip (V.foldr f)) x0 . chunks+++{-# INLINE monoidConcatMap #-}+monoidConcatMap :: (Storable a, Monoid m) => (a -> m) -> Vector a -> m+monoidConcatMap f =+   List.foldr (mappend . V.monoidConcatMap f) mempty . chunks++{-# INLINE any #-}+any :: (Storable a) => (a -> Bool) -> Vector a -> Bool+any p = List.any (V.any p) . chunks++{-# INLINE all #-}+all :: (Storable a) => (a -> Bool) -> Vector a -> Bool+all p = List.all (V.all p) . chunks++maximum :: (Storable a, Ord a) => Vector a -> a+maximum =+   List.maximum . List.map V.maximum . chunks+--   List.foldl1' max . List.map V.maximum . chunks++minimum :: (Storable a, Ord a) => Vector a -> a+minimum =+   List.minimum . List.map V.minimum . chunks+--   List.foldl1' min . List.map V.minimum . chunks++{-+sum :: (Storable a, Num a) => Vector a -> a+sum =+   List.sum . List.map V.sum . chunks++product :: (Storable a, Num a) => Vector a -> a+product =+   List.product . List.map V.product . chunks+-}+++-- * inspecting a vector++{-# INLINE pointer #-}+pointer :: Storable a => Vector a -> Ptr.Pointer a+pointer = Ptr.cons . chunks++{-# INLINE viewL #-}+viewL :: Storable a => Vector a -> Maybe (a, Vector a)+viewL (SV xs0) =+   do (x,xs) <- ListHT.viewL xs0+      (y,ys) <- V.viewL x+      return (y, append (fromChunk ys) (SV xs))++{-# INLINE viewR #-}+viewR :: Storable a => Vector a -> Maybe (Vector a, a)+viewR (SV xs0) =+   do xsp <- ListHT.viewR xs0+      let (xs,x) = xsp+{-+   do ~(xs,x) <- ListHT.viewR xs0+-}+      let (ys,y) = fromMaybe (moduleError "viewR" "last chunk empty") (V.viewR x)+      return (append (SV xs) (fromChunk ys), y)++{-# INLINE switchL #-}+switchL :: Storable a => b -> (a -> Vector a -> b) -> Vector a -> b+switchL n j =+   maybe n (uncurry j) . viewL++{-# INLINE switchR #-}+switchR :: Storable a => b -> (Vector a -> a -> b) -> Vector a -> b+switchR n j =+   maybe n (uncurry j) . viewR+++{-+viewLSafe :: Storable a => Vector a -> Maybe (a, Vector a)+viewLSafe (SV xs0) =+   -- dropWhile would be unnecessary if we require that all chunks are non-empty+   do (x,xs) <- ListHT.viewL (List.dropWhile V.null xs0)+      (y,ys) <- viewLVector x+      return (y, append (fromChunk ys) (SV xs))++viewRSafe :: Storable a => Vector a -> Maybe (Vector a, a)+viewRSafe (SV xs0) =+   -- dropWhile would be unnecessary if we require that all chunks are non-empty+   do (xs,x) <- ListHT.viewR (dropWhileRev V.null xs0)+      (ys,y) <- V.viewR x+      return (append (SV xs) (fromChunk ys), y)+-}+++{-# INLINE scanl #-}+scanl :: (Storable a, Storable b) =>+   (a -> b -> a) -> a -> Vector b -> Vector a+scanl f start =+   cons start . snd .+   mapAccumL (\acc -> (\b -> (b,b)) . f acc) start++{-# INLINE mapAccumL #-}+mapAccumL :: (Storable a, Storable b) =>+   (acc -> a -> (acc, b)) -> acc -> Vector a -> (acc, Vector b)+mapAccumL f start =+   mapSnd SV .+   List.mapAccumL (V.mapAccumL f) start .+   chunks++{-# INLINE mapAccumR #-}+mapAccumR :: (Storable a, Storable b) =>+   (acc -> a -> (acc, b)) -> acc -> Vector a -> (acc, Vector b)+mapAccumR f start =+   mapSnd SV .+   List.mapAccumR (V.mapAccumR f) start .+   chunks++{-# INLINE crochetLChunk #-}+crochetLChunk :: (Storable x, Storable y) =>+      (x -> acc -> Maybe (y, acc))+   -> acc+   -> V.Vector x+   -> (V.Vector y, Maybe acc)+crochetLChunk f acc0 x0 =+   mapSnd (fmap fst) $+   V.unfoldrN+      (V.length x0)+      (\(acc,xt) ->+         do (x,xs) <- V.viewL xt+            (y,acc') <- f x acc+            return (y, (acc',xs)))+      (acc0, x0)++{-# INLINE crochetL #-}+crochetL :: (Storable x, Storable y) =>+      (x -> acc -> Maybe (y, acc))+   -> acc+   -> Vector x+   -> Vector y+crochetL f acc0 =+   SV . List.unfoldr (\(xt,acc) ->+       do (x,xs) <- ListHT.viewL xt+          acc' <- acc+          return $ mapSnd ((,) xs) $ crochetLChunk f acc' x) .+   flip (,) (Just acc0) .+   chunks++++-- * sub-vectors++{-# INLINE take #-}+take :: (Storable a) => Int -> Vector a -> Vector a+{- this order of pattern matches is certainly the most lazy one+> take 4 (pack (chunkSize 2) $ "abcd" List.++ undefined)+VectorLazy.fromChunks [Vector.pack "ab",Vector.pack "cd"]+-}+take 0 _ = empty+take _ (SV []) = empty+take n (SV (x:xs)) =+   let m = V.length x+   in  if m<=n+         then SV $ (x:) $ chunks $ take (n-m) $ SV xs+         else fromChunk (V.take n x)++{- |+Take n values from the end of the vector in a memory friendly way.+@takeEnd n xs@ should perform the same as @drop (length xs - n) xs@,+but the latter one would have to materialise @xs@ completely.+In contrast to that+@takeEnd@ should hold only chunks of about @n@ elements at any time point.+-}+{-# INLINE takeEnd #-}+takeEnd :: (Storable a) => Int -> Vector a -> Vector a+takeEnd n xs =+   -- cf. Pattern.drop+   List.foldl (flip drop) xs $ List.map V.length $ chunks $ drop n xs++{-# INLINE drop #-}+drop :: (Storable a) => Int -> Vector a -> Vector a+drop _ (SV []) = empty+drop n (SV (x:xs)) =+   let m = V.length x+   in  if m<=n+         then drop (n-m) (SV xs)+         else SV (V.drop n x : xs)++{-# INLINE splitAt #-}+splitAt :: (Storable a) => Int -> Vector a -> (Vector a, Vector a)+splitAt n0 =+   {- this order of pattern matches is certainly the most lazy one+   > splitAt 4 (pack (chunkSize 2) $ "abcd" List.++ undefined)+   (VectorLazy.fromChunks [Vector.pack "ab",Vector.pack "cd"],VectorLazy.fromChunks *** Exception: Prelude.undefined+   -}+   let recourse 0 xs = ([], xs)+       recourse _ [] = ([], [])+       recourse n (x:xs) =+          let m = V.length x+          in  if m<=n+                then mapFst (x:) $ recourse (n-m) xs+                else mapPair ((:[]), (:xs)) $ V.splitAt n x+   in  mapPair (SV, SV) . recourse n0 . chunks++++{-# INLINE dropMarginRem #-}+-- I have used this in an inner loop thus I prefer inlining+{- |+@dropMarginRem n m xs@+drops at most the first @m@ elements of @xs@+and ensures that @xs@ still contains @n@ elements.+Additionally returns the number of elements that could not be dropped+due to the margin constraint.+That is @dropMarginRem n m xs == (k,ys)@ implies @length xs - m == length ys - k@.+Requires @length xs >= n@.+-}+dropMarginRem :: (Storable a) => Int -> Int -> Vector a -> (Int, Vector a)+dropMarginRem n m xs =+   List.foldl'+      (\(mi,xsi) k -> (mi-k, drop k xsi))+      (m,xs)+      (List.map V.length $ chunks $ take m $ drop n xs)++{-+This implementation does only walk once through the dropped prefix.+It is maximally lazy and minimally space consuming.+-}+{-# INLINE dropMargin #-}+dropMargin :: (Storable a) => Int -> Int -> Vector a -> Vector a+dropMargin n m xs =+   List.foldl' (flip drop) xs+      (List.map V.length $ chunks $ take m $ drop n xs)++++{-# INLINE dropWhile #-}+dropWhile :: (Storable a) => (a -> Bool) -> Vector a -> Vector a+dropWhile _ (SV []) = empty+dropWhile p (SV (x:xs)) =+   let y = V.dropWhile p x+   in  if V.null y+         then dropWhile p (SV xs)+         else SV (y:xs)++{-# INLINE takeWhile #-}+takeWhile :: (Storable a) => (a -> Bool) -> Vector a -> Vector a+takeWhile _ (SV []) = empty+takeWhile p (SV (x:xs)) =+   let y = V.takeWhile p x+   in  if V.length y < V.length x+         then fromChunk y+         else SV (x : chunks (takeWhile p (SV xs)))+++{-# INLINE span #-}+span :: (Storable a) => (a -> Bool) -> Vector a -> (Vector a, Vector a)+span p =+   let recourse [] = ([],[])+       recourse (x:xs) =+          let (y,z) = V.span p x+          in  if V.null z+                then mapFst (x:) (recourse xs)+                else (chunks $ fromChunk y, (z:xs))+   in  mapPair (SV, SV) . recourse . chunks+{-+span _ (SV []) = (empty, empty)+span p (SV (x:xs)) =+   let (y,z) = V.span p x+   in  if V.length y == 0+         then mapFst (SV . (x:) . chunks) (span p (SV xs))+         else (SV [y], SV (z:xs))+-}+++-- * other functions+++{-# INLINE filter #-}+filter :: (Storable a) => (a -> Bool) -> Vector a -> Vector a+filter p =+   SV . List.filter (not . V.null) . List.map (V.filter p) . chunks+++{- |+Generates laziness breaks+wherever one of the input signals has a chunk boundary.+-}+{-# INLINE zipWith #-}+zipWith :: (Storable a, Storable b, Storable c) =>+      (a -> b -> c)+   -> Vector a+   -> Vector b+   -> Vector c+zipWith f as0 bs0 =+   let recourse at@(a:_) bt@(b:_) =+          let z = V.zipWith f a b+              n = V.length z+          in  z : recourse+                     (chunks $ drop n $ fromChunks at)+                     (chunks $ drop n $ fromChunks bt)+       recourse _ _ = []+   in  fromChunks $ recourse (chunks as0) (chunks bs0)++{-# INLINE zipWith3 #-}+zipWith3 :: (Storable a, Storable b, Storable c, Storable d) =>+      (a -> b -> c -> d)+   -> Vector a+   -> Vector b+   -> Vector c+   -> Vector d+zipWith3 f as0 bs0 cs0 =+   let recourse at@(a:_) bt@(b:_) ct@(c:_) =+          let z = V.zipWith3 f a b c+              n = V.length z+          in  z : recourse+                     (chunks $ drop n $ fromChunks at)+                     (chunks $ drop n $ fromChunks bt)+                     (chunks $ drop n $ fromChunks ct)+       recourse _ _ _ = []+   in  fromChunks $ recourse (chunks as0) (chunks bs0) (chunks cs0)++{-# INLINE zipWith4 #-}+zipWith4 :: (Storable a, Storable b, Storable c, Storable d, Storable e) =>+      (a -> b -> c -> d -> e)+   -> Vector a+   -> Vector b+   -> Vector c+   -> Vector d+   -> Vector e+zipWith4 f as0 bs0 cs0 ds0 =+   let recourse at@(a:_) bt@(b:_) ct@(c:_) dt@(d:_) =+          let z = V.zipWith4 f a b c d+              n = V.length z+          in  z : recourse+                     (chunks $ drop n $ fromChunks at)+                     (chunks $ drop n $ fromChunks bt)+                     (chunks $ drop n $ fromChunks ct)+                     (chunks $ drop n $ fromChunks dt)+       recourse _ _ _ _ = []+   in  fromChunks $+       recourse (chunks as0) (chunks bs0) (chunks cs0) (chunks ds0)+++{- |+Preserves chunk pattern of the last argument.+-}+{-# INLINE zipWithLastPattern #-}+zipWithLastPattern :: (Storable a, Storable b, Storable c) =>+      (a -> b -> c)+   -> Vector a+   -> Vector b+   -> Vector c+zipWithLastPattern f =+   crochetL (\y -> liftM (mapFst (flip f y)) . Ptr.viewL)+    . pointer++{- |+Preserves chunk pattern of the last argument.+-}+{-# INLINE zipWithLastPattern3 #-}+zipWithLastPattern3 ::+   (Storable a, Storable b, Storable c, Storable d) =>+   (a -> b -> c -> d) ->+   (Vector a -> Vector b -> Vector c -> Vector d)+zipWithLastPattern3 f s0 s1 =+   crochetL (\z (xt,yt) ->+      liftM2+         (\(x,xs) (y,ys) -> (f x y z, (xs,ys)))+         (Ptr.viewL xt)+         (Ptr.viewL yt))+      (pointer s0, pointer s1)++{- |+Preserves chunk pattern of the last argument.+-}+{-# INLINE zipWithLastPattern4 #-}+zipWithLastPattern4 ::+   (Storable a, Storable b, Storable c, Storable d, Storable e) =>+   (a -> b -> c -> d -> e) ->+   (Vector a -> Vector b -> Vector c -> Vector d -> Vector e)+zipWithLastPattern4 f s0 s1 s2 =+   crochetL (\w (xt,yt,zt) ->+      liftM3+         (\(x,xs) (y,ys) (z,zs) -> (f x y z w, (xs,ys,zs)))+         (Ptr.viewL xt)+         (Ptr.viewL yt)+         (Ptr.viewL zt))+      (pointer s0, pointer s1, pointer s2)+++{-# INLINE zipWithSize #-}+zipWithSize :: (Storable a, Storable b, Storable c) =>+      ChunkSize+   -> (a -> b -> c)+   -> Vector a+   -> Vector b+   -> Vector c+zipWithSize size f s0 s1 =+   unfoldr size (\(xt,yt) ->+      liftM2+         (\(x,xs) (y,ys) -> (f x y, (xs,ys)))+         (Ptr.viewL xt)+         (Ptr.viewL yt))+      (pointer s0, pointer s1)++{-# INLINE zipWithSize3 #-}+zipWithSize3 ::+   (Storable a, Storable b, Storable c, Storable d) =>+   ChunkSize -> (a -> b -> c -> d) ->+   (Vector a -> Vector b -> Vector c -> Vector d)+zipWithSize3 size f s0 s1 s2 =+   unfoldr size (\(xt,yt,zt) ->+      liftM3+         (\(x,xs) (y,ys) (z,zs) ->+             (f x y z, (xs,ys,zs)))+         (Ptr.viewL xt)+         (Ptr.viewL yt)+         (Ptr.viewL zt))+      (pointer s0, pointer s1, pointer s2)++{-# INLINE zipWithSize4 #-}+zipWithSize4 ::+   (Storable a, Storable b, Storable c, Storable d, Storable e) =>+   ChunkSize -> (a -> b -> c -> d -> e) ->+   (Vector a -> Vector b -> Vector c -> Vector d -> Vector e)+zipWithSize4 size f s0 s1 s2 s3 =+   unfoldr size (\(xt,yt,zt,wt) ->+      liftM4+         (\(x,xs) (y,ys) (z,zs) (w,ws) ->+             (f x y z w, (xs,ys,zs,ws)))+         (Ptr.viewL xt)+         (Ptr.viewL yt)+         (Ptr.viewL zt)+         (Ptr.viewL wt))+      (pointer s0, pointer s1, pointer s2, pointer s3)+++-- * interleaved vectors++{-# INLINE sieve #-}+sieve :: (Storable a) => Int -> Vector a -> Vector a+sieve n =+   fromChunks . List.filter (not . V.null) . snd .+   List.mapAccumL+      (\offset chunk ->+         (mod (offset - V.length chunk) n,+          V.sieve n $ V.drop offset chunk)) 0 .+   chunks++{-# INLINE deinterleave #-}+deinterleave :: (Storable a) => Int -> Vector a -> [Vector a]+deinterleave n =+   P.map (sieve n) . P.take n . P.iterate (switchL empty (flip const))++{- |+Interleave lazy vectors+while maintaining the chunk pattern of the first vector.+All input vectors must have the same length.+-}+{-# INLINE interleaveFirstPattern #-}+interleaveFirstPattern :: (Storable a) => [Vector a] -> Vector a+interleaveFirstPattern [] = empty+interleaveFirstPattern vss@(vs:_) =+   let pattern = List.map V.length $ chunks vs+       split xs =+          snd $+          List.mapAccumL+             (\x n -> swap $ mapFst (V.concat . chunks) $ splitAt n x)+             xs pattern+   in  fromChunks $ List.map V.interleave $+       List.transpose $ List.map split vss++{-+interleaveFirstPattern vss@(vs:_) =+   fromChunks . snd .+   List.mapAccumL+      (\xss n ->+         swap $+         mapFst (V.interleave . List.map (V.concat . chunks)) $+         List.unzip $ List.map (splitAt n) xss)+      vss .+   List.map V.length . chunks $ vs+-}++++{- |+Ensure a minimal length of the list by appending pad values.+-}+{- disabled INLINE pad -}+pad :: (Storable a) => ChunkSize -> a -> Int -> Vector a -> Vector a+pad size y n0 =+   let recourse n xt =+          if n<=0+            then xt+            else+              case xt of+                 [] -> chunks $ replicate size n y+                 x:xs -> x : recourse (n - V.length x) xs+   in  SV . recourse n0 . chunks++padAlt :: (Storable a) => ChunkSize -> a -> Int -> Vector a -> Vector a+padAlt size x n xs =+   append xs+      (let m = length xs+       in  if n>m+             then replicate size (n-m) x+             else empty)++++++-- * Helper functions for StorableVector+++{-# INLINE cancelNullVector #-}+cancelNullVector :: (V.Vector a, b) -> Maybe (V.Vector a, b)+cancelNullVector y =+   toMaybe (not (V.null (fst y))) y++-- if the chunk has length zero, an empty sequence is generated+{-# INLINE fromChunk #-}+fromChunk :: (Storable a) => V.Vector a -> Vector a+fromChunk x =+   if V.null x+     then empty+     else SV [x]++++{-+reduceLVector :: Storable x =>+   (x -> acc -> Maybe acc) -> acc -> Vector x -> (acc, Bool)+reduceLVector f acc0 x =+   let recourse i acc =+          if i < V.length x+            then (acc, True)+            else+               maybe+                  (acc, False)+                  (recourse (succ i))+                  (f (V.index x i) acc)+   in  recourse 0 acc0+++++{- * Fundamental functions -}++{-+Usage of 'unfoldr' seems to be clumsy but that covers all cases,+like different block sizes in source and destination list.+-}+crochetLSize :: (Storable x, Storable y) =>+      ChunkSize+   -> (x -> acc -> Maybe (y, acc))+   -> acc+   -> T x+   -> T y+crochetLSize size f =+   curry (unfoldr size (\(acc,xt) ->+      do (x,xs) <- viewL xt+         (y,acc') <- f x acc+         return (y, (acc',xs))))++crochetListL :: (Storable y) =>+      ChunkSize+   -> (x -> acc -> Maybe (y, acc))+   -> acc+   -> [x]+   -> T y+crochetListL size f =+   curry (unfoldr size (\(acc,xt) ->+      do (x,xs) <- ListHT.viewL xt+         (y,acc') <- f x acc+         return (y, (acc',xs))))++++{-# NOINLINE [0] crochetFusionListL #-}+crochetFusionListL :: (Storable y) =>+      ChunkSize+   -> (x -> acc -> Maybe (y, acc))+   -> acc+   -> FList.T x+   -> T y+crochetFusionListL size f =+   curry (unfoldr size (\(acc,xt) ->+      do (x,xs) <- FList.viewL xt+         (y,acc') <- f x acc+         return (y, (acc',xs))))+++{-# INLINE [0] reduceL #-}+reduceL :: Storable x =>+   (x -> acc -> Maybe acc) -> acc -> Vector x -> acc+reduceL f acc0 =+   let recourse acc xt =+          case xt of+             [] -> acc+             (x:xs) ->+                 let (acc',continue) = reduceLVector f acc x+                 in  if continue+                       then recourse acc' xs+                       else acc'+   in  recourse acc0 . chunks++++{- * Basic functions -}+++{-# RULEZ+  "Storable.append/repeat/repeat" forall size x.+      append (repeat size x) (repeat size x) = repeat size x ;++  "Storable.append/repeat/replicate" forall size n x.+      append (repeat size x) (replicate size n x) = repeat size x ;++  "Storable.append/replicate/repeat" forall size n x.+      append (replicate size n x) (repeat size x) = repeat size x ;++  "Storable.append/replicate/replicate" forall size n m x.+      append (replicate size n x) (replicate size m x) =+         replicate size (n+m) x ;++  "Storable.mix/repeat/repeat" forall size x y.+      mix (repeat size x) (repeat size y) = repeat size (x+y) ;++  #-}++{-# RULES+  "Storable.length/cons" forall x xs.+      length (cons x xs) = 1 + length xs ;++  "Storable.length/map" forall f xs.+      length (map f xs) = length xs ;++  "Storable.map/cons" forall f x xs.+      map f (cons x xs) = cons (f x) (map f xs) ;++  "Storable.map/repeat" forall size f x.+      map f (repeat size x) = repeat size (f x) ;++  "Storable.map/replicate" forall size f x n.+      map f (replicate size n x) = replicate size n (f x) ;++  "Storable.map/repeat" forall size f x.+      map f (repeat size x) = repeat size (f x) ;++  {-+  This can make things worse, if 'map' is applied to replicate,+  since this can use of sharing.+  It can also destroy the more important map/unfoldr fusion in+    take n . map f . unfoldr g++  "Storable.take/map" forall n f x.+      take n (map f x) = map f (take n x) ;+  -}++  "Storable.take/repeat" forall size n x.+      take n (repeat size x) = replicate size n x ;++  "Storable.take/take" forall n m xs.+      take n (take m xs) = take (min n m) xs ;++  "Storable.drop/drop" forall n m xs.+      drop n (drop m xs) = drop (n+m) xs ;++  "Storable.drop/take" forall n m xs.+      drop n (take m xs) = take (max 0 (m-n)) (drop n xs) ;++  "Storable.map/mapAccumL/snd" forall g f acc0 xs.+      map g (snd (mapAccumL f acc0 xs)) =+         snd (mapAccumL (\acc a -> mapSnd g (f acc a)) acc0 xs) ;++  #-}++{- GHC says this is an orphaned rule+  "Storable.map/mapAccumL/mapSnd" forall g f acc0 xs.+      mapSnd (map g) (mapAccumL f acc0 xs) =+         mapAccumL (\acc a -> mapSnd g (f acc a)) acc0 xs ;+-}+++{- * Fusable functions -}++scanLCrochet :: (Storable a, Storable b) =>+   (a -> b -> a) -> a -> Vector b -> Vector a+scanLCrochet f start =+   cons start .+   crochetL (\x acc -> let y = f acc x in Just (y, y)) start++{-# INLINE mapCrochet #-}+mapCrochet :: (Storable a, Storable b) => (a -> b) -> (Vector a -> Vector b)+mapCrochet f = crochetL (\x _ -> Just (f x, ())) ()++{-# INLINE takeCrochet #-}+takeCrochet :: Storable a => Int -> Vector a -> Vector a+takeCrochet = crochetL (\x n -> toMaybe (n>0) (x, pred n))++{-# INLINE repeatUnfoldr #-}+repeatUnfoldr :: Storable a => ChunkSize -> a -> Vector a+repeatUnfoldr size = iterate size id++{-# INLINE replicateCrochet #-}+replicateCrochet :: Storable a => ChunkSize -> Int -> a -> Vector a+replicateCrochet size n = takeCrochet n . repeat size+++++{-+The "fromList/drop" rule is not quite accurate+because the chunk borders are moved.+Maybe 'ChunkSize' better is a list of chunks sizes.+-}++{-# RULEZ+  "fromList/zipWith"+    forall size f (as :: Storable a => [a]) (bs :: Storable a => [a]).+     fromList size (List.zipWith f as bs) =+        zipWith size f (fromList size as) (fromList size bs) ;++  "fromList/drop" forall as n size.+     fromList size (List.drop n as) =+        drop n (fromList size as) ;+  #-}++++{- * Fused functions -}++type Unfoldr s a = (s -> Maybe (a,s), s)++{-# INLINE zipWithUnfoldr2 #-}+zipWithUnfoldr2 :: Storable z =>+      ChunkSize+   -> (x -> y -> z)+   -> Unfoldr a x+   -> Unfoldr b y+   -> T z+zipWithUnfoldr2 size h (f,a) (g,b) =+   unfoldr size+      (\(a0,b0) -> liftM2 (\(x,a1) (y,b1) -> (h x y, (a1,b1))) (f a0) (g b0))+--      (uncurry (liftM2 (\(x,a1) (y,b1) -> (h x y, (a1,b1)))) . (f *** g))+      (a,b)++{- done by takeCrochet+{-# INLINE mapUnfoldr #-}+mapUnfoldr :: (Storable x, Storable y) =>+      ChunkSize+   -> (x -> y)+   -> Unfoldr a x+   -> T y+mapUnfoldr size g (f,a) =+   unfoldr size (fmap (mapFst g) . f) a+-}++{-# INLINE dropUnfoldr #-}+dropUnfoldr :: Storable x =>+      ChunkSize+   -> Int+   -> Unfoldr a x+   -> T x+dropUnfoldr size n (f,a0) =+   maybe+      empty+      (unfoldr size f)+      (nest n (\a -> fmap snd . f =<< a) (Just a0))+++{- done by takeCrochet+{-# INLINE takeUnfoldr #-}+takeUnfoldr :: Storable x =>+      ChunkSize+   -> Int+   -> Unfoldr a x+   -> T x+takeUnfoldr size n0 (f,a0) =+   unfoldr size+      (\(a,n) ->+         do guard (n>0)+            (x,a') <- f a+            return (x, (a', pred n)))+      (a0,n0)+-}+++lengthUnfoldr :: Storable x =>+      Unfoldr a x+   -> Int+lengthUnfoldr (f,a0) =+   let recourse n a =+          maybe n (recourse (succ n) . snd) (f a)+   in  recourse 0 a0+++{-# INLINE zipWithUnfoldr #-}+zipWithUnfoldr ::+   (Storable b, Storable c) =>+      (acc -> Maybe (a, acc))+   -> (a -> b -> c)+   -> acc+   -> T b -> T c+zipWithUnfoldr f h a y =+   crochetL (\y0 a0 ->+       do (x0,a1) <- f a0+          Just (h x0 y0, a1)) a y++{-# INLINE zipWithCrochetL #-}+zipWithCrochetL ::+   (Storable x, Storable b, Storable c) =>+      ChunkSize+   -> (x -> acc -> Maybe (a, acc))+   -> (a -> b -> c)+   -> acc+   -> T x -> T b -> T c+zipWithCrochetL size f h a x y =+   crochetL (\(x0,y0) a0 ->+       do (z0,a1) <- f x0 a0+          Just (h z0 y0, a1))+      a (zip size x y)+++{-# INLINE crochetLCons #-}+crochetLCons ::+   (Storable a, Storable b) =>+      (a -> acc -> Maybe (b, acc))+   -> acc+   -> a -> T a -> T b+crochetLCons f a0 x xs =+   maybe+      empty+      (\(y,a1) -> cons y (crochetL f a1 xs))+      (f x a0)++{-# INLINE reduceLCons #-}+reduceLCons ::+   (Storable a) =>+      (a -> acc -> Maybe acc)+   -> acc+   -> a -> T a -> acc+reduceLCons f a0 x xs =+   maybe a0 (flip (reduceL f) xs) (f x a0)++++++{-# RULES+  "Storable.zipWith/share" forall size (h :: a->a->b) (x :: T a).+     zipWith size h x x = map (\xi -> h xi xi) x ;++--  "Storable.map/zipWith" forall size (f::c->d) (g::a->b->c) (x::T a) (y::T b).+  "Storable.map/zipWith" forall size f g x y.+     map f (zipWith size g x y) =+        zipWith size (\xi yi -> f (g xi yi)) x y ;++  -- this rule lets map run on a different block structure+  "Storable.zipWith/map,*" forall size f g x y.+     zipWith size g (map f x) y =+        zipWith size (\xi yi -> g (f xi) yi) x y ;++  "Storable.zipWith/*,map" forall size f g x y.+     zipWith size g x (map f y) =+        zipWith size (\xi yi -> g xi (f yi)) x y ;+++  "Storable.drop/unfoldr" forall size f a n.+     drop n (unfoldr size f a) =+        dropUnfoldr size n (f,a) ;++  "Storable.take/unfoldr" forall size f a n.+     take n (unfoldr size f a) =+--        takeUnfoldr size n (f,a) ;+        takeCrochet n (unfoldr size f a) ;++  "Storable.length/unfoldr" forall size f a.+     length (unfoldr size f a) = lengthUnfoldr (f,a) ;++  "Storable.map/unfoldr" forall size g f a.+     map g (unfoldr size f a) =+--        mapUnfoldr size g (f,a) ;+        mapCrochet g (unfoldr size f a) ;++  "Storable.map/iterate" forall size g f a.+     map g (iterate size f a) =+        mapCrochet g (iterate size f a) ;++{-+  "Storable.zipWith/unfoldr,unfoldr" forall sizeA sizeB f g h a b n.+     zipWith n h (unfoldr sizeA f a) (unfoldr sizeB g b) =+        zipWithUnfoldr2 n h (f,a) (g,b) ;+-}++  -- block boundaries are changed here, so it changes lazy behaviour+  "Storable.zipWith/unfoldr,*" forall sizeA sizeB f h a y.+     zipWith sizeA h (unfoldr sizeB f a) y =+        zipWithUnfoldr f h a y ;++  -- block boundaries are changed here, so it changes lazy behaviour+  "Storable.zipWith/*,unfoldr" forall sizeA sizeB f h a y.+     zipWith sizeA h y (unfoldr sizeB f a) =+        zipWithUnfoldr f (flip h) a y ;++  "Storable.crochetL/unfoldr" forall size f g a b.+     crochetL g b (unfoldr size f a) =+        unfoldr size (\(a0,b0) ->+            do (y0,a1) <- f a0+               (z0,b1) <- g y0 b0+               Just (z0, (a1,b1))) (a,b) ;++  "Storable.reduceL/unfoldr" forall size f g a b.+     reduceL g b (unfoldr size f a) =+        snd+          (FList.recourse (\(a0,b0) ->+              do (y,a1) <- f a0+                 b1 <- g y b0+                 Just (a1, b1)) (a,b)) ;++  "Storable.crochetL/cons" forall g b x xs.+     crochetL g b (cons x xs) =+        crochetLCons g b x xs ;++  "Storable.reduceL/cons" forall g b x xs.+     reduceL g b (cons x xs) =+        reduceLCons g b x xs ;+++++  "Storable.take/crochetL" forall f a x n.+     take n (crochetL f a x) =+        takeCrochet n (crochetL f a x) ;++  "Storable.length/crochetL" forall f a x.+     length (crochetL f a x) = length x ;++  "Storable.map/crochetL" forall g f a x.+     map g (crochetL f a x) =+        mapCrochet g (crochetL f a x) ;++  "Storable.zipWith/crochetL,*" forall size f h a x y.+     zipWith size h (crochetL f a x) y =+        zipWithCrochetL size f h a x y ;++  "Storable.zipWith/*,crochetL" forall size f h a x y.+     zipWith size h y (crochetL f a x) =+        zipWithCrochetL size f (flip h) a x y ;++  "Storable.crochetL/crochetL" forall f g a b x.+     crochetL g b (crochetL f a x) =+        crochetL (\x0 (a0,b0) ->+            do (y0,a1) <- f x0 a0+               (z0,b1) <- g y0 b0+               Just (z0, (a1,b1))) (a,b) x ;++  "Storable.reduceL/crochetL" forall f g a b x.+     reduceL g b (crochetL f a x) =+        snd+          (reduceL (\x0 (a0,b0) ->+              do (y,a1) <- f x0 a0+                 b1 <- g y b0+                 Just (a1, b1)) (a,b) x) ;+  #-}++-}++{- * IO -}++{- |+Read the rest of a file lazily and+provide the reason of termination as IOError.+If IOError is EOF (check with @System.Error.isEOFError err@),+then the file was read successfully.+Only access the final IOError after you have consumed the file contents,+since finding out the terminating reason forces to read the entire file.+Make also sure you read the file completely,+because it is only closed when the file end is reached+(or an exception is encountered).++TODO:+In ByteString.Lazy the chunk size is reduced+if data is not immediately available.+Maybe we should adapt that behaviour+but when working with realtime streams+that may mean that the chunks are very small.+-}+hGetContentsAsync :: Storable a =>+   ChunkSize -> Handle -> IO (IOError, Vector a)+hGetContentsAsync (ChunkSize size) h =+   let go =+          Unsafe.interleaveIO $+          flip catch (\err -> return (err,[])) $+          do v <- V.hGet h size+             if V.null v+               then hClose h >>+                    return (Exc.mkIOError Exc.eofErrorType+                      "StorableVector.Lazy.hGetContentsAsync" (Just h) Nothing, [])+               else fmap (mapSnd (v:)) go+{-+          Unsafe.interleaveIO $+          flip catch (\err -> return (err,[])) $+          liftM2 (\ chunk ~(err,rest) -> (err,chunk:rest))+             (V.hGet h size) go+-}+   in  fmap (mapSnd SV) go++hGetContentsSync :: Storable a =>+   ChunkSize -> Handle -> IO (Vector a)+hGetContentsSync (ChunkSize size) h =+   let go =+          do v <- V.hGet h size+             if V.null v+               then return []+               else fmap (v:) go+   in  fmap SV go++hPut :: Storable a => Handle -> Vector a -> IO ()+hPut h = mapM_ (V.hPut h) . chunks++{-+*Data.StorableVector.Lazy> print . mapSnd (length :: Vector Data.Int.Int16 -> Int) =<< readFileAsync (ChunkSize 1000) "dist/build/libHSstorablevector-0.1.3.a"+(dist/build/libHSstorablevector-0.1.3.a: hGetBuf: illegal operation (handle is closed),0)+-}+{- |+The file can only closed after all values are consumed.+That is you must always assert that you consume all elements of the stream,+and that no values are missed due to lazy evaluation.+This requirement makes this function useless in many applications.+-}+readFileAsync :: Storable a => ChunkSize -> FilePath -> IO (IOError, Vector a)+readFileAsync size path =+   openBinaryFile path ReadMode >>= hGetContentsAsync size++writeFile :: Storable a => FilePath -> Vector a -> IO ()+writeFile path =+   bracket (openBinaryFile path WriteMode) hClose . flip hPut++appendFile :: Storable a => FilePath -> Vector a -> IO ()+appendFile path =+   bracket (openBinaryFile path AppendMode) hClose . flip hPut+++{-# NOINLINE moduleError #-}+moduleError :: String -> String -> a+moduleError fun msg =+   error ("Data.StorableVector.Lazy." List.++ fun List.++ ':':' ':msg)
+ src/Data/StorableVector/Lazy/Builder.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE Rank2Types #-}+{- |+Build a lazy storable vector by incrementally adding an element.+This is analogous to Data.Binary.Builder for Data.ByteString.Lazy.++Attention:+This implementation is still almost 3 times slower+than constructing a lazy storable vector using unfoldr+in our Chorus speed test.+-}+module Data.StorableVector.Lazy.Builder (+   Builder,+   toLazyStorableVector,+   put,+   flush,+   ) where++import qualified Data.StorableVector as SV+import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector.ST.Strict as STV+-- import qualified Data.StorableVector.ST.Lazy as STVL++import Data.StorableVector.Lazy (ChunkSize, )+import Control.Monad (liftM2, )+import Control.Monad.ST.Strict (ST, runST, )+import Data.Monoid (Monoid(mempty, mappend), )++import Foreign.Storable (Storable, )++import qualified System.Unsafe as Unsafe+++{-+Given an initial buffer and a function that generates the rest of the vector,+a 'Builder' generates the whole vector.+The idea is inspired by Data.Binary.Builder.++We use the strict ST monad by default+and only rare 'Unsafe.interleaveST',+since this is more efficient than using lazy ST everywhere.++Before that approach I tried to achieve this with a lazy State monad.+I found this more comprehensible but it was very slow+and had a space leak, when the last chunk shall be handled correctly.+-}+newtype Builder a =+   Builder {run :: forall s.+      ChunkSize ->+      (Buffer s a -> ST s [SV.Vector a]) ->+      (Buffer s a -> ST s [SV.Vector a])+   }++type Buffer s a = (STV.Vector s a, Int)+++-- instance Monoid (Builder a) where+{-+Storable constraint not needed in the current implementation,+but who knows what will be in future ...+-}+instance Storable a => Monoid (Builder a) where+   {-# INLINE mempty #-}+   {-# INLINE mappend #-}+   mempty = Builder (\_ -> id)+   mappend x y = Builder (\cs -> run x cs . run y cs)+++{- |+> toLazyStorableVector (ChunkSize 7) $ Data.Monoid.mconcat $ map put ['a'..'z']+-}+{-# INLINE toLazyStorableVector #-}+toLazyStorableVector :: Storable a =>+   ChunkSize -> Builder a -> SVL.Vector a+toLazyStorableVector cs bld =+   SVL.fromChunks $+   runST (run bld cs (fmap (:[]) . fixVector) =<< newChunk cs)+++{-# INLINE put #-}+put :: Storable a => a -> Builder a+put a =+   Builder (\cs cont (v0,i0) ->+      do STV.unsafeWrite v0 i0 a+         let i1 = succ i0+         if i1 < STV.length v0+           then+             cont (v0, i1)+           else+             liftM2 (:)+                -- we could call 'flush' here, but this requires an extra 'SV.take'+                (STV.unsafeFreeze v0)+                (Unsafe.interleaveST $+                 cont =<< newChunk cs)+   )++{-+put :: Storable a => a -> Builder a+put a =+   Builder (\cs cont (v0,i0) ->+      if i0 < STV.length v0+        then+          do STV.write v0 i0 a+             cont (v0, succ i0)+        else+          liftM2 (:)+             -- we could call 'flush' here, but this requires an extra 'SV.take'+             (STV.unsafeFreeze v0)+             (Unsafe.interleaveST $+              do (v1,i1) <- newChunk cs+                 STV.write v1 i1 a+                 cont (v1, succ i1))+   )+-}++{-+          lazyToStrictST $+          liftM2 (:)+             -- we could call 'flush' here, but this requires an extra 'SV.take'+             (STVL.unsafeFreeze v0)+             (strictToLazyST $+              do (v1,i1) <- newChunk cs+                 STV.write v1 i1 a+                 cont (v1, succ i1))+-}++{-+Prelude Control.Monad.ST.Lazy> Control.Monad.ST.runST (lazyToStrictST $ Monad.liftM2 (,) (strictToLazyST $ return 'a') (strictToLazyST (undefined::Monad m => m Char)))+*** Exception: Prelude.undefined+-}++{- |+Set a laziness break.+-}+{-# INLINE flush #-}+flush :: Storable a => Builder a+flush =+   Builder (\cs cont vi0 ->+      liftM2 (:)+         (fixVector vi0)+         (Unsafe.interleaveST $ cont =<< newChunk cs)+{-+      lazyToStrictST $+      liftM2 (:)+         (strictToLazyST $ fixVector vi0)+         (strictToLazyST $ cont =<< newChunk cs)+-}+   )++{-# INLINE newChunk #-}+newChunk :: (Storable a) =>+   ChunkSize -> ST s (Buffer s a)+newChunk (SVL.ChunkSize size) =+   fmap (flip (,) 0) $ STV.new_ size++{-# INLINE fixVector #-}+fixVector :: (Storable a) =>+   Buffer s a -> ST s (SV.Vector a)+fixVector ~(v1,i1) =+   fmap (SV.take i1) $ STV.unsafeFreeze v1
+ src/Data/StorableVector/Lazy/Pattern.hs view
@@ -0,0 +1,371 @@+{- |+Functions for 'StorableVector' that allow control of the size of individual chunks.++This is import for an application like the following:+You want to mix audio signals that are relatively shifted.+The structure of chunks of three streams may be illustrated as:++> [____] [____] [____] [____] ...+>   [____] [____] [____] [____] ...+>     [____] [____] [____] [____] ...++When we mix the streams (@zipWith3 (\x y z -> x+y+z)@)+with respect to the chunk structure of the first signal,+computing the first chunk requires full evaluation of all leading chunks of the stream.+However the last value of the third leading chunk+is much later in time than the last value of the first leading chunk.+We like to reduce these dependencies using a different chunk structure,+say++> [____] [____] [____] [____] ...+>   [__] [____] [____] [____] ...+>     [] [____] [____] [____] ...++-}+module Data.StorableVector.Lazy.Pattern (+   Vector,+   ChunkSize,+   chunkSize,+   defaultChunkSize,+   LazySize,++   empty,+   singleton,+   pack,+   unpack,+   packWith,+   unpackWith,+   unfoldrN,+   iterateN,+   cycle,+   replicate,+   null,+   length,+   cons,+   append,+   concat,+   map,+   reverse,+   foldl,+   foldl',+   any,+   all,+   maximum,+   minimum,+   viewL,+   viewR,+   switchL,+   switchR,+   scanl,+   mapAccumL,+   mapAccumR,+   crochetL,+   take,+   drop,+   splitAt,+   takeVectorPattern,+   splitAtVectorPattern,+   dropMarginRem,+   dropMargin,+   dropWhile,+   takeWhile,+   span,+   filter,+   zipWith,+   zipWith3,+   zipWith4,+   zipWithSize,+   zipWithSize3,+   zipWithSize4,+{-+   pad,+   cancelNullVector,+-}+   ) where++import Numeric.NonNegative.Class ((-|))+import qualified Numeric.NonNegative.Chunky as LS+import qualified Data.StorableVector.Lazy as LSV+import qualified Data.StorableVector as V++import Data.StorableVector.Lazy (Vector(SV), ChunkSize(ChunkSize))++import Data.StorableVector.Lazy (+   chunkSize, defaultChunkSize,+   empty, singleton, unpack, unpackWith, cycle,+   null, cons, append, concat, map, reverse,+   foldl, foldl', any, all, maximum, minimum,+   viewL, viewR, switchL, switchR,+   scanl, mapAccumL, mapAccumR, crochetL,+   dropMarginRem, dropMargin,+   dropWhile, takeWhile, span, filter, +   zipWith, zipWith3, zipWith4, +   )++import qualified Data.List as List++import qualified Data.List.HT as ListHT+import Data.Tuple.HT (mapPair, mapFst, forcePair, swap, )++import Control.Monad (liftM2, liftM3, liftM4, guard, )++import Foreign.Storable (Storable)++import Prelude hiding+   (length, (++), iterate, foldl, map, repeat, replicate, null,+    zip, zipWith, zipWith3, drop, take, splitAt, takeWhile, dropWhile, reverse,+    any, all, concat, cycle, filter, maximum, minimum, scanl, span, )+{-+import Data.Maybe (Maybe(Just, Nothing), )+import Prelude (Int, (.), ($), fst, snd, (<=), flip, curry, return, fmap, not, uncurry, )+-}+++type LazySize = LS.T ChunkSize++-- * Introducing and eliminating 'Vector's++{-+Actually, this is lazy enough:++> LSV.unpack $ pack (LS.fromChunks [10,15]) (['a'..'y'] List.++ Prelude.undefined)+"abcdefghijklmnopqrstuvwxy"+-}+pack :: (Storable a) => LazySize -> [a] -> Vector a+pack size =+   fst . unfoldrN size ListHT.viewL+++{-# INLINE packWith #-}+packWith :: (Storable b) => LazySize -> (a -> b) -> [a] -> Vector b+packWith size f =+   fst . unfoldrN size (fmap (mapFst f) . ListHT.viewL)+++{-+{-# INLINE unfoldrNAlt #-}+unfoldrNAlt :: (Storable b) =>+      LazySize+   -> (a -> Maybe (b,a))+   -> a+   -> (Vector b, Maybe a)+unfoldrNAlt (LS.Cons size) f x =+   let go sz y =+          case sz of+             [] -> ([], y)+             (ChunkSize s : ss) ->+                maybe+                   ([], Nothing)+                   ((\(c,a1) -> mapFst (c:) $ go ss a1) .+                    V.unfoldrN s (fmap (mapSnd f)))+                   (f y)+   in  mapFst SV $ go size (Just x)+-}++{-# INLINE unfoldrN #-}+unfoldrN :: (Storable b) =>+      LazySize+   -> (a -> Maybe (b,a))+   -> a+   -> (Vector b, Maybe a)+unfoldrN size f =+   let go sz y =+          forcePair $+          case sz of+             [] -> ([], y)+             (ChunkSize s : ss) ->+                let m =+                       do a0 <- y+                          let p = V.unfoldrN s f a0+                          guard (not (V.null (fst p)))+                          return p+                in  case m of+                       Nothing -> ([], Nothing)+                       Just (c,a1) -> mapFst (c:) $ go ss a1+   in  mapFst SV . go (LS.toChunks size) . Just+++{-# INLINE iterateN #-}+iterateN :: Storable a => LazySize -> (a -> a) -> a -> Vector a+iterateN size f =+   fst . unfoldrN size (\x -> Just (x, f x))++{-+Tries to be time and memory efficient+by reusing subvectors of a chunk+until a larger chunk is needed.+However, it can be a memory leak+if a huge chunk is followed by many little ones.+-}+replicate :: Storable a => LazySize -> a -> Vector a+replicate size x =+   SV $ snd $+   List.mapAccumL+      (\v (ChunkSize m) ->+         if m <= V.length v+           then (v, V.take m v)+           else let v1 = V.replicate m x+                in  (v1,v1))+      V.empty $+   LS.toChunks size++{-+replicate :: Storable a => LazySize -> a -> Vector a+replicate size x =+   SV $ List.map (\(ChunkSize m) -> V.replicate m x) (LS.toChunks size)+-}+++-- * Basic interface++length :: Vector a -> LazySize+length = LS.fromChunks . List.map chunkLength . LSV.chunks++chunkLength :: V.Vector a -> ChunkSize+chunkLength = ChunkSize . V.length++decrementLimit :: V.Vector a -> LazySize -> LazySize+decrementLimit x y =+   y -| LS.fromNumber (chunkLength x)++intFromChunkSize :: ChunkSize -> Int+intFromChunkSize (ChunkSize x) = x++intFromLazySize :: LazySize -> Int+intFromLazySize =+   List.sum . List.map intFromChunkSize . LS.toChunks++++-- * sub-vectors++{- |+Generates laziness breaks+wherever either the lazy length number or the vector has a chunk boundary.+-}+{-# INLINE take #-}+take :: (Storable a) => LazySize -> Vector a -> Vector a+take n = fst . splitAt n++{- |+Preserves the chunk pattern of the lazy vector.+-}+{-# INLINE takeVectorPattern #-}+takeVectorPattern :: (Storable a) => LazySize -> Vector a -> Vector a+takeVectorPattern _ (SV []) = empty+takeVectorPattern n (SV (x:xs)) =+   if List.null (LS.toChunks n)+     then empty+     else+       let remain = decrementLimit x n+       in  SV $ uncurry (:) $+           if LS.isNull remain+             then (V.take (intFromLazySize n) x, [])+             else+               (x, LSV.chunks $ take remain $ LSV.fromChunks xs)++{-# INLINE drop #-}+drop :: (Storable a) => LazySize -> Vector a -> Vector a+drop size xs =+   List.foldl (flip (LSV.drop . intFromChunkSize)) xs (LS.toChunks size)++{-# INLINE splitAt #-}+splitAt ::+   (Storable a) => LazySize -> Vector a -> (Vector a, Vector a)+splitAt size xs =+   mapFst LSV.concat $ swap $+   List.mapAccumL+      (\xs0 n ->+         swap $ LSV.splitAt (intFromChunkSize n) xs0)+      xs (LS.toChunks size)++{-# INLINE splitAtVectorPattern #-}+splitAtVectorPattern ::+   (Storable a) => LazySize -> Vector a -> (Vector a, Vector a)+splitAtVectorPattern n0 =+   forcePair .+   if List.null (LS.toChunks n0)+     then (,) empty+     else+       let recourse n xt =+              forcePair $+              case xt of+                 [] -> ([], [])+                 (x:xs) ->+                    let remain = decrementLimit x n+                    in  if LS.isNull remain+                          then mapPair ((:[]), (:xs)) $+                               V.splitAt (intFromLazySize n) x+                          else mapFst (x:) $ recourse remain xs+       in  mapPair (SV, SV) . recourse n0 . LSV.chunks+++{-# INLINE [0] zipWithSize #-}+zipWithSize :: (Storable a, Storable b, Storable c) =>+      LazySize+   -> (a -> b -> c)+   -> Vector a+   -> Vector b+   -> Vector c+zipWithSize size f =+   curry (fst . unfoldrN size (\(xt,yt) ->+      liftM2+         (\(x,xs) (y,ys) -> (f x y, (xs,ys)))+         (viewL xt)+         (viewL yt)))++{-# INLINE zipWithSize3 #-}+zipWithSize3 ::+   (Storable a, Storable b, Storable c, Storable d) =>+   LazySize -> (a -> b -> c -> d) ->+   (Vector a -> Vector b -> Vector c -> Vector d)+zipWithSize3 size f s0 s1 s2 =+   fst $ unfoldrN size (\(xt,yt,zt) ->+      liftM3+         (\(x,xs) (y,ys) (z,zs) ->+             (f x y z, (xs,ys,zs)))+         (viewL xt)+         (viewL yt)+         (viewL zt))+      (s0,s1,s2)++{-# INLINE zipWithSize4 #-}+zipWithSize4 ::+   (Storable a, Storable b, Storable c, Storable d, Storable e) =>+   LazySize -> (a -> b -> c -> d -> e) ->+   (Vector a -> Vector b -> Vector c -> Vector d -> Vector e)+zipWithSize4 size f s0 s1 s2 s3 =+   fst $ unfoldrN size (\(xt,yt,zt,wt) ->+      liftM4+         (\(x,xs) (y,ys) (z,zs) (w,ws) ->+             (f x y z w, (xs,ys,zs,ws)))+         (viewL xt)+         (viewL yt)+         (viewL zt)+         (viewL wt))+      (s0,s1,s2,s3)++{-+{- |+Ensure a minimal length of the list by appending pad values.+-}+{-# ONLINE pad #-}+pad :: (Storable a) => ChunkSize -> a -> Int -> Vector a -> Vector a+pad size y n0 =+   let recourse n xt =+          if n<=0+            then xt+            else+              case xt of+                 [] -> chunks $ replicate size n y+                 x:xs -> x : recourse (n - V.length x) xs+   in  SV . recourse n0 . chunks++padAlt :: (Storable a) => ChunkSize -> a -> Int -> Vector a -> Vector a+padAlt size x n xs =+   append xs+      (let m = length xs+       in  if n>m+             then replicate size (n-m) x+             else empty)+-}
+ src/Data/StorableVector/Lazy/Pointer.hs view
@@ -0,0 +1,20 @@+{- |+In principle you can traverse through a lazy storable vector+using repeated calls to @viewL@.+However this needs a bit of pointer arrangement and allocation.+This data structure makes the inner loop faster,+that consists of traversing through a chunk.+-}+module Data.StorableVector.Lazy.Pointer (+   Pointer, cons, viewL, switchL,+   ) where++import Data.StorableVector.Lazy.PointerPrivate (Pointer(..), viewL, switchL, )+import qualified Data.StorableVector.Lazy as VL++import Foreign.Storable (Storable)+++{-# INLINE cons #-}+cons :: Storable a => VL.Vector a -> Pointer a+cons = VL.pointer
+ src/Data/StorableVector/Lazy/PointerPrivate.hs view
@@ -0,0 +1,42 @@+module Data.StorableVector.Lazy.PointerPrivate where++import qualified Data.StorableVector.Pointer as VP+import qualified Data.StorableVector as V+import qualified Data.StorableVector.Base as VB++import Foreign.Storable (Storable)+++data Pointer a =+   Pointer {+      chunks :: [VB.Vector a],+      ptr    :: {-# UNPACK #-} !(VP.Pointer a)+   }+++empty :: Storable a => Pointer a+empty =+   Pointer [] (VP.cons V.empty)++{-# INLINE cons #-}+cons :: Storable a => [VB.Vector a] -> Pointer a+cons [] = empty+cons (c:cs) = Pointer cs (VP.cons c)++{-# INLINE viewL #-}+viewL :: Storable a => Pointer a -> Maybe (a, Pointer a)+viewL = switchL Nothing (curry Just)++{-# INLINE switchL #-}+switchL :: Storable a =>+   b -> (a -> Pointer a -> b) -> Pointer a -> b+switchL n j =+   let recourse p =+          let ct = chunks p+          in  VP.switchL+                 (case ct of+                    [] -> n+                    (c:cs) -> recourse (Pointer cs (VP.cons c)))+                 (\a cp -> j a (Pointer ct cp))+                 (ptr p)+   in  recourse
+ src/Data/StorableVector/Lazy/PointerPrivateIndex.hs view
@@ -0,0 +1,38 @@+{-+Alternative to PointerPrivate implemented at a higher level.+-}+module Data.StorableVector.Lazy.PointerPrivateIndex where++import qualified Data.StorableVector as V+import qualified Data.StorableVector.Base as VB++import Foreign.Storable (Storable)+++data Pointer a =+   Pointer {chunks :: ![VB.Vector a], index :: !Int}+++{-# INLINE cons #-}+cons :: Storable a => [VB.Vector a] -> Pointer a+cons = flip Pointer 0++{-# INLINE viewL #-}+viewL :: Storable a => Pointer a -> Maybe (a, Pointer a)+viewL = switchL Nothing (curry Just)++{-# INLINE switchL #-}+switchL :: Storable a =>+   b -> (a -> Pointer a -> b) -> Pointer a -> b+switchL n j =+   let recourse p =+          let s = chunks p+          in  case s of+                 [] -> n+                 (c:cs) ->+                    let i = index p+                        d = i - V.length c+                    in  if d < 0+                          then j (VB.unsafeIndex c i) (Pointer s (i+1))+                          else recourse (Pointer cs d)+   in  recourse
+ src/Data/StorableVector/Pointer.hs view
@@ -0,0 +1,52 @@+{- |+In principle you can traverse through a storable vector+using repeated calls to @viewL@ or using @index@.+However this needs a bit of pointer arrangement and allocation.+This data structure should make loops optimally fast.+-}+module Data.StorableVector.Pointer where++-- import qualified Data.StorableVector as V+import qualified Data.StorableVector.Base as VB++import qualified Foreign.ForeignPtr as FPtr+import Foreign.Marshal.Array (advancePtr, )+import Foreign.Storable (Storable, peek, )+import Foreign (Ptr, )+import qualified System.Unsafe as Unsafe+++{-+The reference to the ForeignPtr asserts,+that the array is maintained and thus is not garbage collected.+The Ptr we use for traversing would not achieve this.+-}+{- |+We might have name the data type iterator.+-}+data Pointer a =+   Pointer {+      fptr :: {-# UNPACK #-} !(FPtr.ForeignPtr a),+      ptr  :: {-# UNPACK #-} !(Ptr a),+      left :: {-# UNPACK #-} !Int+   }+++{-# INLINE cons #-}+cons :: Storable a => VB.Vector a -> Pointer a+cons (VB.SV fp s l) =+   Pointer fp (advancePtr (Unsafe.foreignPtrToPtr fp) s) l+++{-# INLINE viewL #-}+viewL :: Storable a => Pointer a -> Maybe (a, Pointer a)+viewL = switchL Nothing (curry Just)++{-# INLINE switchL #-}+switchL :: Storable a =>+   b -> (a -> Pointer a -> b) -> Pointer a -> b+switchL n j (Pointer fp p l) =+   if l<=0+     then n+     else j (VB.inlinePerformIO (peek p)) (Pointer fp (advancePtr p 1) (l-1))+-- Unsafe.performIO at this place would make SpeedPointer test 0.5 s slower
+ src/Data/StorableVector/ST/Lazy.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE Rank2Types #-}+{- |+Module      : Data.StorableVector.ST.Strict+License     : BSD-style+Maintainer  : haskell@henning-thielemann.de+Stability   : experimental+Portability : portable, requires ffi+Tested with : GHC 6.4.1++Interface for access to a mutable StorableVector.+-}+module Data.StorableVector.ST.Lazy (+        Vector,+        new,+        new_,+        read,+        write,+        modify,+        unsafeRead,+        unsafeWrite,+        unsafeModify,+        freeze,+        unsafeFreeze,+        thaw,+        VST.length,+        runSTVector,+        mapST,+        mapSTLazy,+        ) where++-- import qualified Data.StorableVector.Base as V+import qualified Data.StorableVector as VS+import qualified Data.StorableVector.Lazy as VL++import qualified Data.StorableVector.ST.Strict as VST++import Data.StorableVector.ST.Strict (Vector)+++import qualified Control.Monad.ST.Lazy as ST+import Control.Monad.ST.Lazy (ST)++import Foreign.Storable         (Storable)++-- import Prelude (Int, ($), (+), return, const, )+import Prelude hiding (read, length, )++++-- * access to mutable storable vector++{-# INLINE new #-}+new :: (Storable e) =>+   Int -> e -> ST s (Vector s e)+new n x = ST.strictToLazyST (VST.new n x)++{-# INLINE new_ #-}+new_ :: (Storable e) =>+   Int -> ST s (Vector s e)+new_ n  =  ST.strictToLazyST (VST.new_ n)++{- |+> Control.Monad.ST.runST (do arr <- new_ 10; Monad.zipWithM_ (write arr) [9,8..0] ['a'..]; read arr 3)+-}+{-# INLINE read #-}+read :: (Storable e) =>+   Vector s e -> Int -> ST s e+read xs n = ST.strictToLazyST (VST.read xs n)++{- |+> VS.unpack $ runSTVector (do arr <- new_ 10; Monad.zipWithM_ (write arr) [9,8..0] ['a'..]; return arr)+-}+{-# INLINE write #-}+write :: (Storable e) =>+   Vector s e -> Int -> e -> ST s ()+write xs n x = ST.strictToLazyST (VST.write xs n x)++{-# INLINE modify #-}+modify :: (Storable e) =>+   Vector s e -> Int -> (e -> e) -> ST s ()+modify xs n f = ST.strictToLazyST (VST.modify xs n f)+++{-# INLINE unsafeRead #-}+unsafeRead :: (Storable e) =>+   Vector s e -> Int -> ST s e+unsafeRead xs n = ST.strictToLazyST (VST.unsafeRead xs n)++{-# INLINE unsafeWrite #-}+unsafeWrite :: (Storable e) =>+   Vector s e -> Int -> e -> ST s ()+unsafeWrite xs n x = ST.strictToLazyST (VST.unsafeWrite xs n x)++{-# INLINE unsafeModify #-}+unsafeModify :: (Storable e) =>+   Vector s e -> Int -> (e -> e) -> ST s ()+unsafeModify xs n f = ST.strictToLazyST (VST.unsafeModify xs n f)+++{-# INLINE freeze #-}+freeze :: (Storable e) =>+   Vector s e -> ST s (VS.Vector e)+freeze xs = ST.strictToLazyST (VST.freeze xs)++{-# INLINE unsafeFreeze #-}+unsafeFreeze :: (Storable e) =>+   Vector s e -> ST s (VS.Vector e)+unsafeFreeze xs = ST.strictToLazyST (VST.unsafeFreeze xs)++{-# INLINE thaw #-}+thaw :: (Storable e) =>+   VS.Vector e -> ST s (Vector s e)+thaw xs = ST.strictToLazyST (VST.thaw xs)++++{-# INLINE runSTVector #-}+runSTVector :: (Storable e) =>+   (forall s. ST s (Vector s e)) -> VS.Vector e+runSTVector m = VST.runSTVector (ST.lazyToStrictST m)++++-- * operations on immutable storable vector within ST monad++{- |+> :module + Data.STRef+> VS.unpack $ Control.Monad.ST.runST (do ref <- newSTRef 'a'; mapST (\ _n -> do c <- readSTRef ref; modifySTRef ref succ; return c) (VS.pack [1,2,3,4::Data.Int.Int16]))+-}+{-# INLINE mapST #-}+mapST :: (Storable a, Storable b) =>+   (a -> ST s b) -> VS.Vector a -> ST s (VS.Vector b)+mapST f xs =+   ST.strictToLazyST (VST.mapST (ST.lazyToStrictST . f) xs)+++{- |+> *Data.StorableVector.ST.Strict Data.STRef> VL.unpack $ Control.Monad.ST.runST (do ref <- newSTRef 'a'; mapSTLazy (\ _n -> do c <- readSTRef ref; modifySTRef ref succ; return c) (VL.pack VL.defaultChunkSize [1,2,3,4::Data.Int.Int16]))+> "abcd"++The following should not work on infinite streams,+since we are in 'ST' with strict '>>='.+But it works. Why?++> *Data.StorableVector.ST.Strict Data.STRef.Lazy> VL.unpack $ Control.Monad.ST.Lazy.runST (do ref <- newSTRef 'a'; mapSTLazy (\ _n -> do c <- readSTRef ref; modifySTRef ref succ; return c) (VL.pack VL.defaultChunkSize [0::Data.Int.Int16 ..]))+> "Interrupted.+-}+{-# INLINE mapSTLazy #-}+mapSTLazy :: (Storable a, Storable b) =>+   (a -> ST s b) -> VL.Vector a -> ST s (VL.Vector b)+mapSTLazy f (VL.SV xs) =+   fmap VL.SV $ mapM (mapST f) xs
+ src/Data/StorableVector/ST/Private.hs view
@@ -0,0 +1,54 @@+{- |+Module      : Data.StorableVector.ST.Strict+License     : BSD-style+Maintainer  : haskell@henning-thielemann.de+Stability   : experimental+Portability : portable, requires ffi+Tested with : GHC 6.4.1++-}+module Data.StorableVector.ST.Private where++import qualified Data.StorableVector.Base as V++import Data.StorableVector.Memory (mallocForeignPtrArray, )++import Control.Monad.ST.Strict (ST, )++import Foreign.Ptr        (Ptr, )+import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, )+import Foreign.Storable   (Storable, )++import qualified System.Unsafe as Unsafe++-- import Prelude (Int, ($), (+), return, const, )+import Prelude hiding (read, length, )+++data Vector s a =+   SV {-# UNPACK #-} !(ForeignPtr a)+      {-# UNPACK #-} !Int                -- length+++-- | Wrapper of mallocForeignPtrArray.+create :: (Storable a) => Int -> (Ptr a -> IO ()) -> IO (Vector s a)+create l f = do+    fp <- mallocForeignPtrArray l+    withForeignPtr fp f+    return $! SV fp l++{-# INLINE unsafeCreate #-}+unsafeCreate :: (Storable a) => Int -> (Ptr a -> IO ()) -> ST s (Vector s a)+unsafeCreate l f = Unsafe.ioToST $ create l f++{-+This function must be in ST monad,+since it is usually called+as termination of a series of write accesses to the vector.+We must assert that no read access to the V.Vector can happen+before the end of the write accesses.+(And the caller must assert, that he actually never writes again into that vector.)+-}+{-# INLINE unsafeToVector #-}+unsafeToVector :: Vector s a -> ST s (V.Vector a)+unsafeToVector (SV x l) = return (V.SV x 0 l)
+ src/Data/StorableVector/ST/Strict.hs view
@@ -0,0 +1,287 @@+{-# LANGUAGE Rank2Types #-}+{- |+Module      : Data.StorableVector.ST.Strict+License     : BSD-style+Maintainer  : haskell@henning-thielemann.de+Stability   : experimental+Portability : portable, requires ffi+Tested with : GHC 6.4.1++Interface for access to a mutable StorableVector.+-}+module Data.StorableVector.ST.Strict (+        Vector,+        new,+        new_,+        read,+        write,+        modify,+        maybeRead,+        maybeWrite,+        maybeModify,+        unsafeRead,+        unsafeWrite,+        unsafeModify,+        freeze,+        unsafeFreeze,+        thaw,+        length,+        runSTVector,+        mapST,+        mapSTLazy,+        ) where++import Data.StorableVector.ST.Private+          (Vector(SV), create, unsafeCreate, unsafeToVector, )+import qualified Data.StorableVector.Base as V+import qualified Data.StorableVector as VS+import qualified Data.StorableVector.Lazy as VL++import Control.Monad.ST.Strict (ST, runST, )++import Foreign.Ptr              (Ptr, )+import Foreign.ForeignPtr       (withForeignPtr, )+import Foreign.Storable         (Storable(peek, poke))+import Foreign.Marshal.Array    (advancePtr, copyArray, )+import qualified System.Unsafe as Unsafe++import qualified Data.Traversable as Traversable+import Data.Maybe.HT (toMaybe, )+import Data.Maybe (isJust, )++-- import Prelude (Int, ($), (+), return, const, )+import Prelude hiding (read, length, )+++-- * access to mutable storable vector++{-# INLINE new #-}+new :: (Storable e) =>+   Int -> e -> ST s (Vector s e)+new n x =+   unsafeCreate n $+   let {-# INLINE go #-}+       go m p =+         if m>0+           then poke p x >> go (pred m) (V.incPtr p)+           else return ()+   in  go n++{-# INLINE new_ #-}+new_ :: (Storable e) =>+   Int -> ST s (Vector s e)+new_ n =+   unsafeCreate n (const (return ()))+++{- |+> Control.Monad.ST.runST (do arr <- new_ 10; Monad.zipWithM_ (write arr) [9,8..0] ['a'..]; read arr 3)+-}+{-# INLINE read #-}+read :: (Storable e) =>+   Vector s e -> Int -> ST s e+read v n =+   access "read" v n $ unsafeRead v n++{- |+> VS.unpack $ runSTVector (do arr <- new_ 10; Monad.zipWithM_ (write arr) [9,8..0] ['a'..]; return arr)+-}+{-# INLINE write #-}+write :: (Storable e) =>+   Vector s e -> Int -> e -> ST s ()+write v n x =+   access "write" v n $ unsafeWrite v n x++{- |+> VS.unpack $ runSTVector (do arr <- new 10 'a'; Monad.mapM_ (\n -> modify arr (mod n 8) succ) [0..10]; return arr)+-}+{-# INLINE modify #-}+modify :: (Storable e) =>+   Vector s e -> Int -> (e -> e) -> ST s ()+modify v n f =+   access "modify" v n $ unsafeModify v n f++{-# INLINE access #-}+access :: (Storable e) =>+   String -> Vector s e -> Int -> ST s a -> ST s a+access name (SV _v l) n act =+   if 0<=n && n<l+     then act+     else error ("StorableVector.ST." ++ name ++ ": index out of range")+++{- |+Returns @Just e@, when the element @e@ could be read+and 'Nothing' if the index was out of range.+This way you can avoid duplicate index checks+that may be needed when using 'read'.++> Control.Monad.ST.runST (do arr <- new_ 10; Monad.zipWithM_ (write arr) [9,8..0] ['a'..]; read arr 3)++In future 'maybeRead' will replace 'read'.+-}+{-# INLINE maybeRead #-}+maybeRead :: (Storable e) =>+   Vector s e -> Int -> ST s (Maybe e)+maybeRead v n =+   maybeAccess v n $ unsafeRead v n++{- |+Returns 'True' if the element could be written+and 'False' if the index was out of range.++> runSTVector (do arr <- new_ 10; foldr (\c go i -> maybeWrite arr i c >>= \cont -> if cont then go (succ i) else return arr) (error "unreachable") ['a'..] 0)++In future 'maybeWrite' will replace 'write'.+-}+{-# INLINE maybeWrite #-}+maybeWrite :: (Storable e) =>+   Vector s e -> Int -> e -> ST s Bool+maybeWrite v n x =+   fmap isJust $ maybeAccess v n $ unsafeWrite v n x++{- |+Similar to 'maybeWrite'.++In future 'maybeModify' will replace 'modify'.+-}+{-# INLINE maybeModify #-}+maybeModify :: (Storable e) =>+   Vector s e -> Int -> (e -> e) -> ST s Bool+maybeModify v n f =+   fmap isJust $ maybeAccess v n $ unsafeModify v n f++{-# INLINE maybeAccess #-}+maybeAccess :: (Storable e) =>+   Vector s e -> Int -> ST s a -> ST s (Maybe a)+maybeAccess (SV _v l) n act =+   Traversable.sequence $ toMaybe (0<=n && n<l) act+{-+   if 0<=n && n<l+     then fmap Just act+     else return Nothing+-}++{-# INLINE unsafeRead #-}+unsafeRead :: (Storable e) =>+   Vector s e -> Int -> ST s e+unsafeRead v n =+   unsafeAccess v n $ peek++{-# INLINE unsafeWrite #-}+unsafeWrite :: (Storable e) =>+   Vector s e -> Int -> e -> ST s ()+unsafeWrite v n x =+   unsafeAccess v n $ \p -> poke p x++{-# INLINE unsafeModify #-}+unsafeModify :: (Storable e) =>+   Vector s e -> Int -> (e -> e) -> ST s ()+unsafeModify v n f =+   unsafeAccess v n $ \p -> poke p . f =<< peek p++{-# INLINE unsafeAccess #-}+unsafeAccess :: (Storable e) =>+   Vector s e -> Int -> (Ptr e -> IO a) -> ST s a+unsafeAccess (SV v _l) n act =+   Unsafe.ioToST (withForeignPtr v $ \p -> act (advancePtr p n))+++{-# INLINE freeze #-}+freeze :: (Storable e) =>+   Vector s e -> ST s (VS.Vector e)+freeze (SV x l) =+   Unsafe.ioToST $+   V.create l $ \p ->+   withForeignPtr x $ \f ->+   copyArray p f (fromIntegral l)++{- |+This is like 'freeze' but it does not copy the vector.+You must make sure that you never write again to the array.+It is best to use 'unsafeFreeze' only at the end of a block,+that is run by 'runST'.+-}+{-# INLINE unsafeFreeze #-}+unsafeFreeze :: (Storable e) =>+   Vector s e -> ST s (VS.Vector e)+unsafeFreeze = unsafeToVector+++{-# INLINE thaw #-}+thaw :: (Storable e) =>+   VS.Vector e -> ST s (Vector s e)+thaw v =+   Unsafe.ioToST $+   V.withStartPtr v $ \f l ->+   create l $ \p ->+   copyArray p f (fromIntegral l)+++{-# INLINE length #-}+length ::+   Vector s e -> Int+length (SV _v l) = l+++{-# INLINE runSTVector #-}+runSTVector :: (Storable e) =>+   (forall s. ST s (Vector s e)) -> VS.Vector e+runSTVector m =+   runST (unsafeToVector =<< m)++++-- * operations on immutable storable vector within ST monad++{- |+> :module + Data.STRef+> VS.unpack $ Control.Monad.ST.runST (do ref <- newSTRef 'a'; mapST (\ _n -> do c <- readSTRef ref; modifySTRef ref succ; return c) (VS.pack [1,2,3,4::Data.Int.Int16]))+-}+{-# INLINE mapST #-}+mapST :: (Storable a, Storable b) =>+   (a -> ST s b) -> VS.Vector a -> ST s (VS.Vector b)+mapST f (V.SV px sx n) =+   let {-# INLINE go #-}+       go l q p =+          if l>0+            then+               do Unsafe.ioToST . poke p =<< f =<< Unsafe.ioToST (peek q)+                  go (pred l) (advancePtr q 1) (advancePtr p 1)+            else return ()+   in  do ys@(SV py _) <- new_ n+          go n+              (Unsafe.foreignPtrToPtr px `advancePtr` sx)+              (Unsafe.foreignPtrToPtr py)+          unsafeToVector ys++{-+mapST f xs@(V.SV v s l) =+   let go l q p =+          if l>0+            then+               do poke p =<< stToIO . f =<< peek q+                  go (pred l) (advancePtr q 1) (advancePtr p 1)+            else return ()+       n = VS.length xs+   in  return $ V.unsafeCreate n $ \p ->+          withForeignPtr v $ \q -> go n (advancePtr q s) p+-}+++{- |+> *Data.StorableVector.ST.Strict Data.STRef> VL.unpack $ Control.Monad.ST.runST (do ref <- newSTRef 'a'; mapSTLazy (\ _n -> do c <- readSTRef ref; modifySTRef ref succ; return c) (VL.pack VL.defaultChunkSize [1,2,3,4::Data.Int.Int16]))+> "abcd"++The following should not work on infinite streams,+since we are in 'ST' with strict '>>='.+But it works. Why?++> *Data.StorableVector.ST.Strict Data.STRef> VL.unpack $ Control.Monad.ST.runST (do ref <- newSTRef 'a'; mapSTLazy (\ _n -> do c <- readSTRef ref; modifySTRef ref succ; return c) (VL.pack VL.defaultChunkSize [0::Data.Int.Int16 ..]))+> "Interrupted.+-}+{-# INLINE mapSTLazy #-}+mapSTLazy :: (Storable a, Storable b) =>+   (a -> ST s b) -> VL.Vector a -> ST s (VL.Vector b)+mapSTLazy f (VL.SV xs) =+   fmap VL.SV $ mapM (mapST f) xs
storablevector.cabal view
@@ -1,5 +1,5 @@ Name:                storablevector-Version:             0.2.8.3+Version:             0.2.9 Category:            Data Synopsis:            Fast, packed, strict storable arrays with a list interface like ByteString Description:@@ -25,9 +25,10 @@ Homepage:            http://www.haskell.org/haskellwiki/Storable_Vector Stability:           Experimental Build-Type:          Simple-Tested-With:         GHC==6.8.2, GHC==6.12.3, GHC==7.4.1, GHC==7.6.2+Tested-With:         GHC==6.8.2, GHC==6.12.3+Tested-With:         GHC==7.4.1, GHC==7.6.2, GHC==7.8.2 Tested-With:         JHC==0.7.3-Cabal-Version:       >=1.6+Cabal-Version:       >=1.14 Extra-Source-Files:   foreign-ptr/fast/Data/StorableVector/Memory.hs   foreign-ptr/slow/Data/StorableVector/Memory.hs@@ -39,13 +40,7 @@ Flag separateSYB   description: Data.Generics available in separate package. -Flag functorInstance-  description: Use a custom Functor instance for pairs and functions -Flag buildTests-  description: Build test executables-  default:     False- Source-Repository head   type:     darcs   location: http://code.haskell.org/storablevector/@@ -53,13 +48,14 @@ Source-Repository this   type:     darcs   location: http://code.haskell.org/storablevector/-  tag:      0.2.8.3+  tag:      0.2.9 + Library   Build-Depends:     non-negative >=0.1 && <0.2,     utility-ht >=0.0.5 && <0.1,-    transformers >=0.2 && <0.4,+    transformers >=0.2 && <0.5,     unsafe >=0.0 && <0.1,     QuickCheck >=1 && <3 @@ -81,9 +77,9 @@     Else       Build-Depends: base >=1 && <2 -  Extensions:          CPP, ForeignFunctionInterface   GHC-Options:         -Wall -funbox-strict-fields-  Hs-Source-Dirs:      .+  Default-Language:    Haskell98+  Hs-Source-Dirs:      src    Exposed-Modules:     Data.StorableVector@@ -108,59 +104,53 @@     Data.StorableVector.Lazy.PointerPrivateIndex  --Executable test+Test-Suite test+  Type:                exitcode-stdio-1.0   GHC-Options:         -Wall -funbox-strict-fields-  Hs-Source-Dirs:      ., foreign-ptr/slow, tests-  Main-Is:             tests.hs-  Other-Modules:       QuickCheckUtils, Instances-  Extensions:          CPP, ForeignFunctionInterface-  If flag(buildTests)+  Default-Language:    Haskell98+  Hs-Source-Dirs:      tests+  Main-Is:             Test.hs+  Other-Modules:       Test.Utility+  Build-Depends:+    storablevector,+    bytestring >=0.9 && <0.11,+    QuickCheck >=1 && <3+  If flag(splitBase)     Build-Depends:-      bytestring >=0.9 && <0.11,-      QuickCheck >=1 && <3-    If flag(splitBase)-      Build-Depends:     random >=1.0 && <1.1-      If flag(functorInstance)-        Hs-Source-Dirs:    tests-2-        Build-Depends:     base >=3 && <4-      Else-        Hs-Source-Dirs:    tests-1-        Build-Depends:     base >=4 && <5-    Else-      Hs-Source-Dirs:    tests-1-      Build-Depends:     base >=1.0 && <2+      random >=1.0 && <1.1,+      base >=3 && <5   Else-    Buildable:         False+    Hs-Source-Dirs:    tests-1+    Build-Depends:     base >=1.0 && <2 -Executable speedtest+Benchmark speedtest+  Type:                exitcode-stdio-1.0   GHC-Options:         -Wall   -- -fvia-C -optc-ffast-math -optc-O3 -optc-ftree-vectorize   Main-Is:             SpeedTestChorus.hs   Other-Modules:     Data.StorableVector.Private-  Extensions:          CPP, ForeignFunctionInterface-  Hs-Source-Dirs:      ., foreign-ptr/slow, speedtest-  If flag(buildTests)-    Build-Depends:-      sample-frame >=0.0.1 && <0.1,-      deepseq >=1.1 && <1.4-    If flag(splitBase)-      Build-Depends:   base >= 3 && <5-    Else-      Build-Depends:   base >= 1.0 && < 2+  Default-Language:    Haskell98+  Hs-Source-Dirs:      speedtest+  Build-Depends:+    storablevector,+    sample-frame >=0.0.1 && <0.1,+    deepseq >=1.1 && <1.4+  If flag(splitBase)+    Build-Depends:   base >= 3 && <5   Else-    Buildable:         False+    Build-Depends:   base >= 1.0 && < 2 -Executable speedpointer+Benchmark speedpointer+  Type:                exitcode-stdio-1.0   GHC-Options:         -Wall   Main-Is:             Pointer.hs-  Extensions:          CPP, ForeignFunctionInterface-  Hs-Source-Dirs:      ., foreign-ptr/slow, speedtest-  If flag(buildTests)-    If flag(splitBase)-      Build-Depends:   base >=3 && <5-    Else-      Build-Depends:   base >=1.0 && <2+  Default-Language:    Haskell98+  Hs-Source-Dirs:      speedtest+  Build-Depends:+    storablevector,+    utility-ht+  If flag(splitBase)+    Build-Depends:   base >=3 && <5   Else-    Buildable:         False+    Build-Depends:   base >=1.0 && <2
− tests-2/Instances.hs 
@@ -1,1 +0,0 @@-module Instances where
− tests/QuickCheckUtils.hs 
@@ -1,225 +0,0 @@-{-# OPTIONS_GHC -O -fglasgow-exts #-}------ Uses multi-param type classes----module QuickCheckUtils where--import Instances ()--import Test.QuickCheck--- import Test.QuickCheck (Arbitrary(arbitrary, coarbitrary), variant, choose, sized, (==>), Property, )-import Text.Show.Functions ()-import System.Random (RandomGen, StdGen, Random, newStdGen, split, randomR, random, )--import Control.Monad (liftM2)-import Data.Char (ord)-import Data.Word (Word8)-import Data.Int (Int64)-import System.IO (hFlush, stdout, )--import qualified Data.ByteString      as P-import qualified Data.StorableVector  as V-import qualified Data.List as List--import qualified Data.ByteString.Char8      as PC---- Enable this to get verbose test output. Including the actual tests.-debug = False--mytest :: Testable a => a -> Int -> IO ()-mytest a n = mycheck defaultConfig-    { configMaxTest=n-    , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a--mycheck :: Testable a => Config -> a -> IO ()-mycheck config a =-  do rnd <- newStdGen-     mytests config (evaluate a) rnd 0 0 []--mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO ()-mytests config gen rnd0 ntest nfail stamps-  | ntest == configMaxTest config = do done "OK," ntest stamps-  | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps-  | otherwise               =-      do putStr (configEvery config ntest (arguments result)) >> hFlush stdout-         case ok result of-           Nothing    ->-             mytests config gen rnd1 ntest (nfail+1) stamps-           Just True  ->-             mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps)-           Just False ->-             putStr ( "Falsifiable after "-                   ++ show ntest-                   ++ " tests:\n"-                   ++ unlines (arguments result)-                    ) >> hFlush stdout-     where-      result      = generate (configSize config ntest) rnd2 gen-      (rnd1,rnd2) = split rnd0--done :: String -> Int -> [[String]] -> IO ()-done mesg ntest stamps =-  do putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table )- where-  table = display-        . map entry-        . reverse-        . List.sort-        . map pairLength-        . List.group-        . List.sort-        . filter (not . null)-        $ stamps--  display []  = ".\n"-  display [x] = " (" ++ x ++ ").\n"-  display xs  = ".\n" ++ unlines (map (++ ".") xs)--  pairLength xss@(xs:_) = (length xss, xs)-  entry (n, xs)         = percentage n ntest-                       ++ " "-                       ++ concat (List.intersperse ", " xs)--  percentage n m        = show ((100 * n) `div` m) ++ "%"----------------------------------------------------------------------------instance Arbitrary Char where-  arbitrary     = choose ('a', 'i')-  coarbitrary c = variant (ord c `rem` 4)--instance Arbitrary Word8 where-  arbitrary = choose (97, 105)-  coarbitrary c = variant (fromIntegral ((fromIntegral c) `rem` 4))--instance Arbitrary Int64 where-  arbitrary     = sized $ \n -> choose (-fromIntegral n,fromIntegral n)-  coarbitrary n = variant (fromIntegral (if n >= 0 then 2*n else 2*(-n) + 1))--{--instance Arbitrary Char where-  arbitrary = choose ('\0', '\255') -- since we have to test words, unlines too-  coarbitrary c = variant (ord c `rem` 16)--instance Arbitrary Word8 where-  arbitrary = choose (minBound, maxBound)-  coarbitrary c = variant (fromIntegral ((fromIntegral c) `rem` 16))--}--instance Random Word8 where-  randomR = integralRandomR-  random = randomR (minBound,maxBound)--instance Random Int64 where-  randomR = integralRandomR-  random  = randomR (minBound,maxBound)--integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)-integralRandomR  (a,b) g = case randomR (fromIntegral a :: Integer,-                                         fromIntegral b :: Integer) g of-                            (x,g) -> (fromIntegral x, g)--instance Arbitrary V where-  arbitrary = V.pack `fmap` arbitrary-  coarbitrary s = coarbitrary (V.unpack s)--instance Arbitrary P.ByteString where-  arbitrary = P.pack `fmap` arbitrary-  coarbitrary s = coarbitrary (P.unpack s)--------------------------------------------------------------------------------- We're doing two forms of testing here. Firstly, model based testing.--- For our Lazy and strict bytestring types, we have model types:------  i.e.    Lazy    ==   Byte---              \\      //---                 List ------ That is, the Lazy type can be modeled by functions in both the Byte--- and List type. For each of the 3 models, we have a set of tests that--- check those types match.------ The Model class connects a type and its model type, via a conversion--- function. -------class Model a b where-  model :: a -> b  -- get the abstract value from a concrete value------- Connecting our Lazy and Strict types to their models. We also check--- the data invariant on Lazy types.------ These instances represent the arrows in the above diagram----instance Model P [W]    where model = P.unpack-instance Model P [Char] where model = PC.unpack-instance Model V [W]    where model = V.unpack-instance Model V P      where model = P.pack . V.unpack---- Types are trivially modeled by themselves-instance Model Bool  Bool         where model = id-instance Model Int   Int          where model = id-instance Model Int64 Int64        where model = id-instance Model Int64 Int          where model = fromIntegral-instance Model Word8 Word8        where model = id-instance Model Ordering Ordering  where model = id-instance Model Char Char          where model = id---- More structured types are modeled recursively, using the NatTrans class from Gofer.-class (Functor f, Functor g) => NatTrans f g where-    eta :: f a -> g a---- The transformation of the same type is identity-instance NatTrans [] []             where eta = id-instance NatTrans Maybe Maybe       where eta = id-instance NatTrans ((->) X) ((->) X) where eta = id-instance NatTrans ((->) W) ((->) W) where eta = id-instance NatTrans ((->) Char) ((->) Char) where eta = id---- We have a transformation of pairs, if the pairs are in Model-instance Model f g => NatTrans ((,) f) ((,) g) where eta (f,a) = (model f, a)---- And finally, we can take any (m a) to (n b), if we can Model m n, and a b-instance (NatTrans m n, Model a b) => Model (m a) (n b) where model x = fmap model (eta x)------------------------------------------------------------------------------ Some short hand.-type X = Int-type W = Word8-type P = P.ByteString-type V = V.Vector Word8-------------------------------------------------------------------------------- These comparison functions handle wrapping and equality.------ A single class for these would be nice, but note that they differe in--- the number of arguments, and those argument types, so we'd need HList--- tricks. See here: http://okmij.org/ftp/Haskell/vararg-fn.lhs-----eq1 f g = \a         ->-    model (f a)         == g (model a)-eq2 f g = \a b       ->-    model (f a b)       == g (model a) (model b)-eq3 f g = \a b c     ->-    model (f a b c)     == g (model a) (model b) (model c)-eq4 f g = \a b c d   ->-    model (f a b c d)   == g (model a) (model b) (model c) (model d)-eq5 f g = \a b c d e ->-    model (f a b c d e) == g (model a) (model b) (model c) (model d) (model e)------- And for functions that take non-null input----eqnotnull1 f g = \x     -> (not (isNull x)) ==> eq1 f g x-eqnotnull2 f g = \x y   -> (not (isNull y)) ==> eq2 f g x y-eqnotnull3 f g = \x y z -> (not (isNull z)) ==> eq3 f g x y z--class    IsNull t            where isNull :: t -> Bool-instance IsNull P.ByteString where isNull = P.null-instance IsNull V            where isNull = V.null
+ tests/Test.hs view
@@ -0,0 +1,212 @@+import qualified Data.StorableVector as V+import qualified Data.ByteString as P+import Test.QuickCheck (Property, quickCheck, )+import Test.Utility+          (V, W, X, P, applyId, applyModel,+           eq0, eq1, eq2, eqnotnull1, eqnotnull2, eqnotnull3, )+import Text.Printf (printf)+++-- * compare Data.StorableVector <=> ByteString++limit :: Int -> Int+limit = flip mod 10000++prop_concatVP :: [V] -> Bool+prop_nullVP :: V -> Bool+prop_reverseVP :: V -> Bool+prop_transposeVP :: [V] -> Bool+prop_groupVP :: V -> Bool+prop_initsVP :: V -> Bool+prop_tailsVP :: V -> Bool+prop_allVP :: (W -> Bool) -> V -> Bool+prop_anyVP :: (W -> Bool) -> V -> Bool+prop_appendVP :: V -> V -> Bool+prop_breakVP :: (W -> Bool) -> V -> Bool+prop_concatMapVP :: (W -> V) -> V -> Bool+prop_consVP :: W -> V -> Bool+prop_countVP :: W -> V -> Bool+prop_dropVP :: X -> V -> Bool+prop_dropWhileVP :: (W -> Bool) -> V -> Bool+prop_filterVP :: (W -> Bool) -> V -> Bool+prop_findVP :: (W -> Bool) -> V -> Bool+prop_findIndexVP :: (W -> Bool) -> V -> Bool+prop_findIndicesVP :: (W -> Bool) -> V -> Bool+prop_isPrefixOfVP :: V -> V -> Bool+prop_mapVP :: (W -> W) -> V -> Bool+prop_replicateVP :: X -> W -> Bool+prop_iterateVP :: X -> (W -> W) -> W -> Bool+prop_snocVP :: V -> W -> Bool+prop_spanVP :: (W -> Bool) -> V -> Bool+prop_splitVP :: W -> V -> Bool+prop_splitAtVP :: X -> V -> Bool+prop_takeVP :: X -> V -> Bool+prop_takeWhileVP :: (W -> Bool) -> V -> Bool+prop_elemVP :: W -> V -> Bool+prop_notElemVP :: W -> V -> Bool+prop_elemIndexVP :: W -> V -> Bool+prop_elemIndicesVP :: W -> V -> Bool+prop_lengthVP :: V -> Bool+prop_headVP :: V -> Property+prop_initVP :: V -> Property+prop_lastVP :: V -> Property+prop_maximumVP :: V -> Property+prop_minimumVP :: V -> Property+prop_tailVP :: V -> Property+prop_foldl1VP :: (W -> W -> W) -> V -> Property+prop_foldl1VP' :: (W -> W -> W) -> V -> Property+prop_foldr1VP :: (W -> W -> W) -> V -> Property+prop_scanlVP :: (W -> W -> W) -> W -> V -> Property+prop_scanrVP :: (W -> W -> W) -> W -> V -> Property+prop_eqVP :: V -> V -> Bool+prop_foldlVP :: (X -> W -> X) -> X -> V -> Bool+prop_foldlVP' :: (X -> W -> X) -> X -> V -> Bool+prop_foldrVP :: (W -> X -> X) -> X -> V -> Bool+prop_mapAccumLVP :: (X -> W -> (X, W)) -> X -> V -> Bool+prop_mapAccumRVP :: (X -> W -> (X, W)) -> X -> V -> Bool+prop_zipWithVP :: (W -> W -> W) -> V -> V -> Bool++prop_concatVP       = V.concat  `eq1`  P.concat+prop_nullVP         = V.null  `eq1`  P.null+prop_reverseVP      = V.reverse  `eq1`  P.reverse+prop_transposeVP    = V.transpose  `eq1`  P.transpose+prop_groupVP        = V.group  `eq1`  P.group+prop_initsVP        = V.inits  `eq1`  P.inits+prop_tailsVP        = V.tails  `eq1`  P.tails+prop_allVP          = V.all  `eq2`  P.all+prop_anyVP          = V.any  `eq2`  P.any+prop_appendVP       = V.append  `eq2`  P.append+prop_breakVP        = V.break  `eq2`  P.break+prop_concatMapVP    = V.concatMap  `eq2`  P.concatMap+prop_consVP         = V.cons  `eq2`  P.cons+prop_countVP        = V.count  `eq2`  P.count+prop_dropVP         = V.drop  `eq2`  P.drop+prop_dropWhileVP    = V.dropWhile  `eq2`  P.dropWhile+prop_filterVP       = V.filter  `eq2`  P.filter+prop_findVP         = V.find  `eq2`  P.find+prop_findIndexVP    = V.findIndex  `eq2`  P.findIndex+prop_findIndicesVP  = V.findIndices  `eq2`  P.findIndices+prop_isPrefixOfVP   = V.isPrefixOf  `eq2`  P.isPrefixOf+prop_mapVP          = V.map  `eq2`  P.map+prop_replicateVP    = (\n -> V.replicate n  `eq1`  P.replicate n) . limit+prop_iterateVP      = (\n f -> V.iterateN n f  `eq1`  P.pack . take n . iterate f) . limit+prop_snocVP         = V.snoc  `eq2`  P.snoc+prop_spanVP         = V.span  `eq2`  P.span+prop_splitVP        = V.split  `eq2`  P.split+prop_splitAtVP      = V.splitAt  `eq2`  P.splitAt+prop_takeVP         = V.take  `eq2`  P.take+prop_takeWhileVP    = V.takeWhile  `eq2`  P.takeWhile+prop_elemVP         = V.elem  `eq2`  P.elem+prop_notElemVP      = V.notElem  `eq2`  P.notElem+prop_elemIndexVP    = V.elemIndex  `eq2`  P.elemIndex+prop_elemIndicesVP  = V.elemIndices  `eq2`  P.elemIndices+prop_lengthVP       = V.length  `eq1`  P.length++prop_headVP         = V.head  `eqnotnull1`  P.head+prop_initVP         = V.init  `eqnotnull1`  P.init+prop_lastVP         = V.last  `eqnotnull1`  P.last+prop_maximumVP      = V.maximum  `eqnotnull1`  P.maximum+prop_minimumVP      = V.minimum  `eqnotnull1`  P.minimum+prop_tailVP         = V.tail  `eqnotnull1`  P.tail+prop_foldl1VP       = V.foldl1  `eqnotnull2`  P.foldl1+prop_foldl1VP'      = V.foldl1'  `eqnotnull2`  P.foldl1'+prop_foldr1VP       = V.foldr1  `eqnotnull2`  P.foldr1+prop_scanlVP        = V.scanl  `eqnotnull3`  P.scanl+prop_scanrVP        = V.scanr  `eqnotnull3`  P.scanr++prop_eqVP =+   eq2+      ((==) :: V -> V -> Bool)+      ((==) :: P -> P -> Bool)+prop_foldlVP f b as =+   uncurry eq0+      ((V.foldl, P.foldl) `applyId` f `applyId` b `applyModel` as)+prop_foldlVP' f b as =+   uncurry eq0+      ((V.foldl', P.foldl') `applyId` f `applyId` b `applyModel` as)+prop_foldrVP f b as =+   uncurry eq0+      ((V.foldr, P.foldr) `applyId` f `applyId` b `applyModel` as)+prop_mapAccumLVP f b as =+   uncurry eq0+      ((V.mapAccumL, P.mapAccumL) `applyId` f `applyId` b `applyModel` as)+prop_mapAccumRVP f b as =+   uncurry eq0+      ((V.mapAccumR, P.mapAccumR) `applyId` f `applyId` b `applyModel` as)+prop_zipWithVP f xs ys =+   uncurry eq0+      ((V.zipWith f, \x y -> P.pack (P.zipWith f x y)) `applyModel` xs `applyModel` ys)++prop_unfoldrVP :: Int -> (X -> Maybe (W, X)) -> X -> Bool+prop_unfoldrVP n0 f =+    let n = limit n0+    in  eq1+           (fst . V.unfoldrN n f)+           (fst . P.unfoldrN n f)+++vp_tests :: [(String, IO ())]+vp_tests =+   ("all",         quickCheck prop_allVP) :+   ("any",         quickCheck prop_anyVP) :+   ("append",      quickCheck prop_appendVP) :+   ("concat",      quickCheck prop_concatVP) :+   ("cons",        quickCheck prop_consVP) :+   ("eq",          quickCheck prop_eqVP) :+   ("filter",      quickCheck prop_filterVP) :+   ("find",        quickCheck prop_findVP) :+   ("findIndex",   quickCheck prop_findIndexVP) :+   ("findIndices", quickCheck prop_findIndicesVP) :+   ("foldl",       quickCheck prop_foldlVP) :+   ("foldl'",      quickCheck prop_foldlVP') :+   ("foldl1",      quickCheck prop_foldl1VP) :+   ("foldl1'",     quickCheck prop_foldl1VP') :+   ("foldr",       quickCheck prop_foldrVP) :+   ("foldr1",      quickCheck prop_foldr1VP) :+   ("mapAccumL",   quickCheck prop_mapAccumLVP) :+   ("mapAccumR",   quickCheck prop_mapAccumRVP) :+   ("zipWith",     quickCheck prop_zipWithVP) :+   ("unfoldr",     quickCheck prop_unfoldrVP) :+   ("head",        quickCheck prop_headVP) :+   ("init",        quickCheck prop_initVP) :+   ("isPrefixOf",  quickCheck prop_isPrefixOfVP) :+   ("last",        quickCheck prop_lastVP) :+   ("length",      quickCheck prop_lengthVP) :+   ("map",         quickCheck prop_mapVP) :+   ("maximum",     quickCheck prop_maximumVP) :+   ("minimum",     quickCheck prop_minimumVP) :+   ("null",        quickCheck prop_nullVP) :+   ("reverse",     quickCheck prop_reverseVP) :+   ("snoc",        quickCheck prop_snocVP) :+   ("tail",        quickCheck prop_tailVP) :+   ("scanl",       quickCheck prop_scanlVP) :+   ("scanr",       quickCheck prop_scanrVP) :+   ("transpose",   quickCheck prop_transposeVP) :+   ("replicate",   quickCheck prop_replicateVP) :+   ("iterateN",    quickCheck prop_iterateVP) :+   ("take",        quickCheck prop_takeVP) :+   ("drop",        quickCheck prop_dropVP) :+   ("splitAt",     quickCheck prop_splitAtVP) :+   ("takeWhile",   quickCheck prop_takeWhileVP) :+   ("dropWhile",   quickCheck prop_dropWhileVP) :+   ("break",       quickCheck prop_breakVP) :+   ("span",        quickCheck prop_spanVP) :+   ("split",       quickCheck prop_splitVP) :+   ("count",       quickCheck prop_countVP) :+   ("group",       quickCheck prop_groupVP) :+   ("inits",       quickCheck prop_initsVP) :+   ("tails",       quickCheck prop_tailsVP) :+   ("elem",        quickCheck prop_elemVP) :+   ("notElem",     quickCheck prop_notElemVP) :+   ("elemIndex",   quickCheck prop_elemIndexVP) :+   ("elemIndices", quickCheck prop_elemIndicesVP) :+   ("concatMap",   quickCheck prop_concatMapVP) :+   []+++main :: IO ()+main = run vp_tests++run :: [(String, IO ())] -> IO ()+run tests = do+    mapM_ (\(s,a) -> printf "%-25s: " s >> a) tests
+ tests/Test/Utility.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+module Test.Utility where++import Test.QuickCheck (Property, (==>), )+import Text.Show.Functions ()++import Data.Word (Word8)+import Data.Int (Int64)++import qualified Data.ByteString      as P+import qualified Data.StorableVector  as V++import qualified Data.ByteString.Char8 as PC+++{- |+Class allows to compare StorableVector implementation+with implementations for similar data structures,+here ByteString and [Word8].+-}+class Model a b where+   model :: a -> b++instance Model P [W]    where model = P.unpack+instance Model P [Char] where model = PC.unpack+instance Model V [W]    where model = V.unpack+instance Model V P      where model = P.pack . V.unpack++instance Model Bool  Bool         where model = id+instance Model Int   Int          where model = id+instance Model Int64 Int64        where model = id+instance Model Int64 Int          where model = fromIntegral+instance Model Word8 Word8        where model = id+instance Model Ordering Ordering  where model = id+instance Model Char Char          where model = id++instance (Model x y) => Model (a -> x) (a -> y) where+   model f = model . f++instance (Model x y) => Model (Maybe x) (Maybe y) where+   model = fmap model++instance (Model x y) => Model [x] [y] where+   model = fmap model++instance+   (Model x0 y0, Model x1 y1) =>+      Model (x0,x1) (y0,y1) where+   model (x0,x1) = (model x0, model x1)+++type X = Int+type W = Word8+type P = P.ByteString+type V = V.Vector Word8+++infixl 0 `applyId`, `applyModel`++applyId :: (a -> x, a -> y) -> a -> (x,y)+applyId (f,g) a = (f a, g a)++applyModel :: (Model x0 y0) => (x0 -> x, y0 -> y) -> x0 -> (x,y)+applyModel (f,g) x = (f x, g $ model x)+++{-+These comparison functions handle wrapping and equality automatically.+-}+eq0 ::+   (Model x y, Eq y) =>+   x -> y -> Bool++eq1 ::+   (Model x1 y1, Model x y, Eq y) =>+   (x1 -> x) -> (y1 -> y) -> x1 -> Bool++eq2 ::+   (Model x2 y2, Model x1 y1, Model x y, Eq y) =>+   (x2 -> x1 -> x) -> (y2 -> y1 -> y) -> x2 -> x1 -> Bool++eq3 ::+   (Model x3 y3, Model x2 y2, Model x1 y1, Model x y, Eq y) =>+   (x3 -> x2 -> x1 -> x) -> (y3 -> y2 -> y1 -> y) -> x3 -> x2 -> x1 -> Bool++eq4 ::+   (Model x4 y4, Model x3 y3, Model x2 y2, Model x1 y1, Model x y, Eq y) =>+   (x4 -> x3 -> x2 -> x1 -> x) ->+   (y4 -> y3 -> y2 -> y1 -> y) ->+   x4 -> x3 -> x2 -> x1 -> Bool++eq5 ::+   (Model x5 y5, Model x4 y4, Model x3 y3, Model x2 y2, Model x1 y1, Model x y, Eq y) =>+   (x5 -> x4 -> x3 -> x2 -> x1 -> x) ->+   (y5 -> y4 -> y3 -> y2 -> y1 -> y) ->+   x5 -> x4 -> x3 -> x2 -> x1 -> Bool+++infix 4 `eq1`, `eq2`, `eq3`, `eq4`, `eq5`++eq0 f g =+    model  f            == g+eq1 f g = \a         ->+    model (f a)         == g (model a)+eq2 f g = \a b       ->+    model (f a b)       == g (model a) (model b)+eq3 f g = \a b c     ->+    model (f a b c)     == g (model a) (model b) (model c)+eq4 f g = \a b c d   ->+    model (f a b c d)   == g (model a) (model b) (model c) (model d)+eq5 f g = \a b c d e ->+    model (f a b c d e) == g (model a) (model b) (model c) (model d) (model e)+++{-+Handle functions that require non-empty input.+-}+eqnotnull1 ::+   (Model x y, Model x1 y1, IsNull x1, Eq y) =>+   (x1 -> x) -> (y1 -> y) -> x1 -> Property++eqnotnull2 ::+   (Model x y, Model x1 y1, Model x2 y2, IsNull x1, Eq y) =>+   (x2 -> x1 -> x) -> (y2 -> y1 -> y) -> x2 -> x1 -> Property++eqnotnull3 ::+   (Model x y, Model x1 y1, Model x2 y2, Model x3 y3, IsNull x1,+    Eq y) =>+   (x3 -> x2 -> x1 -> x) ->+   (y3 -> y2 -> y1 -> y) ->+   x3 -> x2 -> x1 -> Property++eqnotnull1 f g = \x     -> not (isNull x) ==> eq1 f g x+eqnotnull2 f g = \x y   -> not (isNull y) ==> eq2 f g x y+eqnotnull3 f g = \x y z -> not (isNull z) ==> eq3 f g x y z++class    IsNull t            where isNull :: t -> Bool+instance IsNull P.ByteString where isNull = P.null+instance IsNull V            where isNull = V.null
− tests/tests.hs 
@@ -1,160 +0,0 @@-{-# OPTIONS_GHC -O #-}-import qualified Data.StorableVector as V-import qualified Data.ByteString as P-import QuickCheckUtils-          (V, W, X, P, mytest,-           eq1, eq2, eq3, eqnotnull1, eqnotnull2, eqnotnull3, )-import Text.Printf (printf)-import System.Environment (getArgs)------- Data.StorableVector <=> ByteString-----prop_concatVP       = (V.concat :: [V] -> V) `eq1`  P.concat-prop_nullVP         = (V.null :: V -> Bool)        `eq1`  P.null-prop_reverseVP      = (V.reverse :: V -> V)    `eq1`  P.reverse-prop_transposeVP    = (V.transpose :: [V] -> [V])  `eq1`  P.transpose-prop_groupVP        = (V.group :: V -> [V])      `eq1`  P.group-prop_initsVP        = (V.inits :: V -> [V])      `eq1`  P.inits-prop_tailsVP        = (V.tails :: V -> [V])      `eq1`  P.tails-prop_allVP          = (V.all :: (W -> Bool) -> V -> Bool) `eq2`  P.all-prop_anyVP          = (V.any :: (W -> Bool) -> V -> Bool) `eq2`  P.any-prop_appendVP       = (V.append :: V -> V -> V)     `eq2`  P.append-prop_breakVP        = (V.break :: (W -> Bool) -> V -> (V, V))      `eq2`  P.break-prop_concatMapVP    = (V.concatMap :: (W -> V) -> V -> V) `eq2`  P.concatMap-prop_consVP         = (V.cons :: W -> V -> V)       `eq2`  P.cons-prop_countVP        = (V.count :: W -> V -> X)      `eq2`  P.count-prop_dropVP         = (V.drop :: X -> V -> V)       `eq2`  P.drop-prop_dropWhileVP    = (V.dropWhile :: (W -> Bool) -> V -> V)  `eq2`  P.dropWhile-prop_filterVP       = (V.filter :: (W -> Bool) -> V -> V)     `eq2`  P.filter-prop_findVP         = (V.find :: (W -> Bool) -> V -> Maybe W)       `eq2`  P.find-prop_findIndexVP    = (V.findIndex :: (W -> Bool) -> V -> Maybe X)  `eq2`  P.findIndex-prop_findIndicesVP  = (V.findIndices :: (W -> Bool) -> V -> [X]) `eq2`  P.findIndices-prop_isPrefixOfVP   = (V.isPrefixOf :: V -> V -> Bool) `eq2`  P.isPrefixOf-prop_mapVP          = (V.map :: (W -> W) -> V -> V)        `eq2`  P.map-prop_replicateVP    = (V.replicate :: X -> W -> V)  `eq2`  P.replicate-prop_iterateVP      = (V.iterateN :: X -> (W -> W) -> W -> V)  `eq3`  (\n f -> P.pack . take n . iterate f)-prop_snocVP         = (V.snoc :: V -> W -> V)       `eq2`  P.snoc-prop_spanVP         = (V.span :: (W -> Bool) -> V -> (V, V))       `eq2`  P.span-prop_splitVP        = (V.split :: W -> V -> [V])      `eq2`  P.split-prop_splitAtVP      = (V.splitAt :: X -> V -> (V, V))    `eq2`  P.splitAt-prop_takeVP         = (V.take :: X -> V -> V)       `eq2`  P.take-prop_takeWhileVP    = (V.takeWhile :: (W -> Bool) -> V -> V)  `eq2`  P.takeWhile-prop_elemVP         = (V.elem :: W -> V -> Bool)       `eq2`  P.elem-prop_notElemVP      = (V.notElem :: W -> V -> Bool)    `eq2`  P.notElem-prop_elemIndexVP    = (V.elemIndex :: W -> V -> Maybe X)  `eq2`  P.elemIndex-prop_elemIndicesVP  = (V.elemIndices :: W -> V -> [X])`eq2`  P.elemIndices-prop_lengthVP       = (V.length :: V -> X)     `eq1`  P.length--prop_headVP         = (V.head :: V -> W)        `eqnotnull1` P.head-prop_initVP         = (V.init :: V -> V)       `eqnotnull1` P.init-prop_lastVP         = (V.last :: V -> W)       `eqnotnull1` P.last-prop_maximumVP      = (V.maximum :: V -> W)    `eqnotnull1` P.maximum-prop_minimumVP      = (V.minimum :: V -> W)    `eqnotnull1` P.minimum-prop_tailVP         = (V.tail :: V -> V)       `eqnotnull1` P.tail-prop_foldl1VP       = (V.foldl1 :: (W -> W -> W) -> V -> W)     `eqnotnull2` P.foldl1-prop_foldl1VP'      = (V.foldl1' :: (W -> W -> W) -> V -> W)    `eqnotnull2` P.foldl1'-prop_foldr1VP       = (V.foldr1 :: (W -> W -> W) -> V -> W)      `eqnotnull2` P.foldr1-prop_scanlVP        = (V.scanl :: (W -> W -> W) -> W -> V -> V)      `eqnotnull3` P.scanl-prop_scanrVP        = (V.scanr :: (W -> W -> W) -> W -> V -> V)      `eqnotnull3` P.scanr--prop_eqVP        = eq2-    ((==) :: V -> V -> Bool)-    ((==) :: P -> P -> Bool)-prop_foldlVP     = eq3-    (V.foldl     :: (X -> W -> X) -> X -> V -> X)-    (P.foldl     :: (X -> W -> X) -> X -> P -> X)-prop_foldlVP'    = eq3-    (V.foldl'    :: (X -> W -> X) -> X -> V -> X)-    (P.foldl'    :: (X -> W -> X) -> X -> P -> X)-prop_foldrVP     = eq3-    (V.foldr     :: (W -> X -> X) -> X -> V -> X)-    (P.foldr     :: (W -> X -> X) -> X -> P -> X)-prop_mapAccumLVP = eq3-    (V.mapAccumL :: (X -> W -> (X,W)) -> X -> V -> (X, V))-    (P.mapAccumL :: (X -> W -> (X,W)) -> X -> P -> (X, P))-prop_mapAccumRVP = eq3-    (V.mapAccumR :: (X -> W -> (X,W)) -> X -> V -> (X, V))-    (P.mapAccumR :: (X -> W -> (X,W)) -> X -> P -> (X, P))-prop_zipWithVP = eq3-    (V.zipWith :: (W -> W -> W) -> V -> V -> V)---    (P.zipWith :: (W -> W -> W) -> P -> P -> P)-    (\f x y -> P.pack (P.zipWith f x y) :: P)--prop_unfoldrVP   = eq3-    ((\n f a -> V.take (fromIntegral n) $-        V.unfoldr    f a) :: Int -> (X -> Maybe (W,X)) -> X -> V)-    ((\n f a ->                     fst $-        P.unfoldrN n f a) :: Int -> (X -> Maybe (W,X)) -> X -> P)----------------------------------------------------------------------------- StorableVector <=> ByteString--vp_tests =-    [("all",         mytest prop_allVP)-    ,("any",         mytest prop_anyVP)-    ,("append",      mytest prop_appendVP)-    ,("concat",      mytest prop_concatVP)-    ,("cons",        mytest prop_consVP)-    ,("eq",          mytest prop_eqVP)-    ,("filter",      mytest prop_filterVP)-    ,("find",        mytest prop_findVP)-    ,("findIndex",   mytest prop_findIndexVP)-    ,("findIndices", mytest prop_findIndicesVP)-    ,("foldl",       mytest prop_foldlVP)-    ,("foldl'",      mytest prop_foldlVP')-    ,("foldl1",      mytest prop_foldl1VP)-    ,("foldl1'",     mytest prop_foldl1VP')-    ,("foldr",       mytest prop_foldrVP)-    ,("foldr1",      mytest prop_foldr1VP)-    ,("mapAccumL",   mytest prop_mapAccumLVP)-    ,("mapAccumR",   mytest prop_mapAccumRVP)-    ,("zipWith",     mytest prop_zipWithVP)-    -- ,("unfoldr",     mytest prop_unfoldrVP)-    ,("head",        mytest prop_headVP)-    ,("init",        mytest prop_initVP)-    ,("isPrefixOf",  mytest prop_isPrefixOfVP)-    ,("last",        mytest prop_lastVP)-    ,("length",      mytest prop_lengthVP)-    ,("map",         mytest prop_mapVP)-    ,("maximum   ",  mytest prop_maximumVP)-    ,("minimum"   ,  mytest prop_minimumVP)-    ,("null",        mytest prop_nullVP)-    ,("reverse",     mytest prop_reverseVP)-    ,("snoc",        mytest prop_snocVP)-    ,("tail",        mytest prop_tailVP)-    ,("scanl",       mytest prop_scanlVP)-    ,("scanr",       mytest prop_scanrVP)-    ,("transpose",   mytest prop_transposeVP)-    ,("replicate",   mytest prop_replicateVP)-    ,("iterateN",    mytest prop_iterateVP)-    ,("take",        mytest prop_takeVP)-    ,("drop",        mytest prop_dropVP)-    ,("splitAt",     mytest prop_splitAtVP)-    ,("takeWhile",   mytest prop_takeWhileVP)-    ,("dropWhile",   mytest prop_dropWhileVP)-    ,("break",       mytest prop_breakVP)-    ,("span",        mytest prop_spanVP)-    ,("split",       mytest prop_splitVP)-    ,("count",       mytest prop_countVP)-    ,("group",       mytest prop_groupVP)-    ,("inits",       mytest prop_initsVP)-    ,("tails",       mytest prop_tailsVP)-    ,("elem",        mytest prop_elemVP)-    ,("notElem",     mytest prop_notElemVP)-    ,("elemIndex",   mytest prop_elemIndexVP)-    ,("elemIndices", mytest prop_elemIndicesVP)-    ,("concatMap",   mytest prop_concatMapVP)-    ]----------------------------------------------------------------------------- The entry point--main = run vp_tests--run :: [(String, Int -> IO ())] -> IO ()-run tests = do-    x <- getArgs-    let n = if null x then 100 else read . head $ x-    mapM_ (\(s,a) -> printf "%-25s: " s >> a n) tests