storablevector 0.2.1 → 0.2.2
raw patch · 13 files changed
+932/−893 lines, 13 filesdep +non-negativedep +transformersdep +utility-htdep −mtl
Dependencies added: non-negative, transformers, utility-ht
Dependencies removed: mtl
Files
- Data/StorableVector.hs +259/−184
- Data/StorableVector/Base.hs +3/−15
- Data/StorableVector/Cursor.hs +100/−38
- Data/StorableVector/Lazy.hs +64/−35
- Data/StorableVector/Lazy/Builder.hs +87/−0
- Data/StorableVector/Lazy/Pattern.hs +344/−0
- Data/StorableVector/LazySize.hs +0/−135
- Data/StorableVector/LazyVarying.hs +0/−403
- Data/StorableVector/ST/Lazy.hs +1/−1
- Data/StorableVector/ST/Private.hs +52/−0
- Data/StorableVector/ST/Strict.hs +6/−27
- Data/StorableVector/Utility.hs +0/−46
- storablevector.cabal +16/−9
Data/StorableVector.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-}+{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans #-} -- -- Module : StorableVector -- Copyright : (c) The University of Glasgow 2001,@@ -7,12 +7,12 @@ -- (c) Don Stewart 2005-2006 -- (c) Bjorn Bringert 2006 -- (c) Spencer Janssen 2006--- (c) Henning Thielemann 2008+-- (c) Henning Thielemann 2008-2009 -- -- -- License : BSD-style ----- Maintainer : sjanssen@cse.unl.edu+-- Maintainer : Henning Thielemann -- Stability : experimental -- Portability : portable, requires ffi and cpp -- Tested with : GHC 6.4.1 and Hugs March 2005@@ -34,7 +34,8 @@ -- 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 and mutable access in ST monad by Henning Thieleman.+-- Chunky lazy stream, also with chunk pattern control,+-- mutable access in ST monad, Builder monoid by Henning Thieleman. module Data.StorableVector ( @@ -46,6 +47,7 @@ singleton, pack, unpack,+ packN, packWith, unpackWith, @@ -100,6 +102,7 @@ replicate, unfoldr, unfoldrN,+ sample, -- * Substrings @@ -179,36 +182,32 @@ import Data.StorableVector.Base 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 (withForeignPtr, )+import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, ) import Foreign.Marshal.Array (advancePtr, copyArray, ) import Foreign.Ptr (Ptr, minusPtr, ) import Foreign.Storable (Storable(..)) import Data.Monoid (Monoid, mempty, mappend, mconcat, )+import Control.Monad (mplus, guard, when, ) import System.IO (openBinaryFile, hClose, hFileSize, hGetBuf, hPutBuf, Handle, IOMode(..), ) -import System.IO.Unsafe+import System.IO.Unsafe (unsafePerformIO, ) -- import GHC.IOBase -- ----------------------------------------------------------------------------------- Useful macros, until we have bang patterns--- -#define STRICT1(f) f _a | _a `seq` False = undefined-#define STRICT2(f) f _a _b | _a `seq` _b `seq` False = undefined-#define STRICT3(f) f _a _b _c | _a `seq` _b `seq` _c `seq` False = undefined-#define STRICT4(f) f _a _b _c _d | _a `seq` _b `seq` _c `seq` _d `seq` False = undefined-#define STRICT5(f) f _a _b _c _d e | _a `seq` _b `seq` _c `seq` _d `seq` _e `seq` False = undefined---- ------------------------------------------------------------------------------ instance (Storable a, Eq a) => Eq (Vector a) where (==) = eq @@ -243,9 +242,17 @@ pack :: (Storable a) => [a] -> Vector a pack str = unsafeCreate (P.length str) $ \p -> go p str where- go _ [] = return ()- go p (x:xs) = poke p x >> go (p `advancePtr` 1) xs+ go = Strict.arguments2 $ \p ->+ ListHT.switchL+ (return ())+ (\x xs -> poke p x >> go (p `advancePtr` 1) 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 (:) []@@ -257,13 +264,29 @@ packWith :: (Storable b) => (a -> b) -> [a] -> Vector b packWith k str = unsafeCreate (P.length str) $ \p -> go p str where- STRICT2(go)- go _ [] = return ()- go p (x:xs) = poke p (k x) >> go (p `advancePtr` 1) xs -- less space than pokeElemOff+ go = Strict.arguments2 $ \p ->+ ListHT.switchL+ (return ())+ (\x xs -> poke p (k x) >> go (p `advancePtr` 1) 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 (SV ps s l) = inlinePerformIO $ withForeignPtr ps $ \p -> go (p `advancePtr` s) (l - 1) []@@ -273,6 +296,17 @@ 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 @@ -292,9 +326,7 @@ -- worth around 10% in speed testing. -- -#if defined(__GLASGOW_HASKELL__) {-# INLINE [1] length #-}-#endif ------------------------------------------------------------------------ @@ -347,9 +379,10 @@ -- | /O(n)/ Append two Vectors append :: (Storable a) => Vector a -> Vector a -> Vector a-append xs ys | null xs = ys- | null ys = xs- | otherwise = concat [xs,ys]+append xs ys =+ if' (null xs) ys $+ if' (null ys) xs $+ concat [xs,ys] {-# INLINE append #-} -- ---------------------------------------------------------------------@@ -359,22 +392,32 @@ -- element of @xs@. map :: (Storable a, Storable b) => (a -> b) -> Vector a -> Vector b map f (SV fp s len) = inlinePerformIO $ withForeignPtr fp $ \a ->- create len $ map_ 0 (a `advancePtr` s)- where- STRICT3(map_)- map_ n p1 p2- | n >= len = return ()- | otherwise = do- x <- peekElemOff p1 n- pokeElemOff p2 n (f x)- map_ (n+1) p1 p2+ create len $+ let go = Strict.arguments3 $+ \ n p1 p2 ->+ when (n>0) $+ do poke p2 . f =<< peek p1+ go (n-1) (p1 `advancePtr` 1) (p2 `advancePtr` 1)+ in go len (a `advancePtr` s) {-# INLINE map #-} +{-+mapByIndex :: (Storable a, Storable b) => (a -> b) -> Vector a -> Vector b+mapByIndex f (SV fp s len) = inlinePerformIO $ withForeignPtr fp $ \a ->+ create len $ \p2 ->+ let p1 = a `advancePtr` s+ go = Strict.arguments1 $ \ n ->+ when (n<len) $+ do pokeElemOff p2 n . f =<< peekElemOff p1 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 (SV x s l) = unsafeCreate l $ \p -> withForeignPtr x $ \f ->- sequence_ [peekElemOff (f `advancePtr` s) i >>= pokeElemOff p (l - i - 1)- | i <- [0 .. l - 1]]+ sequence_ [peekElemOff (f `advancePtr` s) i >>= pokeElemOff p (l - i - 1)+ | i <- [0 .. l - 1]] -- | /O(n)/ The 'intersperse' function takes a element and a -- 'Vector' and \`intersperses\' that element between the elements of@@ -396,30 +439,82 @@ -- 'Vector' using the binary operator, from left to right. -- This function is subject to array fusion. foldl :: (Storable a) => (b -> a -> b) -> b -> Vector a -> b-foldl f v (SV x s l) = inlinePerformIO $ withForeignPtr x $ \ptr ->- lgo v (ptr `advancePtr` s) (ptr `advancePtr` (s+l))- where- STRICT3(lgo)- lgo z p q | p == q = return z- | otherwise = do c <- peek p- lgo (f z c) (p `advancePtr` 1) q+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.--- Though actually foldl is also strict in the accumulator. foldl' :: (Storable a) => (b -> a -> b) -> b -> Vector a -> b-foldl' = foldl+foldl' f v (SV x s l) =+ unsafePerformIO $ withForeignPtr x $ \ptr ->+ let sptr = ptr `advancePtr` s+ q = sptr `advancePtr` l+ go = Strict.arguments2 $ \p z ->+ if p == q+ then return z+ else go (p `advancePtr` 1) . f z =<< peek p+ in go sptr v {-# INLINE foldl' #-} -- | 'foldr', applied to a binary operator, a starting value -- (typically the right-identity of the operator), and a 'Vector', -- reduces the 'Vector' using the binary operator, from right to left. foldr :: (Storable a) => (a -> b -> b) -> b -> Vector a -> b-foldr k z =- let recurse = switchL z (\h t -> k h (recurse t))- in recurse+foldr = foldrByLoop {-# INLINE foldr #-} +{-+*Data.StorableVector> List.length $ foldrBySwitch (:) [] $ replicate 1000000 'a'+1000000+(11.29 secs, 1183476300 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.+-}+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 #-}++{-+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.@@ -457,46 +552,31 @@ concat :: (Storable a) => [Vector a] -> Vector a concat [] = empty concat [ps] = ps-concat xs = unsafeCreate len $ \ptr -> go xs ptr+concat xs = unsafeCreate len $ \ptr -> go ptr xs where len = P.sum . P.map length $ xs- STRICT2(go)- go [] _ = return ()- go (SV p s l:ps) ptr = do- withForeignPtr p $ \fp -> copyArray ptr (fp `advancePtr` s) l- go ps (ptr `advancePtr` l)+ go =+ Strict.arguments2 $ \ptr ->+ ListHT.switchL+ (return ())+ (\(SV fp s l) ps -> do+ withForeignPtr fp $ \p -> copyArray ptr (p `advancePtr` s) l+ go (ptr `advancePtr` l) 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 . foldr ((:) . f) []+concatMap f = concat . unpackWith f {-# INLINE concatMap #-} -- | /O(n)/ Applied to a predicate and a 'Vector', 'any' determines if -- any element of the 'Vector' satisfies the predicate. any :: (Storable a) => (a -> Bool) -> Vector a -> Bool-any _ (SV _ _ 0) = False-any f (SV x s l) = inlinePerformIO $ withForeignPtr x $ \ptr ->- go (ptr `advancePtr` s) (ptr `advancePtr` (s+l))- where- STRICT2(go)- go p q | p == q = return False- | otherwise = do c <- peek p- if f c then return True- else go (p `advancePtr` 1) q+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 _ (SV _ _ 0) = True-all f (SV x s l) = inlinePerformIO $ withForeignPtr x $ \ptr ->- go (ptr `advancePtr` s) (ptr `advancePtr` (s+l))- where- STRICT2(go)- go p q | p == q = return True -- end of list- | otherwise = do c <- peek p- if f c- then go (p `advancePtr` 1) q- else return False+all f = foldr ((&&) . f) True {-# INLINE all #-} ------------------------------------------------------------------------@@ -664,8 +744,7 @@ unfoldr f = concat . unfoldChunk 32 64 where unfoldChunk n n' x = case unfoldrN n f x of- (s, Nothing) -> s : []- (s, Just x') -> s : unfoldChunk n' (n+n') x'+ (s, mx) -> s : maybe [] (unfoldChunk n' (n+n')) mx {-# INLINE unfoldr #-} -- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a 'Vector' from a seed@@ -678,27 +757,31 @@ -- > fst (unfoldrN n f s) == take n (unfoldr f s) -- unfoldrN :: (Storable b) => Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a)-unfoldrN i f x0- | i < 0 = (empty, Just x0)- | otherwise = unsafePerformIO $ createAndTrim' i $ \p -> go p x0 0- where STRICT3(go)- go p x n =- if n == i- then return (0, n, Just x)- else- case f x of- Nothing -> return (0, n, Nothing)- Just (w,x') -> do poke p w- go (p `advancePtr` 1) x' (n+1)+unfoldrN i f x0 =+ if i < 0+ then (empty, Just x0)+ else unsafePerformIO $ 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, Just x)+ else+ case f x of+ Nothing -> return (0, n, Nothing)+ Just (w,x') -> do poke p w+ go (p `advancePtr` 1) (n+1) x' {-# INLINE unfoldrN #-} unfoldlN :: (Storable b) => Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a) unfoldlN i f x0 | i < 0 = (empty, Just x0)- | otherwise = unsafePerformIO $ createAndTrim' i $ \p -> go (p `advancePtr` i) x0 i- where STRICT3(go)- go p x n =- if n == 0+ | otherwise = unsafePerformIO $ 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@@ -706,9 +789,26 @@ Just (w,x') -> let p' = p `advancePtr` (-1) in do poke p' w- go p' x' (n-1)+ 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 @@ -791,13 +891,12 @@ -- splitWith :: (Storable a) => (a -> Bool) -> Vector a -> [Vector a] splitWith _ (SV _ _ 0) = []-splitWith p ps = loop p ps+splitWith p ps = loop ps where- STRICT2(loop)- loop q qs =- chunk :- switchL [] (\ _ t -> loop q t) rest- where (chunk,rest) = break q qs+ loop =+ uncurry (:) .+ mapSnd (switchL [] (\ _ t -> loop t)) .+ break p {-# INLINE splitWith #-} -- | /O(n)/ Break a 'Vector' into pieces separated by the@@ -880,17 +979,8 @@ -- | /O(n)/ The 'elemIndex' function returns the index of the first -- element in the given 'Vector' which is equal to the query -- element, or 'Nothing' if there is no such element.--- This implementation uses memchr(3). elemIndex :: (Storable a, Eq a) => a -> Vector a -> Maybe Int-elemIndex c (SV x s l) = inlinePerformIO $ withForeignPtr x $ \p -> go p (s + l) 0- where- STRICT3(go)- go p end i | i == end = return Nothing- | otherwise = do- e <- peekElemOff p i- if c == e- then return $ Just (i - s)- else go p end (i + 1)+elemIndex c = findIndex (c==) {-# INLINE elemIndex #-} -- | /O(n)/ The 'elemIndexEnd' function returns the last index of the@@ -902,30 +992,17 @@ -- > (-) (length xs - 1) `fmap` elemIndex c (reverse xs) -- elemIndexEnd :: (Storable a, Eq a) => a -> Vector a -> Maybe Int-elemIndexEnd ch (SV x s l) = inlinePerformIO $ withForeignPtr x $ \p ->- go (p `advancePtr` s) (l-1)- where- STRICT2(go)- go p i | i < 0 = return Nothing- | otherwise = do ch' <- peekElemOff p i- if ch == ch'- then return $ Just i- else go p (i-1)+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.--- This implementation uses memchr(3). elemIndices :: (Storable a, Eq a) => a -> Vector a -> [Int]-elemIndices c ps = loop 0 ps- where STRICT2(loop)- loop n ps' =- switchL []- (\ h t ->- if c == h- then n : loop (n+1) t- else loop (n+1) t)- ps'+elemIndices c = findIndices (c==) {-# INLINE elemIndices #-} -- | count returns the number of times its argument appears in the 'Vector'@@ -934,49 +1011,46 @@ -- -- But more efficiently than using length on the intermediate list. count :: (Storable a, Eq a) => a -> Vector a -> Int-count w sv = List.length $ elemIndices w sv+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 k (SV x s l) = inlinePerformIO $ withForeignPtr x $ \f -> go (f `advancePtr` s) 0- where- STRICT2(go)- go ptr n | n >= l = return Nothing- | otherwise = do w <- peek ptr- if k w- then return (Just n)- else go (ptr `advancePtr` 1) (n+1)+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 -}+ 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 ps = loop 0 ps- where- STRICT2(loop)- loop n qs =- switchL []- (\ h t ->- if p h- then n : loop (n+1) t- else loop (n+1) t) $- qs+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 k (SV x s l) = inlinePerformIO $ withForeignPtr x $ \f -> go (f `advancePtr` s) 0- where- STRICT2(go)- go ptr n | n >= l = return l- | otherwise = do w <- peek ptr- if k w- then return n- else go (ptr `advancePtr` 1) (n+1)+findIndexOrEnd p xs =+ foldr+ (\x k n ->+ if p x then n else k (succ n))+ id xs 0 {-# INLINE findIndexOrEnd #-} -- ---------------------------------------------------------------------@@ -984,7 +1058,7 @@ -- | /O(n)/ 'elem' is the 'Vector' membership predicate. elem :: (Storable a, Eq a) => a -> Vector a -> Bool-elem c ps = case elemIndex c ps of Nothing -> False ; _ -> True+elem c ps = isJust $ elemIndex c ps {-# INLINE elem #-} -- | /O(n)/ 'notElem' is the inverse of 'elem'@@ -996,20 +1070,19 @@ -- returns a 'Vector' containing those elements that satisfy the -- predicate. This function is subject to array fusion. filter :: (Storable a) => (a -> Bool) -> Vector a -> Vector a-filter k ps@(SV x s l)- | null ps = ps- | otherwise = unsafePerformIO $ createAndTrim l $ \p -> withForeignPtr x $ \f ->- let STRICT3(go)- go end i j | i == end = return j- | otherwise = do- w <- peekElemOff f i- if k w- then do- pokeElemOff p j w- go end (i+1) (j + 1)- else- go end (i+1) j- in go (s + l) s 0+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',@@ -1085,7 +1158,7 @@ -- | /O(n)/ Return all initial segments of the given 'Vector', shortest first. inits :: (Storable a) => Vector a -> [Vector a]-inits (SV x s l) = [SV x s n | n <- [0..l]]+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]@@ -1115,15 +1188,13 @@ -- | Outputs a 'Vector' to the specified 'Handle'. hPut :: (Storable a) => Handle -> Vector a -> IO () hPut h v =- if null v- then return ()- else- let (fptr, s, l) = toForeignPtr v- in withForeignPtr fptr $ \ ptr ->- let ptrS = advancePtr ptr s- ptrE = advancePtr ptrS l- -- use advancePtr and minusPtr in order to respect alignment- in hPutBuf h ptrS (minusPtr ptrE ptrS)+ when (not (null v)) $+ let (fptr, s, l) = toForeignPtr v+ in withForeignPtr fptr $ \ ptr ->+ let ptrS = advancePtr ptr s+ 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@@ -1165,6 +1236,11 @@ -- --------------------------------------------------------------------- -- Internal utilities +foreignPeek :: Storable a => ForeignPtr a -> Int -> a+foreignPeek fp k =+ inlinePerformIO $ withForeignPtr fp $ flip peekElemOff k+{-# INLINE foreignPeek #-}+ -- Common up near identical calls to `error' to reduce the number -- constant strings created when compiled: errorEmptyList :: String -> a@@ -1177,8 +1253,7 @@ -- Find from the end of the string using predicate findFromEndUntil :: (Storable a) => (a -> Bool) -> Vector a -> Int-STRICT2(findFromEndUntil)-findFromEndUntil f ps@(SV x s l) =+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 view
@@ -54,25 +54,13 @@ #if defined(__GLASGOW_HASKELL__) import Data.Generics (Data(..), Typeable(..)) import GHC.Base (realWorld#)-import GHC.IOBase (IO(IO), unsafePerformIO, )--#else-import System.IO.Unsafe (unsafePerformIO)+import GHC.IOBase (IO(IO), ) #endif +import System.IO.Unsafe (unsafePerformIO, )+ -- CFILES stuff is Hugs only {-# CFILES cbits/fpstring.c #-}---- ----------------------------------------------------------------------------------- Useful macros, until we have bang patterns-----#define STRICT1(f) f a | a `seq` False = undefined-#define STRICT2(f) f a b | a `seq` b `seq` False = undefined-#define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined-#define STRICT4(f) f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined-#define STRICT5(f) f a b c d e | a `seq` b `seq` c `seq` d `seq` e `seq` False = undefined -- -----------------------------------------------------------------------------
Data/StorableVector/Cursor.hs view
@@ -5,7 +5,7 @@ module Data.StorableVector.Cursor where import Control.Exception (assert, )-import Control.Monad.State (StateT(StateT), runStateT, )+import Control.Monad.Trans.State (StateT(StateT), runStateT, ) import Data.IORef (IORef, newIORef, readIORef, writeIORef, ) import Foreign.Storable (Storable(peekElemOff, pokeElemOff))@@ -18,13 +18,22 @@ import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO, ) -import Data.StorableVector.Utility (- viewListL, mapSnd,- )+import qualified Data.List.HT as ListHT+import Data.Tuple.HT (mapSnd, ) -import Prelude hiding (length, foldr, zipWith, )+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 which 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 =>@@ -40,7 +49,7 @@ data Buffer a = Buffer { memory :: {-# UNPACK #-} !(ForeignPtr a),- size :: {-# UNPACK #-} !Int, -- size of allocated memory+ size :: {-# UNPACK #-} !Int, -- size of allocated memory, I think I only need it for debugging gen :: {-# UNPACK #-} !(Generator a), cursor :: {-# UNPACK #-} !(IORef Int) }@@ -52,7 +61,7 @@ Vector { buffer :: {-# UNPACK #-} !(Buffer a), start :: {-# UNPACK #-} !Int, -- invariant: start <= cursor- maxLen :: {-# UNPACK #-} !Int -- invariant: start+maxLen <= size+ maxLen :: {-# UNPACK #-} !Int -- invariant: start+maxLen <= size buffer } @@ -141,7 +150,7 @@ {-# INLINE pack #-} pack :: (Storable a) => Int -> [a] -> Vector a-pack n = unfoldrNTerm n viewListL+pack n = unfoldrNTerm n ListHT.viewL {-# INLINE cons #-}@@ -194,20 +203,23 @@ -- | evaluate next value in a buffer advanceIO :: Storable a =>- Buffer a -> IO ()+ 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 -> return Nothing Just s0 -> case runStateT n s0 of- Nothing -> writeIORef s Nothing+ Nothing ->+ writeIORef s Nothing >>+ return Nothing Just (a,s1) -> writeIORef s (Just s1) >>- withForeignPtr p (\q -> pokeElemOff q c a)+ withForeignPtr p (\q -> pokeElemOff q c a) >>+ return (Just a) -- | evaluate all values up to a given position evaluateToIO :: Storable a =>@@ -219,37 +231,53 @@ whileM :: Monad m => m Bool -> m a -> m () whileM p f =- let recurse =+ let recourse = do b <- p- when b (f >> recurse)- in recurse+ when b (f >> recourse)+ in recourse {-# INLINE switchL #-} switchL :: Storable a => b -> (a -> Vector a -> b) -> Vector a -> b-switchL n j v = unsafePerformIO (switchLIO n j v)+switchL n j v = maybe n (uncurry j) (viewL v) -switchLIO :: Storable a => b -> (a -> Vector a -> b) -> Vector a -> IO b-switchLIO n j v@(Vector buf st ml) =- nullIO v >>= \ isNull ->- if isNull- then return n- else- do c <- readIORef (cursor buf)- assert (st <= c) $ when (st == c) (advanceIO buf)- x <- withForeignPtr (memory buf) (\p -> peekElemOff p st)- let tl = assert (ml>0) $ Vector buf (succ st) (pred ml)- return (j x tl) +{-+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 = switchL Nothing (curry Just)+viewL v = unsafePerformIO (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 recurse = switchL z (\h t -> k h (recurse t))- in recurse+ let recourse = switchL z (\h t -> k h (recourse t))+ in recourse -- | /O(n)/ Converts a 'Vector a' to a '[a]'. {-# INLINE unpack #-}@@ -262,14 +290,15 @@ {-# INLINE null #-}-null :: Vector a -> Bool-null = unsafePerformIO . nullIO--nullIO :: Vector a -> IO Bool-nullIO (Vector (Buffer _ sz (Generator _ s) _) st _) =- do b <- readIORef s- return (st >= sz || isNothing b)--- assert (l >= 0) $ l <= 0+{-+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)) {-@@ -279,3 +308,36 @@ -} -- length++drop :: (Storable a) => Int -> Vector a -> Vector a+drop n v = unsafePerformIO $ 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 view
@@ -14,11 +14,12 @@ import qualified Data.StorableVector as V import qualified Data.StorableVector.Base as VB +import qualified Numeric.NonNegative.Class as NonNeg++import qualified Data.List.HT as ListHT+import Data.Tuple.HT (mapPair, mapFst, mapSnd, )+import Data.Maybe.HT (toMaybe, ) import Data.Maybe (Maybe(Just), maybe, fromMaybe)-import Data.StorableVector.Utility (- viewListL, viewListR,- mapPair, mapFst, mapSnd, toMaybe,- ) import Foreign.Storable (Storable) @@ -60,7 +61,21 @@ -- for a list of chunk sizes see "Data.StorableVector.LazySize". newtype ChunkSize = ChunkSize Int+ deriving (Eq, Ord, Show) +instance Num ChunkSize where+ (ChunkSize x) + (ChunkSize y) =+ ChunkSize (x+y)+ (-) = error "ChunkSize.-: intentionally unimplemented"+ (*) = error "ChunkSize.*: intentionally unimplemented"+ abs = error "ChunkSize.abs: intentionally unimplemented"+ signum = error "ChunkSize.signum: intentionally unimplemented"+ fromInteger = ChunkSize . fromInteger++instance NonNeg.C ChunkSize where+ (ChunkSize x) -| (ChunkSize y) =+ ChunkSize $ if x >= y then x-y else 0+ chunkSize :: Int -> ChunkSize chunkSize x = ChunkSize $@@ -88,7 +103,7 @@ fromChunks = SV pack :: (Storable a) => ChunkSize -> [a] -> Vector a-pack size = unfoldr size viewListL+pack size = unfoldr size ListHT.viewL unpack :: (Storable a) => Vector a -> [a] unpack = List.concatMap V.unpack . chunks@@ -97,7 +112,7 @@ {-# INLINE packWith #-} packWith :: (Storable b) => ChunkSize -> (a -> b) -> [a] -> Vector b packWith size f =- unfoldr size (fmap (\(a,b) -> (f a, b)) . viewListL)+ unfoldr size (fmap (\(a,b) -> (f a, b)) . ListHT.viewL) {-# INLINE unpackWith #-} unpackWith :: (Storable a) => (a -> b) -> Vector a -> [b]@@ -115,7 +130,17 @@ List.unfoldr (cancelNullVector . V.unfoldrN size f =<<) . Just +{-# 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))@@ -175,7 +200,7 @@ if V.length x + V.length y <= size then V.append x y : ys else x:yt)- (viewListL yt)+ (ListHT.viewL yt) concat :: (Storable a) => [Vector a] -> Vector a@@ -207,7 +232,11 @@ 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 any #-} any :: (Storable a) => (a -> Bool) -> Vector a -> Bool any p = List.any (V.any p) . chunks@@ -242,14 +271,14 @@ {-# INLINE viewL #-} viewL :: Storable a => Vector a -> Maybe (a, Vector a) viewL (SV xs0) =- do (x,xs) <- viewListL 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 ~(xs,x) <- viewListR xs0+ do ~(xs,x) <- ListHT.viewR xs0 let (ys,y) = fromMaybe (error "StorableVector.Lazy.viewR: last chunk empty") (V.viewR x) return (append (SV xs) (fromChunk ys), y) @@ -268,14 +297,14 @@ 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) <- viewListL (List.dropWhile V.null xs0)+ 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) <- viewListR (dropWhileRev V.null xs0)+ do (xs,x) <- ListHT.viewR (dropWhileRev V.null xs0) (ys,y) <- V.viewR x return (append (SV xs) (fromChunk ys), y) -}@@ -328,7 +357,7 @@ -> Vector y crochetL f acc0 = SV . List.unfoldr (\(xt,acc) ->- do (x,xs) <- viewListL xt+ do (x,xs) <- ListHT.viewL xt acc' <- acc return $ mapSnd ((,) xs) $ crochetLChunk f acc' x) . flip (,) (Just acc0) .@@ -360,14 +389,14 @@ {-# INLINE splitAt #-} splitAt :: (Storable a) => Int -> Vector a -> (Vector a, Vector a) splitAt n0 =- let recurse _ [] = ([], [])- recurse 0 xs = ([], xs)- recurse n (x:xs) =+ let recourse _ [] = ([], [])+ recourse 0 xs = ([], xs)+ recourse n (x:xs) = let m = V.length x in if m<=n- then mapFst (x:) $ recurse (n-m) xs+ then mapFst (x:) $ recourse (n-m) xs else mapPair ((:[]), (:xs)) $ V.splitAt n x- in mapPair (SV, SV) . recurse n0 . chunks+ in mapPair (SV, SV) . recourse n0 . chunks @@ -423,13 +452,13 @@ {-# INLINE span #-} span :: (Storable a) => (a -> Bool) -> Vector a -> (Vector a, Vector a) span p =- let recurse [] = ([],[])- recurse (x:xs) =+ let recourse [] = ([],[])+ recourse (x:xs) = let (y,z) = V.span p x in if V.null z- then mapFst (x:) (recurse xs)+ then mapFst (x:) (recourse xs) else (chunks $ fromChunk y, (z:xs))- in mapPair (SV, SV) . recurse . chunks+ in mapPair (SV, SV) . recourse . chunks {- span _ (SV []) = (empty, empty) span p (SV (x:xs)) =@@ -538,14 +567,14 @@ {-# ONLINE pad #-} pad :: (Storable a) => ChunkSize -> a -> Int -> Vector a -> Vector a pad size y n0 =- let recurse n xt =+ let recourse n xt = if n<=0 then xt else case xt of [] -> chunks $ replicate size n y- x:xs -> x : recurse (n - V.length x) xs- in SV . recurse n0 . chunks+ 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 =@@ -581,15 +610,15 @@ reduceLVector :: Storable x => (x -> acc -> Maybe acc) -> acc -> Vector x -> (acc, Bool) reduceLVector f acc0 x =- let recurse i acc =+ let recourse i acc = if i < V.length x then (acc, True) else maybe (acc, False)- (recurse (succ i))+ (recourse (succ i)) (f (V.index x i) acc)- in recurse 0 acc0+ in recourse 0 acc0 @@ -620,7 +649,7 @@ -> T y crochetListL size f = curry (unfoldr size (\(acc,xt) ->- do (x,xs) <- viewListL xt+ do (x,xs) <- ListHT.viewL xt (y,acc') <- f x acc return (y, (acc',xs)))) @@ -644,15 +673,15 @@ reduceL :: Storable x => (x -> acc -> Maybe acc) -> acc -> Vector x -> acc reduceL f acc0 =- let recurse acc xt =+ let recourse acc xt = case xt of [] -> acc (x:xs) -> let (acc',continue) = reduceLVector f acc x in if continue- then recurse acc' xs+ then recourse acc' xs else acc'- in recurse acc0 . chunks+ in recourse acc0 . chunks @@ -840,9 +869,9 @@ Unfoldr a x -> Int lengthUnfoldr (f,a0) =- let recurse n a =- maybe n (recurse (succ n) . snd) (f a)- in recurse 0 a0+ let recourse n a =+ maybe n (recourse (succ n) . snd) (f a)+ in recourse 0 a0 {-# INLINE zipWithUnfoldr #-}@@ -963,7 +992,7 @@ "Storable.reduceL/unfoldr" forall size f g a b. reduceL g b (unfoldr size f a) = snd- (FList.recurse (\(a0,b0) ->+ (FList.recourse (\(a0,b0) -> do (y,a1) <- f a0 b1 <- g y b0 Just (a1, b1)) (a,b)) ;
+ Data/StorableVector/Lazy/Builder.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE Rank2Types #-}+{- |+Build a lazy storable vector by incrementally adding an element.+This is analogous to Data.Binary.Builder for Data.ByteString.Lazy.+-}+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.Lazy as STV+import qualified Data.StorableVector.ST.Private as STVP+import qualified Control.Monad.Trans.RWS as RWS++import Foreign.Storable (Storable, )+import Data.StorableVector.Lazy (ChunkSize(ChunkSize), )+import Control.Monad.ST.Lazy (ST, runST, strictToLazyST, )+import Control.Monad.Trans.RWS (RWST, runRWST, )+import Control.Monad.Trans (lift, )+import Data.Monoid (Monoid(mempty, mappend), Endo(Endo), appEndo, )+++newtype Builder a =+ Builder {run :: forall s.+ RWST ChunkSize (Endo [SV.Vector a]) (STV.Vector s a, Int) (ST s) ()}+++-- instance Monoid (Builder a) where+{-+Storable constraint not need in the current implementation,+but who knows what will be in future ...+-}+instance Storable a => Monoid (Builder a) where+ mempty = Builder (return ())+ mappend x y = Builder (run x >> run y)+++{-+SVL.unpack $ toLazyStorableVector (ChunkSize 7) $ Data.Monoid.mconcat $ map put ['a'..'z']+-}+toLazyStorableVector :: Storable a =>+ ChunkSize -> Builder a -> SVL.Vector a+toLazyStorableVector cs@(SVL.ChunkSize size) bld =+ runST (do+ v0 <- STV.new_ size+ (_,vi1,chunks) <- runRWST (run bld) cs (v0,0)+ lastChunk <- fixVector vi1+ return $ SVL.fromChunks $ appEndo chunks [lastChunk])++put :: Storable a => a -> Builder a+put a =+ Builder (+ do (SVL.ChunkSize size) <- RWS.ask+ (v0,i0) <- RWS.get+ (v1,i1) <-+ if i0<size+ then return (v0,i0)+ else+ -- we could call 'flush' here, but this requires an extra 'SV.take'+ do RWS.tell . Endo . (:) =<<+ (lift $ strictToLazyST $ STVP.unsafeToVector v0)+ lift $ fmap (flip (,) 0) $ STV.new_ size+ lift $ STV.write v1 i1 a+ RWS.put (v1, succ i1)+ )++{- |+Set a laziness break.+-}+flush :: Storable a => Builder a+flush =+ Builder (+ do RWS.tell . Endo . (:) =<< lift . fixVector =<< RWS.get+ (SVL.ChunkSize size) <- RWS.ask+ v1 <- lift $ STV.new_ size+ RWS.put (v1, 0)+ )++fixVector :: (Storable a) =>+ (STVP.Vector s a, Int) -> ST s (SV.Vector a)+fixVector ~(v1,i1) =+ fmap (SV.take i1) $+ strictToLazyST $ STVP.unsafeToVector v1
+ Data/StorableVector/Lazy/Pattern.hs view
@@ -0,0 +1,344 @@+{- |+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,+ 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 Data.Maybe (Maybe(Just, Nothing), )+import qualified Data.List.HT as ListHT+import Data.Tuple.HT (mapPair, mapFst, forcePair, )++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)+-}+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++{-# INLINE take #-}+take :: (Storable a) => LazySize -> Vector a -> Vector a+take _ (SV []) = empty+take 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 n0 =+ 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/LazySize.hs
@@ -1,135 +0,0 @@-{- |-A chunky lazy size type that resembles the NonNegative.Chunky type.--}-module Data.StorableVector.LazySize where--import Data.StorableVector.Lazy- (ChunkSize(ChunkSize), chunkSize, defaultChunkSize, )-import Control.Monad (liftM, liftM2, )-import Data.List (genericReplicate, )--import Test.QuickCheck (Arbitrary(..))---newtype T = Cons {decons :: [ChunkSize]}--intFromChunkSize :: ChunkSize -> Int-intFromChunkSize (ChunkSize x) = x----fromInt :: Int -> T-fromInt x = Cons [chunkSize x]--fromInts :: [Int] -> T-fromInts = Cons . map chunkSize--toInt :: T -> Int-toInt = sum . map intFromChunkSize . decons----instance Show T where- showsPrec p x =- showParen (p>10)- (showString "LazySize.Cons " .- showsPrec 10 (map intFromChunkSize $ decons x))--lift2 :: ([ChunkSize] -> [ChunkSize] -> [ChunkSize]) -> (T -> T -> T)-lift2 f (Cons x) (Cons y) = Cons $ f x y--{- |-Remove zero chunks.--}-normalize :: T -> T-normalize = Cons . filter (\(ChunkSize x) -> x>0) . decons--isNullList :: [ChunkSize] -> Bool-isNullList = null . filter (\(ChunkSize x) -> x>0)--isNull :: T -> Bool-isNull = isNullList . decons- -- null . decons . normalize--isPositive :: T -> Bool-isPositive = not . isNull---check :: String -> Bool -> a -> a-check funcName b x =- if b- then x- else error ("Numeric.NonNegative.Chunky."++funcName++": negative number")---{- |-In @glue x y == (z,r,b)@-@z@ represents @min x y@,-@r@ represents @max x y - min x y@,-and @x<y ==> b@ or @x>y ==> not b@, for @x==y@ the value of b is arbitrary.--}-glue :: [ChunkSize] -> [ChunkSize] -> ([ChunkSize], [ChunkSize], Bool)-glue [] ys = ([], ys, True)-glue xs [] = ([], xs, False)-glue (x@(ChunkSize x0) : xs) (y@(ChunkSize y0) : ys) =- let (z,(zs,rs,b)) =- case compare x0 y0 of- LT -> (x, glue xs (ChunkSize (y0-x0) : ys))- GT -> (y, glue (ChunkSize (x0-y0) : xs) ys)- EQ -> (x, glue xs ys)- in (z:zs,rs,b)---equalList :: [ChunkSize] -> [ChunkSize] -> Bool-equalList x y =- let (_,r,_) = glue x y- in isNullList r--compareList :: [ChunkSize] -> [ChunkSize] -> Ordering-compareList x y =- let (_,r,b) = glue x y- in if isNullList r- then EQ- else if b then LT else GT--minList :: [ChunkSize] -> [ChunkSize] -> [ChunkSize]-minList x y =- let (z,_,_) = glue x y in z--maxList :: [ChunkSize] -> [ChunkSize] -> [ChunkSize]-maxList x y =- let (z,r,_) = glue x y in z++r---instance Eq T where- (Cons x) == (Cons y) = equalList x y--instance Ord T where- compare (Cons x) (Cons y) = compareList x y- min = lift2 minList- max = lift2 maxList--instance Num T where- (+) = lift2 (++)- (Cons x) - (Cons y) =- let (_,d,b) = glue x y- d' = Cons d- in check "-" (not b || isNull d') d'- negate x = check "negate" (isNull x) x- fromInteger x =- let (q,r) = divMod x (fromIntegral $ intFromChunkSize defaultChunkSize)- in Cons $ genericReplicate q defaultChunkSize ++ [ChunkSize (fromInteger r)]- (*) = lift2 (liftM2 (\(ChunkSize x) (ChunkSize y) -> ChunkSize (x*y)))- abs = id- signum = fromInt . (\b -> if b then 1 else 0) . isPositive--instance Arbitrary T where- arbitrary = liftM (normalize . Cons . map (ChunkSize . abs)) arbitrary- coarbitrary = undefined--decrementLimit :: ChunkSize -> T -> T-decrementLimit (ChunkSize x) =- let sub _ [] = []- sub z (ChunkSize y : ys) =- if z<y then ChunkSize (y-z) : ys else sub (z-y) ys- in Cons . sub x . decons
− Data/StorableVector/LazyVarying.hs
@@ -1,403 +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.LazyVarying (- Vector,- ChunkSize,- chunkSize,- defaultChunkSize,-- 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,- dropMarginRem,- dropMargin,- dropWhile,- takeWhile,- span,- filter,- zipWith,- zipWith3,- zipWith4,- zipWithSize,- zipWithSize3,- zipWithSize4,-{-- pad,- cancelNullVector,- fromChunk,- hGetContentsAsync,- hPut,- readFileAsync,- writeFile,- appendFile,--}- ) where--import qualified Data.StorableVector.LazySize 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 Data.Maybe (Maybe(Just, Nothing), )-import Data.StorableVector.Utility (viewListL, mapPair, mapFst, )--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)--}-import Prelude ((.), ($), fst, flip, curry, return, fmap, not, )---type LazySize = LS.T---- * Introducing and eliminating 'Vector's--pack :: (Storable a) => LazySize -> [a] -> Vector a-pack size =- fst . unfoldrN size viewListL---{-# INLINE packWith #-}-packWith :: (Storable b) => LazySize -> (a -> b) -> [a] -> Vector b-packWith size f =- fst . unfoldrN size (fmap (\(a,b) -> (f a, b)) . viewListL)---{--{-# 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 (LS.Cons size) f x =- let go sz y =- 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 size (Just x)---{-# INLINE iterateN #-}-iterateN :: Storable a => LazySize -> (a -> a) -> a -> Vector a-iterateN size f =- fst . unfoldrN size (\x -> Just (x, f x))--replicate :: Storable a => LazySize -> a -> Vector a-replicate size x =- SV $ List.map (\(ChunkSize m) -> V.replicate m x) (LS.decons size)------ * Basic interface--length :: Vector a -> LazySize-length = LS.Cons . List.map chunkLength . LSV.chunks--chunkLength :: V.Vector a -> ChunkSize-chunkLength = ChunkSize . V.length----- * sub-vectors--{-# INLINE take #-}-take :: (Storable a) => LazySize -> Vector a -> Vector a-take _ (SV []) = empty-take (LS.Cons []) _ = empty-take n (SV (x:xs)) =- let remain = LS.decrementLimit (chunkLength x) n- in SV $- if LS.isNull remain- then [V.take (LS.toInt n) x]- else- let (SV ys) = take remain $ SV xs- in x:ys--{-# INLINE drop #-}-drop :: (Storable a) => LazySize -> Vector a -> Vector a-drop (LS.Cons size) xs =- List.foldl (flip (LSV.drop . LS.intFromChunkSize)) xs size--{-# INLINE splitAt #-}-splitAt :: (Storable a) => LazySize -> Vector a -> (Vector a, Vector a)-splitAt (LS.Cons []) = (,) empty-splitAt n0 =- let recurse _ [] = ([], [])- recurse n (x:xs) =- let remain = LS.decrementLimit (chunkLength x) n- in if LS.isNull remain- then mapPair ((:[]), (:xs)) $ V.splitAt (LS.toInt n) x- else mapFst (x:) $ recurse remain xs- in mapPair (SV, SV) . recurse 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 recurse n xt =- if n<=0- then xt- else- case xt of- [] -> chunks $ replicate size n y- x:xs -> x : recurse (n - V.length x) xs- in SV . recurse 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]----{- * 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 =- unsafeInterleaveIO $- 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 liftM (\ ~(err,rest) -> (err, v:rest)) go-{-- unsafeInterleaveIO $- 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 (IOError, Vector a)-hGetContentsSync (ChunkSize size) h =- let go =- flip catch (\err -> return (err,[])) $- do v <- V.hGet h size- if V.null v- then return (Exc.mkIOError Exc.eofErrorType- "StorableVector.Lazy.hGetContentsAsync" (Just h) Nothing, [])- else liftM (\ ~(err,rest) -> (err, v:rest)) go- in fmap (mapSnd 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--}
Data/StorableVector/ST/Lazy.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -fglasgow-exts #-}+{-# LANGUAGE Rank2Types #-} {- | Module : Data.StorableVector.ST.Strict License : BSD-style
+ Data/StorableVector/ST/Private.hs view
@@ -0,0 +1,52 @@+{- |+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 qualified Data.StorableVector as VS++import qualified Control.Monad.ST.Strict as ST+import Control.Monad.ST.Strict (ST, unsafeIOToST, ) -- stToIO,++import Foreign.Ptr (Ptr, )+import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, mallocForeignPtrArray, )+import Foreign.Storable (Storable, )++-- 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 = unsafeIOToST $ 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 view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -fglasgow-exts #-}+{-# LANGUAGE Rank2Types #-} {- | Module : Data.StorableVector.ST.Strict License : BSD-style@@ -24,6 +24,8 @@ mapSTLazy, ) where +import Data.StorableVector.ST.Private+ (Vector(SV), unsafeCreate, unsafeToVector, ) import qualified Data.StorableVector.Base as V import qualified Data.StorableVector as VS import qualified Data.StorableVector.Lazy as VL@@ -32,7 +34,7 @@ import Control.Monad.ST.Strict (ST, unsafeIOToST, runST, ) -- stToIO, import Foreign.Ptr (Ptr, )-import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, mallocForeignPtrArray, unsafeForeignPtrToPtr, )+import Foreign.ForeignPtr (withForeignPtr, unsafeForeignPtrToPtr, ) import Foreign.Storable (Storable(peek, poke)) import Foreign.Marshal.Array (advancePtr, copyArray, ) -- import System.IO.Unsafe (unsafePerformIO)@@ -41,11 +43,6 @@ import Prelude hiding (read, length, ) -data Vector s a =- SV {-# UNPACK #-} !(ForeignPtr a)- {-# UNPACK #-} !Int -- length-- {-# INLINE new #-} {-# INLINE new_ #-} {-# INLINE read #-}@@ -59,24 +56,6 @@ {-# INLINE mapSTLazy #-} --- * helper functions---- | 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 = unsafeIOToST $ create l f--{-# INLINE unsafeToVector #-}-unsafeToVector :: Vector s a -> V.Vector a-unsafeToVector (SV x l) = V.SV x 0 l-- -- * access to mutable storable vector new :: (Storable e) =>@@ -153,7 +132,7 @@ runSTVector :: (Storable e) => (forall s. ST s (Vector s e)) -> VS.Vector e runSTVector m =- runST (fmap unsafeToVector m)+ runST (unsafeToVector =<< m) @@ -177,7 +156,7 @@ go n (unsafeForeignPtrToPtr px `advancePtr` sx) (unsafeForeignPtrToPtr py)- return $! unsafeToVector ys+ unsafeToVector ys {- mapST f xs@(V.SV v s l) =
− Data/StorableVector/Utility.hs
@@ -1,46 +0,0 @@-module Data.StorableVector.Utility where--import qualified Data.List as List--{-# INLINE viewListL #-}-viewListL :: [a] -> Maybe (a, [a])-viewListL [] = Nothing-viewListL (x:xs) = Just (x,xs)---- for constant padding-{-# INLINE viewListR #-}-viewListR :: [a] -> Maybe ([a], a)-viewListR =- List.foldr (\x -> Just . maybe ([],x) (mapFst (x:))) Nothing--{-# INLINE nest #-}-nest :: Int -> (a -> a) -> a -> a-nest 0 _ x = x-nest n f x = f (nest (n-1) f x)----- see event-list package--- | Control.Arrow.***-{-# INLINE mapPair #-}-mapPair :: (a -> c, b -> d) -> (a,b) -> (c,d)-mapPair ~(f,g) ~(x,y) = (f x, g y)---- | Control.Arrow.first-{-# INLINE mapFst #-}-mapFst :: (a -> c) -> (a,b) -> (c,b)-mapFst f ~(x,y) = (f x, y)---- | Control.Arrow.second-{-# INLINE mapSnd #-}-mapSnd :: (b -> d) -> (a,b) -> (a,d)-mapSnd g ~(x,y) = (x, g y)---{-# INLINE toMaybe #-}-toMaybe :: Bool -> a -> Maybe a-toMaybe False _ = Nothing-toMaybe True x = Just x--{-# INLINE swap #-}-swap :: (a,b) -> (b,a)-swap (a,b) = (b,a)
storablevector.cabal view
@@ -1,5 +1,5 @@ Name: storablevector-Version: 0.2.1+Version: 0.2.2 Category: Data Synopsis: Fast, packed, strict storable arrays with a list interface like ByteString Description:@@ -12,15 +12,20 @@ <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/vector>, <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/uvector> with a similar intention.+ .+ We do not provide advanced fusion optimization,+ since especially for lazy vectors+ this would either be incorrect or not applicable.+ For fusion see @storablevector-stream@ package. License: BSD3 License-file: LICENSE-Author: Spencer Janssen <sjanssen@cse.unl.edu>+Author: Spencer Janssen <sjanssen@cse.unl.edu>, Henning Thielemann <storablevector@henning-thielemann.de> Maintainer: Henning Thielemann <storablevector@henning-thielemann.de> Homepage: http://www.haskell.org/haskellwiki/Storable_Vector-Package-URL: http://code.haskell.org/storablevector+Package-URL: http://code.haskell.org/storablevector/ Stability: Experimental Build-Type: Simple-Tested-With: GHC==6.4.1, GHC==6.8.2+Tested-With: GHC==6.8.2 Cabal-Version: >=1.2 Flag splitBase@@ -31,7 +36,10 @@ default: False Library- Build-Depends: mtl >= 1 && <2+ Build-Depends:+ non-negative >= 0.0.4 && <0.1,+ utility-ht >= 0.0.5 && <0.1,+ transformers >=0.0 && <0.2 If flag(splitBase) Build-Depends: base >= 3 Else@@ -45,17 +53,16 @@ Data.StorableVector Data.StorableVector.Base Data.StorableVector.Lazy+ Data.StorableVector.Lazy.Builder+ Data.StorableVector.Lazy.Pattern Data.StorableVector.ST.Strict Data.StorableVector.ST.Lazy Other-Modules:- -- LazySize and LazyVarying have no mature interface so far- Data.StorableVector.LazySize- Data.StorableVector.LazyVarying -- Cursor has no mature interface so far Data.StorableVector.Cursor Data.StorableVector.Memory- Data.StorableVector.Utility+ Data.StorableVector.ST.Private