storablevector 0.1.2.2 → 0.2
raw patch · 10 files changed
+2104/−7 lines, 10 files
Files
- Data/StorableVector/Cursor.hs +281/−0
- Data/StorableVector/Lazy.hs +1079/−0
- Data/StorableVector/ST/Lazy.hs +120/−0
- Data/StorableVector/ST/Strict.hs +156/−0
- Data/StorableVector/Utility.hs +42/−0
- speedtest/SpeedTestLazy.hs +17/−0
- storablevector.cabal +22/−7
- tests-2/Instances.hs +1/−0
- tests/QuickCheckUtils.hs +228/−0
- tests/tests.hs +158/−0
+ Data/StorableVector/Cursor.hs view
@@ -0,0 +1,281 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+{- |+Simulate a list with strict elements by a more efficient array structure.+-}+module Data.StorableVector.Cursor where++import Control.Exception (assert, )+import Control.Monad.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 System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO, )++import Data.StorableVector.Utility (+ viewListL, mapSnd,+ )++import Prelude hiding (length, foldr, zipWith, )+++-- | Cf. StreamFusion Data.Stream+data Generator a =+ forall s. -- Seq s =>+ Generator+ {-# UNPACK #-} !(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+ gen :: {-# UNPACK #-} !(Generator a),+ 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+ }+++-- * construction++{-# INLINE create #-}+create :: (Storable a) => Int -> Generator a -> Buffer a+create l g = unsafePerformIO (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 =+ unsafePerformIO (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 =+ unsafePerformIO (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 <- unsafeInterleaveIO $+ 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 =+ unsafePerformIO $+ ...+-}+++{-# INLINE pack #-}+pack :: (Storable a) => Int -> [a] -> Vector a+pack n = unfoldrNTerm n viewListL+++{-# INLINE cons #-}+{- |+This is expensive and should not be used to construct lists iteratively!+-}+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 ()+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 ()+ Just s0 ->+ case runStateT n s0 of+ Nothing -> writeIORef s Nothing+ Just (a,s1) ->+ writeIORef s (Just s1) >>+ withForeignPtr p (\q -> pokeElemOff q c 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 recurse =+ do b <- p+ when b (f >> recurse)+ in recurse++{-# INLINE switchL #-}+switchL :: Storable a => b -> (a -> Vector a -> b) -> Vector a -> b+switchL n j v = unsafePerformIO (switchLIO n j 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)++{-# INLINE viewL #-}+viewL :: Storable a => Vector a -> Maybe (a, Vector a)+viewL = switchL Nothing (curry Just)+++{-# 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++-- | /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 #-}+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+++{-+toVector :: Storable a => Vector a -> VS.Vector a+toVector v =+ VS.Cons (memory (buffer v)) ()+-}++-- length
+ Data/StorableVector/Lazy.hs view
@@ -0,0 +1,1079 @@+{-# OPTIONS_GHC -O2 -fglasgow-exts #-}+{- glasgow-exts are for the rules -}+{- |+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 Data.Maybe (Maybe(Just), maybe, fromMaybe)+import Data.StorableVector.Utility (+ viewListL, viewListR,+ mapPair, mapFst, mapSnd, toMaybe,+ )++import Foreign.Storable (Storable)++-- 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)++import qualified System.IO.Error as Exc+import System.IO.Unsafe (unsafeInterleaveIO)+++import Prelude hiding+ (length, (++), iterate, foldl, map, repeat, replicate, null,+ zip, zipWith, zipWith3, drop, take, splitAt, takeWhile, dropWhile, reverse)++import qualified Prelude as P+{-+import Prelude+ (Int, IO, ($), (.), fst, snd, id, error,+ Char, Num, Show, showsPrec, FilePath,+ Bool(True,False), not,+ flip, curry, uncurry,+ Ord, (<), (>), (<=), {- (>=), (==), -} min, max,+ mapM_, fmap, (=<<), return,+ Enum, succ, pred,+ sum, (+), (-), divMod, )+-}++++{-# ONLINE chunks #-}++newtype Vector a = SV {chunks :: [V.Vector a]}+++-- could also be a list of chunk sizes+newtype ChunkSize = ChunkSize Int++chunkSize :: Int -> ChunkSize+chunkSize = ChunkSize++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]++pack :: (Storable a) => ChunkSize -> [a] -> Vector a+pack size = unfoldr size viewListL++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 (\(a,b) -> (f a, b)) . viewListL)++{-# 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+++{-# 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+++{-# 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)+ (viewListL 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 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 viewL #-}+viewL :: Storable a => Vector a -> Maybe (a, Vector a)+viewL (SV xs0) =+ do (x,xs) <- viewListL 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+ let (ys,y) = fromMaybe (error "StorableVector.Lazy.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) <- viewListL (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)+ (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) <- viewListL 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+take _ (SV []) = empty+take 0 _ = 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 =+ let recurse _ [] = ([], [])+ recurse 0 xs = ([], xs)+ recurse n (x:xs) =+ let m = V.length x+ in if m<=n+ then mapFst (x:) $ recurse (n-m) xs+ else mapPair ((:[]), (:xs)) $ V.splitAt n x+ in mapPair (SV, SV) . recurse n0 . chunks++++{-# INLINE dropMarginRem #-}+-- I have used this in an inner loop thus I prefer inlining+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 recurse [] = ([],[])+ recurse (x:xs) =+ let (y,z) = V.span p x+ in if V.null z+ then mapFst (x:) (recurse xs)+ else (chunks $ fromChunk y, (z:xs))+ in mapPair (SV, SV) . recurse . 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+++{-# INLINE zipWith #-}+zipWith :: (Storable a, Storable b, Storable c) =>+ (a -> b -> c)+ -> Vector a+ -> Vector b+ -> Vector c+zipWith f =+ crochetL (\y -> liftM (mapFst (flip f y)) . viewL)++{-# 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 s0 s1 =+ crochetL (\z (xt,yt) ->+ liftM2+ (\(x,xs) (y,ys) -> (f x y z, (xs,ys)))+ (viewL xt)+ (viewL yt))+ (s0,s1)++{-# 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 s0 s1 s2 =+ crochetL (\w (xt,yt,zt) ->+ liftM3+ (\(x,xs) (y,ys) (z,zs) -> (f x y z w, (xs,ys,zs)))+ (viewL xt)+ (viewL yt)+ (viewL zt))+ (s0,s1,s2)+++{-# INLINE [0] zipWithSize #-}+zipWithSize :: (Storable a, Storable b, Storable c) =>+ ChunkSize+ -> (a -> b -> c)+ -> Vector a+ -> Vector b+ -> Vector c+zipWithSize size f =+ curry (unfoldr 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) =>+ 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)))+ (viewL xt)+ (viewL yt)+ (viewL zt))+ (s0,s1,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)))+ (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]++++{-+reduceLVector :: Storable x =>+ (x -> acc -> Maybe acc) -> acc -> Vector x -> (acc, Bool)+reduceLVector f acc0 x =+ let recurse i acc =+ if i < V.length x+ then (acc, True)+ else+ maybe+ (acc, False)+ (recurse (succ i))+ (f (V.index x i) acc)+ in recurse 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) <- viewListL 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 recurse acc xt =+ case xt of+ [] -> acc+ (x:xs) ->+ let (acc',continue) = reduceLVector f acc x+ in if continue+ then recurse acc' xs+ else acc'+ in recurse 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 recurse n a =+ maybe n (recurse (succ n) . snd) (f a)+ in recurse 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.recurse (\(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 =+ 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
@@ -0,0 +1,120 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+{- |+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,+ freeze,+ thaw,+ 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, )++++{-# INLINE new #-}+{-# INLINE new_ #-}+{-# INLINE read #-}+{-# INLINE write #-}+{-# INLINE freeze #-}+{-# INLINE thaw #-}+{-# INLINE runSTVector #-}+{-# INLINE mapST #-}+{-# INLINE mapSTLazy #-}+++-- * access to mutable storable vector++new :: (Storable e) =>+ Int -> e -> ST s (Vector s e)+new n x = ST.strictToLazyST (VST.new n x)++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)+-}+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)+-}+write :: (Storable e) =>+ Vector s e -> Int -> e -> ST s ()+write xs n x = ST.strictToLazyST (VST.write xs n x)++freeze :: (Storable e) =>+ Vector s e -> ST s (VS.Vector e)+freeze xs = ST.strictToLazyST (VST.freeze xs)++thaw :: (Storable e) =>+ VS.Vector e -> ST s (Vector s e)+thaw xs = ST.strictToLazyST (VST.thaw xs)+++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]))+-}+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.+-}+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/Strict.hs view
@@ -0,0 +1,156 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+{- |+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,+ freeze,+ thaw,+ 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 Control.Monad.ST.Strict as ST+import Control.Monad.ST.Strict (ST, unsafeIOToST, runST, ) -- stToIO,++import Foreign.ForeignPtr (withForeignPtr, unsafeForeignPtrToPtr, )+import Foreign.Storable (Storable(peek, poke, pokeElemOff))+import Foreign.Marshal.Array (advancePtr, )+-- import System.IO.Unsafe (unsafePerformIO)++-- import Prelude (Int, ($), (+), return, const, )+import Prelude hiding (read, )+++newtype Vector s e = SV {vector :: V.Vector e}+++{-# INLINE new #-}+{-# INLINE new_ #-}+{-# INLINE read #-}+{-# INLINE write #-}+{-# INLINE freeze #-}+{-# INLINE thaw #-}+{-# INLINE runSTVector #-}+{-# INLINE mapST #-}+{-# INLINE mapSTLazy #-}+++-- * access to mutable storable vector++new :: (Storable e) =>+ Int -> e -> ST s (Vector s e)+new n x = return (SV (VS.replicate n x))++new_ :: (Storable e) =>+ Int -> ST s (Vector s e)+new_ = fmap SV . newVec_++{-# INLINE newVec_ #-}+newVec_ :: (Storable e) =>+ Int -> ST s (VS.Vector e)+newVec_ n =+ -- return (V.unsafeCreate n (const (return ())))+ unsafeIOToST $ V.create n (const (return ()))++{- |+> Control.Monad.ST.runST (do arr <- new_ 10; Monad.zipWithM_ (write arr) [9,8..0] ['a'..]; read arr 3)+-}+read :: (Storable e) =>+ Vector s e -> Int -> ST s e+read (SV xs) n = return (VS.index xs n)++{- |+> VS.unpack $ runSTVector (do arr <- new_ 10; Monad.zipWithM_ (write arr) [9,8..0] ['a'..]; return arr)+-}+write :: (Storable e) =>+ Vector s e -> Int -> e -> ST s ()+write (SV (V.SV v s l)) n x =+ if 0<=n && n<l+ then unsafeIOToST (withForeignPtr v $ \p -> pokeElemOff p (s+n) x)+ else error "StorableVector.ST.Strict.write: index out of range"++freeze :: (Storable e) =>+ Vector s e -> ST s (VS.Vector e)+freeze (SV xs) = return (VS.copy xs)++thaw :: (Storable e) =>+ VS.Vector e -> ST s (Vector s e)+thaw xs = return (SV (VS.copy xs))+++runSTVector :: (Storable e) =>+ (forall s. ST s (Vector s e)) -> VS.Vector e+runSTVector m =+ runST (fmap vector m)+-- vector (unsafePerformIO (stToIO 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]))+-}+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 unsafeIOToST . poke p =<< f =<< unsafeIOToST (peek q)+ go (pred l) (advancePtr q 1) (advancePtr p 1)+ else return ()+ in do ys@(V.SV py sy _) <- newVec_ n+ go n+ (advancePtr (unsafeForeignPtrToPtr px) sx)+ (advancePtr (unsafeForeignPtrToPtr py) sy)+ return 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.+-}+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/Utility.hs view
@@ -0,0 +1,42 @@+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
+ speedtest/SpeedTestLazy.hs view
@@ -0,0 +1,17 @@+{-# OPTIONS_GHC -O -ddump-simpl-stats #-}+{- -dverbose-core2core -}+module Main (main) where++import qualified Data.StorableVector.Lazy as SV++import Data.Int (Int16)++++main :: IO ()+main =+ SV.writeFile "speed-lazy.sw"+ (SV.take 10000000 $+ SV.unfoldr (SV.ChunkSize 10000)+ (\x -> let y = mod (succ x) 10000+ in Just (x,y)) (0::Int16))
storablevector.cabal view
@@ -1,16 +1,24 @@ Name: storablevector-Version: 0.1.2.2+Version: 0.2 Category: Data Synopsis: Fast, packed, strict storable arrays with a list interface like ByteString Description:- Fast, packed, strict storable arrays with a list interface.- This is much like bytestring but can be used for every Storable type.+ Fast, packed, strict storable arrays+ with a list interface,+ a chunky lazy list interface with variable chunk size+ and an interface for write access via the @ST@ monad.+ This is much like @bytestring@ and @binary@ but can be used for every 'Foreign.Storable.Storable' type.+ See also packages+ <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/vector>,+ <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/uvector>+ with a similar intention. License: BSD3 License-file: LICENSE Author: Spencer Janssen <sjanssen@cse.unl.edu> Maintainer: Henning Thielemann <storablevector@henning-thielemann.de>-Homepage: http://darcs.haskell.org/storablevector-Package-URL: http://code.haskell.org/~sjanssen/storablevector+Homepage: http://www.haskell.org/haskellwiki/Storable_Vector+Package-URL: http://code.haskell.org/storablevector+Stability: Experimental Build-Type: Simple Tested-With: GHC==6.4.1, GHC==6.8.2 Cabal-Version: >=1.2@@ -36,11 +44,18 @@ Exposed-Modules: Data.StorableVector Data.StorableVector.Base+ Data.StorableVector.Lazy+ Data.StorableVector.ST.Strict+ Data.StorableVector.ST.Lazy Other-Modules:+ -- Cursor has no mature interface so far+ Data.StorableVector.Cursor Data.StorableVector.Memory+ Data.StorableVector.Utility + Executable test GHC-Options: -Wall -funbox-strict-fields Hs-Source-Dirs: ., slow-foreign-ptr, tests@@ -66,5 +81,5 @@ Build-Depends: base >= 3 Else Build-Depends: base >= 1.0 && < 2- if !flag(buildTests)- buildable: False+ If !flag(buildTests)+ Buildable: False
+ tests-2/Instances.hs view
@@ -0,0 +1,1 @@+module Instances where
+ tests/QuickCheckUtils.hs view
@@ -0,0 +1,228 @@+{-# 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++instance Show V where+ show = show . V.unpack
+ tests/tests.hs view
@@ -0,0 +1,158 @@+{-# 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_snocVP = (V.snoc :: V -> W -> V) `eq2` P.snoc+prop_spanVP = (V.span :: (W -> Bool) -> V -> (V, V)) `eq2` P.span+prop_splitVP = (V.split :: W -> V -> [V]) `eq2` P.split+prop_splitAtVP = (V.splitAt :: X -> V -> (V, V)) `eq2` P.splitAt+prop_takeVP = (V.take :: X -> V -> V) `eq2` P.take+prop_takeWhileVP = (V.takeWhile :: (W -> Bool) -> V -> V) `eq2` P.takeWhile+prop_elemVP = (V.elem :: W -> V -> Bool) `eq2` P.elem+prop_notElemVP = (V.notElem :: W -> V -> Bool) `eq2` P.notElem+prop_elemIndexVP = (V.elemIndex :: W -> V -> Maybe X) `eq2` P.elemIndex+prop_elemIndicesVP = (V.elemIndices :: W -> V -> [X])`eq2` P.elemIndices+prop_lengthVP = (V.length :: V -> X) `eq1` P.length++prop_headVP = (V.head :: V -> W) `eqnotnull1` P.head+prop_initVP = (V.init :: V -> V) `eqnotnull1` P.init+prop_lastVP = (V.last :: V -> W) `eqnotnull1` P.last+prop_maximumVP = (V.maximum :: V -> W) `eqnotnull1` P.maximum+prop_minimumVP = (V.minimum :: V -> W) `eqnotnull1` P.minimum+prop_tailVP = (V.tail :: V -> V) `eqnotnull1` P.tail+prop_foldl1VP = (V.foldl1 :: (W -> W -> W) -> V -> W) `eqnotnull2` P.foldl1+prop_foldl1VP' = (V.foldl1' :: (W -> W -> W) -> V -> W) `eqnotnull2` P.foldl1'+prop_foldr1VP = (V.foldr1 :: (W -> W -> W) -> V -> W) `eqnotnull2` P.foldr1+prop_scanlVP = (V.scanl :: (W -> W -> W) -> W -> V -> V) `eqnotnull3` P.scanl+prop_scanrVP = (V.scanr :: (W -> W -> W) -> W -> V -> V) `eqnotnull3` P.scanr++prop_eqVP = eq2+ ((==) :: V -> V -> Bool)+ ((==) :: P -> P -> Bool)+prop_foldlVP = eq3+ (V.foldl :: (X -> W -> X) -> X -> V -> X)+ (P.foldl :: (X -> W -> X) -> X -> P -> X)+prop_foldlVP' = eq3+ (V.foldl' :: (X -> W -> X) -> X -> V -> X)+ (P.foldl' :: (X -> W -> X) -> X -> P -> X)+prop_foldrVP = eq3+ (V.foldr :: (W -> X -> X) -> X -> V -> X)+ (P.foldr :: (W -> X -> X) -> X -> P -> X)+prop_mapAccumLVP = eq3+ (V.mapAccumL :: (X -> W -> (X,W)) -> X -> V -> (X, V))+ (P.mapAccumL :: (X -> W -> (X,W)) -> X -> P -> (X, P))+prop_mapAccumRVP = eq3+ (V.mapAccumR :: (X -> W -> (X,W)) -> X -> V -> (X, V))+ (P.mapAccumR :: (X -> W -> (X,W)) -> X -> P -> (X, P))+prop_zipWithVP = eq3+ (V.zipWith :: (W -> W -> W) -> V -> V -> V)+-- (P.zipWith :: (W -> W -> W) -> P -> P -> P)+ (\f x y -> P.pack (P.zipWith f x y) :: P)++prop_unfoldrVP = eq3+ ((\n f a -> V.take (fromIntegral n) $+ V.unfoldr f a) :: Int -> (X -> Maybe (W,X)) -> X -> V)+ ((\n f a -> fst $+ P.unfoldrN n f a) :: Int -> (X -> Maybe (W,X)) -> X -> P)++------------------------------------------------------------------------+-- StorableVector <=> ByteString++vp_tests =+ [("all", mytest prop_allVP)+ ,("any", mytest prop_anyVP)+ ,("append", mytest prop_appendVP)+ ,("concat", mytest prop_concatVP)+ ,("cons", mytest prop_consVP)+ ,("eq", mytest prop_eqVP)+ ,("filter", mytest prop_filterVP)+ ,("find", mytest prop_findVP)+ ,("findIndex", mytest prop_findIndexVP)+ ,("findIndices", mytest prop_findIndicesVP)+ ,("foldl", mytest prop_foldlVP)+ ,("foldl'", mytest prop_foldlVP')+ ,("foldl1", mytest prop_foldl1VP)+ ,("foldl1'", mytest prop_foldl1VP')+ ,("foldr", mytest prop_foldrVP)+ ,("foldr1", mytest prop_foldr1VP)+ ,("mapAccumL", mytest prop_mapAccumLVP)+ ,("mapAccumR", mytest prop_mapAccumRVP)+ ,("zipWith", mytest prop_zipWithVP)+ -- ,("unfoldr", mytest prop_unfoldrVP)+ ,("head", mytest prop_headVP)+ ,("init", mytest prop_initVP)+ ,("isPrefixOf", mytest prop_isPrefixOfVP)+ ,("last", mytest prop_lastVP)+ ,("length", mytest prop_lengthVP)+ ,("map", mytest prop_mapVP)+ ,("maximum ", mytest prop_maximumVP)+ ,("minimum" , mytest prop_minimumVP)+ ,("null", mytest prop_nullVP)+ ,("reverse", mytest prop_reverseVP)+ ,("snoc", mytest prop_snocVP)+ ,("tail", mytest prop_tailVP)+ ,("scanl", mytest prop_scanlVP)+ ,("scanr", mytest prop_scanrVP)+ ,("transpose", mytest prop_transposeVP)+ ,("replicate", mytest prop_replicateVP)+ ,("take", mytest prop_takeVP)+ ,("drop", mytest prop_dropVP)+ ,("splitAt", mytest prop_splitAtVP)+ ,("takeWhile", mytest prop_takeWhileVP)+ ,("dropWhile", mytest prop_dropWhileVP)+ ,("break", mytest prop_breakVP)+ ,("span", mytest prop_spanVP)+ ,("split", mytest prop_splitVP)+ ,("count", mytest prop_countVP)+ ,("group", mytest prop_groupVP)+ ,("inits", mytest prop_initsVP)+ ,("tails", mytest prop_tailsVP)+ ,("elem", mytest prop_elemVP)+ ,("notElem", mytest prop_notElemVP)+ ,("elemIndex", mytest prop_elemIndexVP)+ ,("elemIndices", mytest prop_elemIndicesVP)+ ,("concatMap", mytest prop_concatMapVP)+ ]++------------------------------------------------------------------------+-- The entry point++main = run vp_tests++run :: [(String, Int -> IO ())] -> IO ()+run tests = do+ x <- getArgs+ let n = if null x then 100 else read . head $ x+ mapM_ (\(s,a) -> printf "%-25s: " s >> a n) tests