{- |
Chunky signal stream build on StorableVector.

Hints for fusion:
 - Higher order functions should always be inlined in the end
   in order to turn them into machine loops
   instead of calling a function in an inner loop.
-}
module Data.StorableVector.Lazy where

import qualified Data.List as List
import qualified Data.StorableVector as V
import qualified Data.StorableVector.Base as VB
import qualified Data.StorableVector.Lazy.PointerPrivate as Ptr

import qualified Numeric.NonNegative.Class as NonNeg

import qualified Data.List.HT as ListHT
import Data.Tuple.HT (mapPair, mapFst, mapSnd, swap, )
import Data.Maybe.HT (toMaybe, )
import Data.Maybe (fromMaybe, )

import Foreign.Storable (Storable)

import Data.Monoid (Monoid, mempty, mappend, mconcat, )
-- import Control.Arrow ((***))
import Control.Monad (liftM, liftM2, liftM3, liftM4, {- guard, -} )


import System.IO (openBinaryFile, IOMode(WriteMode, ReadMode, AppendMode),
                  hClose, Handle)
import Control.Exception (bracket, catch, )

import qualified System.IO.Error as Exc
import qualified System.Unsafe as Unsafe

import Test.QuickCheck (Arbitrary(..))


{-
import Prelude hiding
   (length, (++), concat, iterate, foldl, map, repeat, replicate, null,
    zip, zipWith, zipWith3, drop, take, splitAt, takeWhile, dropWhile, reverse)
-}

import qualified Prelude as P

import Data.Either (Either(Left, Right), either, )
import Data.Maybe (Maybe(Just, Nothing), maybe, )
import Data.Function (const, flip, ($), (.), )
import Data.Tuple (fst, snd, uncurry, )
import Data.Bool (Bool(True,False), not, (&&), )
import Data.Ord (Ord, (<), (>), (<=), (>=), min, max, )
import Data.Eq (Eq, (==), )
import Control.Monad (mapM_, fmap, (=<<), (>>=), (>>), return, )
import Text.Show (Show, showsPrec, showParen, showString, show, )
import Prelude
   (IO, error, IOError,
    FilePath, String, succ,
    Num, Int, sum, (+), (-), divMod, mod, fromInteger, )



newtype Vector a = SV {chunks :: [V.Vector a]}


instance (Storable a) => Monoid (Vector a) where
    mempty  = empty
    mappend = append
    mconcat = concat

instance (Storable a, Eq a) => Eq (Vector a) where
   (==) = equal

instance (Storable a, Show a) => Show (Vector a) where
   showsPrec p xs =
      showParen (p>=10)
         (showString "VectorLazy.fromChunks " .
          showsPrec 10 (chunks xs))

instance (Storable a, Arbitrary a) => Arbitrary (Vector a) where
   arbitrary = liftM2 pack arbitrary arbitrary


-- for a list of chunk sizes see "Data.StorableVector.LazySize".
newtype ChunkSize = ChunkSize Int
   deriving (Eq, Ord, Show)

instance Arbitrary ChunkSize where
   arbitrary = fmap (ChunkSize . max 1 . min 2048) arbitrary

{-
ToDo:
Since non-negative-0.1 we have the Monoid superclass for NonNeg.
Maybe we do not need the Num instance anymore.
-}
instance Num ChunkSize where
   (ChunkSize x) + (ChunkSize y)  =
       ChunkSize (x+y)
   (-)  =  moduleError "ChunkSize.-" "intentionally unimplemented"
   (*)  =  moduleError "ChunkSize.*" "intentionally unimplemented"
   abs  =  moduleError "ChunkSize.abs" "intentionally unimplemented"
   signum  =  moduleError "ChunkSize.signum" "intentionally unimplemented"
   fromInteger = ChunkSize . fromInteger

instance Monoid ChunkSize where
   mempty = ChunkSize 0
   mappend (ChunkSize x) (ChunkSize y) = ChunkSize (x+y)
   mconcat = ChunkSize . sum . List.map (\(ChunkSize c) -> c)

instance NonNeg.C ChunkSize where
   split = NonNeg.splitDefault (\(ChunkSize c) -> c) ChunkSize

chunkSize :: Int -> ChunkSize
chunkSize x =
   ChunkSize $
      if x>0
        then x
        else moduleError "chunkSize" ("no positive number: " List.++ show x)

defaultChunkSize :: ChunkSize
defaultChunkSize =
   ChunkSize 1024



-- * Introducing and eliminating 'Vector's

{-# INLINE empty #-}
empty :: (Storable a) => Vector a
empty = SV []

{-# INLINE singleton #-}
singleton :: (Storable a) => a -> Vector a
singleton x = SV [V.singleton x]

fromChunks :: (Storable a) => [V.Vector a] -> Vector a
fromChunks = SV

pack :: (Storable a) => ChunkSize -> [a] -> Vector a
pack size = unfoldr size ListHT.viewL

unpack :: (Storable a) => Vector a -> [a]
unpack = List.concatMap V.unpack . chunks


{-# INLINE packWith #-}
packWith :: (Storable b) => ChunkSize -> (a -> b) -> [a] -> Vector b
packWith size f =
   unfoldr size (fmap (mapFst f) . ListHT.viewL)

{-# INLINE unpackWith #-}
unpackWith :: (Storable a) => (a -> b) -> Vector a -> [b]
unpackWith f = List.concatMap (V.unpackWith f) . chunks


{-# INLINE unfoldr #-}
unfoldr :: (Storable b) =>
   ChunkSize ->
   (a -> Maybe (b,a)) ->
   a ->
   Vector b
unfoldr (ChunkSize size) f =
   SV .
   List.unfoldr (cancelNullVector . V.unfoldrN size f =<<) .
   Just

{- |
Example:

> *Data.StorableVector.Lazy> unfoldrResult (ChunkSize 5) (\c -> if c>'z' then Left (Char.ord c) else Right (c, succ c)) 'a'
> (VectorLazy.fromChunks [Vector.pack "abcde",Vector.pack "fghij",Vector.pack "klmno",Vector.pack "pqrst",Vector.pack "uvwxy",Vector.pack "z"],123)
-}
{-# INLINE unfoldrResult #-}
unfoldrResult :: (Storable b) =>
   ChunkSize ->
   (a -> Either c (b, a)) ->
   a ->
   (Vector b, c)
unfoldrResult (ChunkSize size) f =
   let recourse a0 =
          let (chunk, a1) =
                 V.unfoldrResultN size Right (either (Left . Left) Right . f) a0
          in  either
                 ((,) (if V.null chunk then [] else [chunk]))
                 (mapFst (chunk :) . recourse) a1
   in  mapFst SV . recourse


{-# INLINE sample #-}
sample :: (Storable a) => ChunkSize -> (Int -> a) -> Vector a
sample size f =
   unfoldr size (\i -> Just (f i, succ i)) 0

{-# INLINE sampleN #-}
sampleN :: (Storable a) => ChunkSize -> Int -> (Int -> a) -> Vector a
sampleN size n f =
   unfoldr size (\i -> toMaybe (i<n) (f i, succ i)) 0


{-# INLINE iterate #-}
iterate :: Storable a => ChunkSize -> (a -> a) -> a -> Vector a
iterate size f = unfoldr size (\x -> Just (x, f x))

repeat :: Storable a => ChunkSize -> a -> Vector a
repeat (ChunkSize size) =
   SV . List.repeat . V.replicate size

cycle :: Storable a => Vector a -> Vector a
cycle =
   SV . List.cycle . chunks

replicate :: Storable a => ChunkSize -> Int -> a -> Vector a
replicate (ChunkSize size) n x =
   let (numChunks, rest) = divMod n size
   in  append
          (SV (List.replicate numChunks (V.replicate size x)))
          (fromChunk (V.replicate rest x))




-- * Basic interface

{-# INLINE null #-}
null :: (Storable a) => Vector a -> Bool
null = List.null . chunks

length :: Vector a -> Int
length = sum . List.map V.length . chunks

equal :: (Storable a, Eq a) => Vector a -> Vector a -> Bool
equal (SV xs0) (SV ys0) =
   let recourse (x:xs) (y:ys) =
          let l = min (V.length x) (V.length y)
              (xPrefix, xSuffix) = V.splitAt l x
              (yPrefix, ySuffix) = V.splitAt l y
              build z zs =
                 if V.null z then zs else z:zs
          in  xPrefix == yPrefix &&
              recourse (build xSuffix xs) (build ySuffix ys)
       recourse [] [] = True
       -- this requires that chunks will always be non-empty
       recourse _ _ = False
   in  recourse xs0 ys0

index :: (Storable a) => Vector a -> Int -> a
index (SV xs) n =
   if n < 0
     then
        moduleError "index"
           ("negative index: " List.++ show n)
     else
        List.foldr
           (\x k m0 ->
              let m1 = m0 - V.length x
              in  if m1 < 0
                    then VB.unsafeIndex x m0
                    else k m1)
           (\m -> moduleError "index"
                     ("index too large: " List.++ show n
                      List.++ ", length = " List.++ show (n-m)))
           xs n


{-# NOINLINE [0] cons #-}
cons :: Storable a => a -> Vector a -> Vector a
cons x = SV . (V.singleton x :) . chunks

infixr 5 `append`

{-# NOINLINE [0] append #-}
append :: Storable a => Vector a -> Vector a -> Vector a
append (SV xs) (SV ys)  =  SV (xs List.++ ys)


{- |
@extendL size x y@
prepends the chunk @x@ and merges it with the first chunk of @y@
if the total size is at most @size@.
This way you can prepend small chunks
while asserting a reasonable average size for chunks.
-}
extendL :: Storable a => ChunkSize -> V.Vector a -> Vector a -> Vector a
extendL (ChunkSize size) x (SV yt) =
   SV $
   maybe
      [x]
      (\(y,ys) ->
          if V.length x + V.length y <= size
            then V.append x y : ys
            else x:yt)
      (ListHT.viewL yt)


concat :: (Storable a) => [Vector a] -> Vector a
concat = SV . List.concat . List.map chunks


-- * Transformations

{-# INLINE map #-}
map :: (Storable x, Storable y) =>
      (x -> y)
   -> Vector x
   -> Vector y
map f = SV . List.map (V.map f) . chunks


reverse :: Storable a => Vector a -> Vector a
reverse =
   SV . List.reverse . List.map V.reverse . chunks


-- * Reducing 'Vector's

{-# INLINE foldl #-}
foldl :: Storable b => (a -> b -> a) -> a -> Vector b -> a
foldl f x0 = List.foldl (V.foldl f) x0 . chunks

{-# INLINE foldl' #-}
foldl' :: Storable b => (a -> b -> a) -> a -> Vector b -> a
foldl' f x0 = List.foldl' (V.foldl f) x0 . chunks

{-# INLINE foldr #-}
foldr :: Storable b => (b -> a -> a) -> a -> Vector b -> a
foldr f x0 = List.foldr (flip (V.foldr f)) x0 . chunks


{-# INLINE monoidConcatMap #-}
monoidConcatMap :: (Storable a, Monoid m) => (a -> m) -> Vector a -> m
monoidConcatMap f =
   List.foldr (mappend . V.monoidConcatMap f) mempty . chunks

{-# INLINE any #-}
any :: (Storable a) => (a -> Bool) -> Vector a -> Bool
any p = List.any (V.any p) . chunks

{-# INLINE all #-}
all :: (Storable a) => (a -> Bool) -> Vector a -> Bool
all p = List.all (V.all p) . chunks

maximum :: (Storable a, Ord a) => Vector a -> a
maximum =
   List.maximum . List.map V.maximum . chunks
--   List.foldl1' max . List.map V.maximum . chunks

minimum :: (Storable a, Ord a) => Vector a -> a
minimum =
   List.minimum . List.map V.minimum . chunks
--   List.foldl1' min . List.map V.minimum . chunks

{-
sum :: (Storable a, Num a) => Vector a -> a
sum =
   List.sum . List.map V.sum . chunks

product :: (Storable a, Num a) => Vector a -> a
product =
   List.product . List.map V.product . chunks
-}


-- * inspecting a vector

{-# INLINE pointer #-}
pointer :: Storable a => Vector a -> Ptr.Pointer a
pointer = Ptr.cons . chunks

{-# INLINE viewL #-}
viewL :: Storable a => Vector a -> Maybe (a, Vector a)
viewL (SV xs0) =
   do (x,xs) <- ListHT.viewL xs0
      (y,ys) <- V.viewL x
      return (y, append (fromChunk ys) (SV xs))

{-# INLINE viewR #-}
viewR :: Storable a => Vector a -> Maybe (Vector a, a)
viewR (SV xs0) =
   do xsp <- ListHT.viewR xs0
      let (xs,x) = xsp
{-
   do ~(xs,x) <- ListHT.viewR xs0
-}
      let (ys,y) = fromMaybe (moduleError "viewR" "last chunk empty") (V.viewR x)
      return (append (SV xs) (fromChunk ys), y)

{-# INLINE switchL #-}
switchL :: Storable a => b -> (a -> Vector a -> b) -> Vector a -> b
switchL n j =
   maybe n (uncurry j) . viewL

{-# INLINE switchR #-}
switchR :: Storable a => b -> (Vector a -> a -> b) -> Vector a -> b
switchR n j =
   maybe n (uncurry j) . viewR


{-
viewLSafe :: Storable a => Vector a -> Maybe (a, Vector a)
viewLSafe (SV xs0) =
   -- dropWhile would be unnecessary if we require that all chunks are non-empty
   do (x,xs) <- ListHT.viewL (List.dropWhile V.null xs0)
      (y,ys) <- viewLVector x
      return (y, append (fromChunk ys) (SV xs))

viewRSafe :: Storable a => Vector a -> Maybe (Vector a, a)
viewRSafe (SV xs0) =
   -- dropWhile would be unnecessary if we require that all chunks are non-empty
   do (xs,x) <- ListHT.viewR (dropWhileRev V.null xs0)
      (ys,y) <- V.viewR x
      return (append (SV xs) (fromChunk ys), y)
-}


{-# INLINE scanl #-}
scanl :: (Storable a, Storable b) =>
   (a -> b -> a) -> a -> Vector b -> Vector a
scanl f start =
   cons start . snd .
   mapAccumL (\acc -> (\b -> (b,b)) . f acc) start

{-# INLINE mapAccumL #-}
mapAccumL :: (Storable a, Storable b) =>
   (acc -> a -> (acc, b)) -> acc -> Vector a -> (acc, Vector b)
mapAccumL f start =
   mapSnd SV .
   List.mapAccumL (V.mapAccumL f) start .
   chunks

{-# INLINE mapAccumR #-}
mapAccumR :: (Storable a, Storable b) =>
   (acc -> a -> (acc, b)) -> acc -> Vector a -> (acc, Vector b)
mapAccumR f start =
   mapSnd SV .
   List.mapAccumR (V.mapAccumR f) start .
   chunks

{-# INLINE crochetLChunk #-}
crochetLChunk :: (Storable x, Storable y) =>
      (x -> acc -> Maybe (y, acc))
   -> acc
   -> V.Vector x
   -> (V.Vector y, Maybe acc)
crochetLChunk f acc0 x0 =
   mapSnd (fmap fst) $
   V.unfoldrN
      (V.length x0)
      (\(acc,xt) ->
         do (x,xs) <- V.viewL xt
            (y,acc') <- f x acc
            return (y, (acc',xs)))
      (acc0, x0)

{-# INLINE crochetL #-}
crochetL :: (Storable x, Storable y) =>
      (x -> acc -> Maybe (y, acc))
   -> acc
   -> Vector x
   -> Vector y
crochetL f acc0 =
   SV . List.unfoldr (\(xt,acc) ->
       do (x,xs) <- ListHT.viewL xt
          acc' <- acc
          return $ mapSnd ((,) xs) $ crochetLChunk f acc' x) .
   flip (,) (Just acc0) .
   chunks



-- * sub-vectors

{-# INLINE take #-}
take :: (Storable a) => Int -> Vector a -> Vector a
{- this order of pattern matches is certainly the most lazy one
> take 4 (pack (chunkSize 2) $ "abcd" List.++ undefined)
VectorLazy.fromChunks [Vector.pack "ab",Vector.pack "cd"]
-}
take 0 _ = empty
take _ (SV []) = empty
take n (SV (x:xs)) =
   let m = V.length x
   in  if m<=n
         then SV $ (x:) $ chunks $ take (n-m) $ SV xs
         else fromChunk (V.take n x)

{- |
Take n values from the end of the vector in a memory friendly way.
@takeEnd n xs@ should perform the same as @drop (length xs - n) xs@,
but the latter one would have to materialise @xs@ completely.
In contrast to that
@takeEnd@ should hold only chunks of about @n@ elements at any time point.
-}
{-# INLINE takeEnd #-}
takeEnd :: (Storable a) => Int -> Vector a -> Vector a
takeEnd n xs =
   -- cf. Pattern.drop
   List.foldl (flip drop) xs $ List.map V.length $ chunks $ drop n xs

{-# INLINE drop #-}
drop :: (Storable a) => Int -> Vector a -> Vector a
drop _ (SV []) = empty
drop n (SV (x:xs)) =
   let m = V.length x
   in  if m<=n
         then drop (n-m) (SV xs)
         else SV (V.drop n x : xs)

{-# INLINE splitAt #-}
splitAt :: (Storable a) => Int -> Vector a -> (Vector a, Vector a)
splitAt n0 =
   {- this order of pattern matches is certainly the most lazy one
   > splitAt 4 (pack (chunkSize 2) $ "abcd" List.++ undefined)
   (VectorLazy.fromChunks [Vector.pack "ab",Vector.pack "cd"],VectorLazy.fromChunks *** Exception: Prelude.undefined
   -}
   let recourse 0 xs = ([], xs)
       recourse _ [] = ([], [])
       recourse n (x:xs) =
          let m = V.length x
          in  if m<=n
                then mapFst (x:) $ recourse (n-m) xs
                else mapPair ((:[]), (:xs)) $ V.splitAt n x
   in  mapPair (SV, SV) . recourse n0 . chunks



{-# INLINE dropMarginRem #-}
-- I have used this in an inner loop thus I prefer inlining
{- |
@dropMarginRem n m xs@
drops at most the first @m@ elements of @xs@
and ensures that @xs@ still contains @n@ elements.
Additionally returns the number of elements that could not be dropped
due to the margin constraint.
That is @dropMarginRem n m xs == (k,ys)@ implies @length xs - m == length ys - k@.
Requires @length xs >= n@.
-}
dropMarginRem :: (Storable a) => Int -> Int -> Vector a -> (Int, Vector a)
dropMarginRem n m xs =
   List.foldl'
      (\(mi,xsi) k -> (mi-k, drop k xsi))
      (m,xs)
      (List.map V.length $ chunks $ take m $ drop n xs)

{-
This implementation does only walk once through the dropped prefix.
It is maximally lazy and minimally space consuming.
-}
{-# INLINE dropMargin #-}
dropMargin :: (Storable a) => Int -> Int -> Vector a -> Vector a
dropMargin n m xs =
   List.foldl' (flip drop) xs
      (List.map V.length $ chunks $ take m $ drop n xs)



{-# INLINE dropWhile #-}
dropWhile :: (Storable a) => (a -> Bool) -> Vector a -> Vector a
dropWhile _ (SV []) = empty
dropWhile p (SV (x:xs)) =
   let y = V.dropWhile p x
   in  if V.null y
         then dropWhile p (SV xs)
         else SV (y:xs)

{-# INLINE takeWhile #-}
takeWhile :: (Storable a) => (a -> Bool) -> Vector a -> Vector a
takeWhile _ (SV []) = empty
takeWhile p (SV (x:xs)) =
   let y = V.takeWhile p x
   in  if V.length y < V.length x
         then fromChunk y
         else SV (x : chunks (takeWhile p (SV xs)))


{-# INLINE span #-}
span :: (Storable a) => (a -> Bool) -> Vector a -> (Vector a, Vector a)
span p =
   let recourse [] = ([],[])
       recourse (x:xs) =
          let (y,z) = V.span p x
          in  if V.null z
                then mapFst (x:) (recourse xs)
                else (chunks $ fromChunk y, (z:xs))
   in  mapPair (SV, SV) . recourse . chunks
{-
span _ (SV []) = (empty, empty)
span p (SV (x:xs)) =
   let (y,z) = V.span p x
   in  if V.length y == 0
         then mapFst (SV . (x:) . chunks) (span p (SV xs))
         else (SV [y], SV (z:xs))
-}


-- * other functions


{-# INLINE filter #-}
filter :: (Storable a) => (a -> Bool) -> Vector a -> Vector a
filter p =
   SV . List.filter (not . V.null) . List.map (V.filter p) . chunks


{- |
Generates laziness breaks
wherever one of the input signals has a chunk boundary.
-}
{-# INLINE zipWith #-}
zipWith :: (Storable a, Storable b, Storable c) =>
      (a -> b -> c)
   -> Vector a
   -> Vector b
   -> Vector c
zipWith f as0 bs0 =
   let recourse at@(a:_) bt@(b:_) =
          let z = V.zipWith f a b
              n = V.length z
          in  z : recourse
                     (chunks $ drop n $ fromChunks at)
                     (chunks $ drop n $ fromChunks bt)
       recourse _ _ = []
   in  fromChunks $ recourse (chunks as0) (chunks bs0)

{-# INLINE zipWith3 #-}
zipWith3 :: (Storable a, Storable b, Storable c, Storable d) =>
      (a -> b -> c -> d)
   -> Vector a
   -> Vector b
   -> Vector c
   -> Vector d
zipWith3 f as0 bs0 cs0 =
   let recourse at@(a:_) bt@(b:_) ct@(c:_) =
          let z = V.zipWith3 f a b c
              n = V.length z
          in  z : recourse
                     (chunks $ drop n $ fromChunks at)
                     (chunks $ drop n $ fromChunks bt)
                     (chunks $ drop n $ fromChunks ct)
       recourse _ _ _ = []
   in  fromChunks $ recourse (chunks as0) (chunks bs0) (chunks cs0)

{-# INLINE zipWith4 #-}
zipWith4 :: (Storable a, Storable b, Storable c, Storable d, Storable e) =>
      (a -> b -> c -> d -> e)
   -> Vector a
   -> Vector b
   -> Vector c
   -> Vector d
   -> Vector e
zipWith4 f as0 bs0 cs0 ds0 =
   let recourse at@(a:_) bt@(b:_) ct@(c:_) dt@(d:_) =
          let z = V.zipWith4 f a b c d
              n = V.length z
          in  z : recourse
                     (chunks $ drop n $ fromChunks at)
                     (chunks $ drop n $ fromChunks bt)
                     (chunks $ drop n $ fromChunks ct)
                     (chunks $ drop n $ fromChunks dt)
       recourse _ _ _ _ = []
   in  fromChunks $
       recourse (chunks as0) (chunks bs0) (chunks cs0) (chunks ds0)


{- |
Preserves chunk pattern of the last argument.
-}
{-# INLINE zipWithLastPattern #-}
zipWithLastPattern :: (Storable a, Storable b, Storable c) =>
      (a -> b -> c)
   -> Vector a
   -> Vector b
   -> Vector c
zipWithLastPattern f =
   crochetL (\y -> liftM (mapFst (flip f y)) . Ptr.viewL)
    . pointer

{- |
Preserves chunk pattern of the last argument.
-}
{-# INLINE zipWithLastPattern3 #-}
zipWithLastPattern3 ::
   (Storable a, Storable b, Storable c, Storable d) =>
   (a -> b -> c -> d) ->
   (Vector a -> Vector b -> Vector c -> Vector d)
zipWithLastPattern3 f s0 s1 =
   crochetL (\z (xt,yt) ->
      liftM2
         (\(x,xs) (y,ys) -> (f x y z, (xs,ys)))
         (Ptr.viewL xt)
         (Ptr.viewL yt))
      (pointer s0, pointer s1)

{- |
Preserves chunk pattern of the last argument.
-}
{-# INLINE zipWithLastPattern4 #-}
zipWithLastPattern4 ::
   (Storable a, Storable b, Storable c, Storable d, Storable e) =>
   (a -> b -> c -> d -> e) ->
   (Vector a -> Vector b -> Vector c -> Vector d -> Vector e)
zipWithLastPattern4 f s0 s1 s2 =
   crochetL (\w (xt,yt,zt) ->
      liftM3
         (\(x,xs) (y,ys) (z,zs) -> (f x y z w, (xs,ys,zs)))
         (Ptr.viewL xt)
         (Ptr.viewL yt)
         (Ptr.viewL zt))
      (pointer s0, pointer s1, pointer s2)


{-# INLINE zipWithSize #-}
zipWithSize :: (Storable a, Storable b, Storable c) =>
      ChunkSize
   -> (a -> b -> c)
   -> Vector a
   -> Vector b
   -> Vector c
zipWithSize size f s0 s1 =
   unfoldr size (\(xt,yt) ->
      liftM2
         (\(x,xs) (y,ys) -> (f x y, (xs,ys)))
         (Ptr.viewL xt)
         (Ptr.viewL yt))
      (pointer s0, pointer s1)

{-# INLINE zipWithSize3 #-}
zipWithSize3 ::
   (Storable a, Storable b, Storable c, Storable d) =>
   ChunkSize -> (a -> b -> c -> d) ->
   (Vector a -> Vector b -> Vector c -> Vector d)
zipWithSize3 size f s0 s1 s2 =
   unfoldr size (\(xt,yt,zt) ->
      liftM3
         (\(x,xs) (y,ys) (z,zs) ->
             (f x y z, (xs,ys,zs)))
         (Ptr.viewL xt)
         (Ptr.viewL yt)
         (Ptr.viewL zt))
      (pointer s0, pointer s1, pointer s2)

{-# INLINE zipWithSize4 #-}
zipWithSize4 ::
   (Storable a, Storable b, Storable c, Storable d, Storable e) =>
   ChunkSize -> (a -> b -> c -> d -> e) ->
   (Vector a -> Vector b -> Vector c -> Vector d -> Vector e)
zipWithSize4 size f s0 s1 s2 s3 =
   unfoldr size (\(xt,yt,zt,wt) ->
      liftM4
         (\(x,xs) (y,ys) (z,zs) (w,ws) ->
             (f x y z w, (xs,ys,zs,ws)))
         (Ptr.viewL xt)
         (Ptr.viewL yt)
         (Ptr.viewL zt)
         (Ptr.viewL wt))
      (pointer s0, pointer s1, pointer s2, pointer s3)


-- * interleaved vectors

{-# INLINE sieve #-}
sieve :: (Storable a) => Int -> Vector a -> Vector a
sieve n =
   fromChunks . List.filter (not . V.null) . snd .
   List.mapAccumL
      (\offset chunk ->
         (mod (offset - V.length chunk) n,
          V.sieve n $ V.drop offset chunk)) 0 .
   chunks

{-# INLINE deinterleave #-}
deinterleave :: (Storable a) => Int -> Vector a -> [Vector a]
deinterleave n =
   P.map (sieve n) . P.take n . P.iterate (switchL empty (flip const))

{- |
Interleave lazy vectors
while maintaining the chunk pattern of the first vector.
All input vectors must have the same length.
-}
{-# INLINE interleaveFirstPattern #-}
interleaveFirstPattern :: (Storable a) => [Vector a] -> Vector a
interleaveFirstPattern [] = empty
interleaveFirstPattern vss@(vs:_) =
   let pattern = List.map V.length $ chunks vs
       split xs =
          snd $
          List.mapAccumL
             (\x n -> swap $ mapFst (V.concat . chunks) $ splitAt n x)
             xs pattern
   in  fromChunks $ List.map V.interleave $
       List.transpose $ List.map split vss

{-
interleaveFirstPattern vss@(vs:_) =
   fromChunks . snd .
   List.mapAccumL
      (\xss n ->
         swap $
         mapFst (V.interleave . List.map (V.concat . chunks)) $
         List.unzip $ List.map (splitAt n) xss)
      vss .
   List.map V.length . chunks $ vs
-}



{- |
Ensure a minimal length of the list by appending pad values.
-}
{- disabled INLINE pad -}
pad :: (Storable a) => ChunkSize -> a -> Int -> Vector a -> Vector a
pad size y n0 =
   let recourse n xt =
          if n<=0
            then xt
            else
              case xt of
                 [] -> chunks $ replicate size n y
                 x:xs -> x : recourse (n - V.length x) xs
   in  SV . recourse n0 . chunks

padAlt :: (Storable a) => ChunkSize -> a -> Int -> Vector a -> Vector a
padAlt size x n xs =
   append xs
      (let m = length xs
       in  if n>m
             then replicate size (n-m) x
             else empty)





-- * Helper functions for StorableVector


{-# INLINE cancelNullVector #-}
cancelNullVector :: (V.Vector a, b) -> Maybe (V.Vector a, b)
cancelNullVector y =
   toMaybe (not (V.null (fst y))) y

-- if the chunk has length zero, an empty sequence is generated
{-# INLINE fromChunk #-}
fromChunk :: (Storable a) => V.Vector a -> Vector a
fromChunk x =
   if V.null x
     then empty
     else SV [x]



{-
reduceLVector :: Storable x =>
   (x -> acc -> Maybe acc) -> acc -> Vector x -> (acc, Bool)
reduceLVector f acc0 x =
   let recourse i acc =
          if i < V.length x
            then (acc, True)
            else
               maybe
                  (acc, False)
                  (recourse (succ i))
                  (f (V.index x i) acc)
   in  recourse 0 acc0




{- * Fundamental functions -}

{-
Usage of 'unfoldr' seems to be clumsy but that covers all cases,
like different block sizes in source and destination list.
-}
crochetLSize :: (Storable x, Storable y) =>
      ChunkSize
   -> (x -> acc -> Maybe (y, acc))
   -> acc
   -> T x
   -> T y
crochetLSize size f =
   curry (unfoldr size (\(acc,xt) ->
      do (x,xs) <- viewL xt
         (y,acc') <- f x acc
         return (y, (acc',xs))))

crochetListL :: (Storable y) =>
      ChunkSize
   -> (x -> acc -> Maybe (y, acc))
   -> acc
   -> [x]
   -> T y
crochetListL size f =
   curry (unfoldr size (\(acc,xt) ->
      do (x,xs) <- ListHT.viewL xt
         (y,acc') <- f x acc
         return (y, (acc',xs))))



{-# NOINLINE [0] crochetFusionListL #-}
crochetFusionListL :: (Storable y) =>
      ChunkSize
   -> (x -> acc -> Maybe (y, acc))
   -> acc
   -> FList.T x
   -> T y
crochetFusionListL size f =
   curry (unfoldr size (\(acc,xt) ->
      do (x,xs) <- FList.viewL xt
         (y,acc') <- f x acc
         return (y, (acc',xs))))


{-# INLINE [0] reduceL #-}
reduceL :: Storable x =>
   (x -> acc -> Maybe acc) -> acc -> Vector x -> acc
reduceL f acc0 =
   let recourse acc xt =
          case xt of
             [] -> acc
             (x:xs) ->
                 let (acc',continue) = reduceLVector f acc x
                 in  if continue
                       then recourse acc' xs
                       else acc'
   in  recourse acc0 . chunks



{- * Basic functions -}


{-# RULEZ
  "Storable.append/repeat/repeat" forall size x.
      append (repeat size x) (repeat size x) = repeat size x ;

  "Storable.append/repeat/replicate" forall size n x.
      append (repeat size x) (replicate size n x) = repeat size x ;

  "Storable.append/replicate/repeat" forall size n x.
      append (replicate size n x) (repeat size x) = repeat size x ;

  "Storable.append/replicate/replicate" forall size n m x.
      append (replicate size n x) (replicate size m x) =
         replicate size (n+m) x ;

  "Storable.mix/repeat/repeat" forall size x y.
      mix (repeat size x) (repeat size y) = repeat size (x+y) ;

  #-}

{-# RULES
  "Storable.length/cons" forall x xs.
      length (cons x xs) = 1 + length xs ;

  "Storable.length/map" forall f xs.
      length (map f xs) = length xs ;

  "Storable.map/cons" forall f x xs.
      map f (cons x xs) = cons (f x) (map f xs) ;

  "Storable.map/repeat" forall size f x.
      map f (repeat size x) = repeat size (f x) ;

  "Storable.map/replicate" forall size f x n.
      map f (replicate size n x) = replicate size n (f x) ;

  "Storable.map/repeat" forall size f x.
      map f (repeat size x) = repeat size (f x) ;

  {-
  This can make things worse, if 'map' is applied to replicate,
  since this can use of sharing.
  It can also destroy the more important map/unfoldr fusion in
    take n . map f . unfoldr g

  "Storable.take/map" forall n f x.
      take n (map f x) = map f (take n x) ;
  -}

  "Storable.take/repeat" forall size n x.
      take n (repeat size x) = replicate size n x ;

  "Storable.take/take" forall n m xs.
      take n (take m xs) = take (min n m) xs ;

  "Storable.drop/drop" forall n m xs.
      drop n (drop m xs) = drop (n+m) xs ;

  "Storable.drop/take" forall n m xs.
      drop n (take m xs) = take (max 0 (m-n)) (drop n xs) ;

  "Storable.map/mapAccumL/snd" forall g f acc0 xs.
      map g (snd (mapAccumL f acc0 xs)) =
         snd (mapAccumL (\acc a -> mapSnd g (f acc a)) acc0 xs) ;

  #-}

{- GHC says this is an orphaned rule
  "Storable.map/mapAccumL/mapSnd" forall g f acc0 xs.
      mapSnd (map g) (mapAccumL f acc0 xs) =
         mapAccumL (\acc a -> mapSnd g (f acc a)) acc0 xs ;
-}


{- * Fusable functions -}

scanLCrochet :: (Storable a, Storable b) =>
   (a -> b -> a) -> a -> Vector b -> Vector a
scanLCrochet f start =
   cons start .
   crochetL (\x acc -> let y = f acc x in Just (y, y)) start

{-# INLINE mapCrochet #-}
mapCrochet :: (Storable a, Storable b) => (a -> b) -> (Vector a -> Vector b)
mapCrochet f = crochetL (\x _ -> Just (f x, ())) ()

{-# INLINE takeCrochet #-}
takeCrochet :: Storable a => Int -> Vector a -> Vector a
takeCrochet = crochetL (\x n -> toMaybe (n>0) (x, pred n))

{-# INLINE repeatUnfoldr #-}
repeatUnfoldr :: Storable a => ChunkSize -> a -> Vector a
repeatUnfoldr size = iterate size id

{-# INLINE replicateCrochet #-}
replicateCrochet :: Storable a => ChunkSize -> Int -> a -> Vector a
replicateCrochet size n = takeCrochet n . repeat size




{-
The "fromList/drop" rule is not quite accurate
because the chunk borders are moved.
Maybe 'ChunkSize' better is a list of chunks sizes.
-}

{-# RULEZ
  "fromList/zipWith"
    forall size f (as :: Storable a => [a]) (bs :: Storable a => [a]).
     fromList size (List.zipWith f as bs) =
        zipWith size f (fromList size as) (fromList size bs) ;

  "fromList/drop" forall as n size.
     fromList size (List.drop n as) =
        drop n (fromList size as) ;
  #-}



{- * Fused functions -}

type Unfoldr s a = (s -> Maybe (a,s), s)

{-# INLINE zipWithUnfoldr2 #-}
zipWithUnfoldr2 :: Storable z =>
      ChunkSize
   -> (x -> y -> z)
   -> Unfoldr a x
   -> Unfoldr b y
   -> T z
zipWithUnfoldr2 size h (f,a) (g,b) =
   unfoldr size
      (\(a0,b0) -> liftM2 (\(x,a1) (y,b1) -> (h x y, (a1,b1))) (f a0) (g b0))
--      (uncurry (liftM2 (\(x,a1) (y,b1) -> (h x y, (a1,b1)))) . (f *** g))
      (a,b)

{- done by takeCrochet
{-# INLINE mapUnfoldr #-}
mapUnfoldr :: (Storable x, Storable y) =>
      ChunkSize
   -> (x -> y)
   -> Unfoldr a x
   -> T y
mapUnfoldr size g (f,a) =
   unfoldr size (fmap (mapFst g) . f) a
-}

{-# INLINE dropUnfoldr #-}
dropUnfoldr :: Storable x =>
      ChunkSize
   -> Int
   -> Unfoldr a x
   -> T x
dropUnfoldr size n (f,a0) =
   maybe
      empty
      (unfoldr size f)
      (nest n (\a -> fmap snd . f =<< a) (Just a0))


{- done by takeCrochet
{-# INLINE takeUnfoldr #-}
takeUnfoldr :: Storable x =>
      ChunkSize
   -> Int
   -> Unfoldr a x
   -> T x
takeUnfoldr size n0 (f,a0) =
   unfoldr size
      (\(a,n) ->
         do guard (n>0)
            (x,a') <- f a
            return (x, (a', pred n)))
      (a0,n0)
-}


lengthUnfoldr :: Storable x =>
      Unfoldr a x
   -> Int
lengthUnfoldr (f,a0) =
   let recourse n a =
          maybe n (recourse (succ n) . snd) (f a)
   in  recourse 0 a0


{-# INLINE zipWithUnfoldr #-}
zipWithUnfoldr ::
   (Storable b, Storable c) =>
      (acc -> Maybe (a, acc))
   -> (a -> b -> c)
   -> acc
   -> T b -> T c
zipWithUnfoldr f h a y =
   crochetL (\y0 a0 ->
       do (x0,a1) <- f a0
          Just (h x0 y0, a1)) a y

{-# INLINE zipWithCrochetL #-}
zipWithCrochetL ::
   (Storable x, Storable b, Storable c) =>
      ChunkSize
   -> (x -> acc -> Maybe (a, acc))
   -> (a -> b -> c)
   -> acc
   -> T x -> T b -> T c
zipWithCrochetL size f h a x y =
   crochetL (\(x0,y0) a0 ->
       do (z0,a1) <- f x0 a0
          Just (h z0 y0, a1))
      a (zip size x y)


{-# INLINE crochetLCons #-}
crochetLCons ::
   (Storable a, Storable b) =>
      (a -> acc -> Maybe (b, acc))
   -> acc
   -> a -> T a -> T b
crochetLCons f a0 x xs =
   maybe
      empty
      (\(y,a1) -> cons y (crochetL f a1 xs))
      (f x a0)

{-# INLINE reduceLCons #-}
reduceLCons ::
   (Storable a) =>
      (a -> acc -> Maybe acc)
   -> acc
   -> a -> T a -> acc
reduceLCons f a0 x xs =
   maybe a0 (flip (reduceL f) xs) (f x a0)





{-# RULES
  "Storable.zipWith/share" forall size (h :: a->a->b) (x :: T a).
     zipWith size h x x = map (\xi -> h xi xi) x ;

--  "Storable.map/zipWith" forall size (f::c->d) (g::a->b->c) (x::T a) (y::T b).
  "Storable.map/zipWith" forall size f g x y.
     map f (zipWith size g x y) =
        zipWith size (\xi yi -> f (g xi yi)) x y ;

  -- this rule lets map run on a different block structure
  "Storable.zipWith/map,*" forall size f g x y.
     zipWith size g (map f x) y =
        zipWith size (\xi yi -> g (f xi) yi) x y ;

  "Storable.zipWith/*,map" forall size f g x y.
     zipWith size g x (map f y) =
        zipWith size (\xi yi -> g xi (f yi)) x y ;


  "Storable.drop/unfoldr" forall size f a n.
     drop n (unfoldr size f a) =
        dropUnfoldr size n (f,a) ;

  "Storable.take/unfoldr" forall size f a n.
     take n (unfoldr size f a) =
--        takeUnfoldr size n (f,a) ;
        takeCrochet n (unfoldr size f a) ;

  "Storable.length/unfoldr" forall size f a.
     length (unfoldr size f a) = lengthUnfoldr (f,a) ;

  "Storable.map/unfoldr" forall size g f a.
     map g (unfoldr size f a) =
--        mapUnfoldr size g (f,a) ;
        mapCrochet g (unfoldr size f a) ;

  "Storable.map/iterate" forall size g f a.
     map g (iterate size f a) =
        mapCrochet g (iterate size f a) ;

{-
  "Storable.zipWith/unfoldr,unfoldr" forall sizeA sizeB f g h a b n.
     zipWith n h (unfoldr sizeA f a) (unfoldr sizeB g b) =
        zipWithUnfoldr2 n h (f,a) (g,b) ;
-}

  -- block boundaries are changed here, so it changes lazy behaviour
  "Storable.zipWith/unfoldr,*" forall sizeA sizeB f h a y.
     zipWith sizeA h (unfoldr sizeB f a) y =
        zipWithUnfoldr f h a y ;

  -- block boundaries are changed here, so it changes lazy behaviour
  "Storable.zipWith/*,unfoldr" forall sizeA sizeB f h a y.
     zipWith sizeA h y (unfoldr sizeB f a) =
        zipWithUnfoldr f (flip h) a y ;

  "Storable.crochetL/unfoldr" forall size f g a b.
     crochetL g b (unfoldr size f a) =
        unfoldr size (\(a0,b0) ->
            do (y0,a1) <- f a0
               (z0,b1) <- g y0 b0
               Just (z0, (a1,b1))) (a,b) ;

  "Storable.reduceL/unfoldr" forall size f g a b.
     reduceL g b (unfoldr size f a) =
        snd
          (FList.recourse (\(a0,b0) ->
              do (y,a1) <- f a0
                 b1 <- g y b0
                 Just (a1, b1)) (a,b)) ;

  "Storable.crochetL/cons" forall g b x xs.
     crochetL g b (cons x xs) =
        crochetLCons g b x xs ;

  "Storable.reduceL/cons" forall g b x xs.
     reduceL g b (cons x xs) =
        reduceLCons g b x xs ;




  "Storable.take/crochetL" forall f a x n.
     take n (crochetL f a x) =
        takeCrochet n (crochetL f a x) ;

  "Storable.length/crochetL" forall f a x.
     length (crochetL f a x) = length x ;

  "Storable.map/crochetL" forall g f a x.
     map g (crochetL f a x) =
        mapCrochet g (crochetL f a x) ;

  "Storable.zipWith/crochetL,*" forall size f h a x y.
     zipWith size h (crochetL f a x) y =
        zipWithCrochetL size f h a x y ;

  "Storable.zipWith/*,crochetL" forall size f h a x y.
     zipWith size h y (crochetL f a x) =
        zipWithCrochetL size f (flip h) a x y ;

  "Storable.crochetL/crochetL" forall f g a b x.
     crochetL g b (crochetL f a x) =
        crochetL (\x0 (a0,b0) ->
            do (y0,a1) <- f x0 a0
               (z0,b1) <- g y0 b0
               Just (z0, (a1,b1))) (a,b) x ;

  "Storable.reduceL/crochetL" forall f g a b x.
     reduceL g b (crochetL f a x) =
        snd
          (reduceL (\x0 (a0,b0) ->
              do (y,a1) <- f x0 a0
                 b1 <- g y b0
                 Just (a1, b1)) (a,b) x) ;
  #-}

-}

{- * IO -}

{- |
Read the rest of a file lazily and
provide the reason of termination as IOError.
If IOError is EOF (check with @System.Error.isEOFError err@),
then the file was read successfully.
Only access the final IOError after you have consumed the file contents,
since finding out the terminating reason forces to read the entire file.
Make also sure you read the file completely,
because it is only closed when the file end is reached
(or an exception is encountered).

TODO:
In ByteString.Lazy the chunk size is reduced
if data is not immediately available.
Maybe we should adapt that behaviour
but when working with realtime streams
that may mean that the chunks are very small.
-}
hGetContentsAsync :: Storable a =>
   ChunkSize -> Handle -> IO (IOError, Vector a)
hGetContentsAsync (ChunkSize size) h =
   let go =
          Unsafe.interleaveIO $
          flip catch (\err -> return (err,[])) $
          do v <- V.hGet h size
             if V.null v
               then hClose h >>
                    return (Exc.mkIOError Exc.eofErrorType
                      "StorableVector.Lazy.hGetContentsAsync" (Just h) Nothing, [])
               else fmap (mapSnd (v:)) go
{-
          Unsafe.interleaveIO $
          flip catch (\err -> return (err,[])) $
          liftM2 (\ chunk ~(err,rest) -> (err,chunk:rest))
             (V.hGet h size) go
-}
   in  fmap (mapSnd SV) go

hGetContentsSync :: Storable a =>
   ChunkSize -> Handle -> IO (Vector a)
hGetContentsSync (ChunkSize size) h =
   let go =
          do v <- V.hGet h size
             if V.null v
               then return []
               else fmap (v:) go
   in  fmap SV go

hPut :: Storable a => Handle -> Vector a -> IO ()
hPut h = mapM_ (V.hPut h) . chunks

{-
*Data.StorableVector.Lazy> print . mapSnd (length :: Vector Data.Int.Int16 -> Int) =<< readFileAsync (ChunkSize 1000) "dist/build/libHSstorablevector-0.1.3.a"
(dist/build/libHSstorablevector-0.1.3.a: hGetBuf: illegal operation (handle is closed),0)
-}
{- |
The file can only closed after all values are consumed.
That is you must always assert that you consume all elements of the stream,
and that no values are missed due to lazy evaluation.
This requirement makes this function useless in many applications.
-}
readFileAsync :: Storable a => ChunkSize -> FilePath -> IO (IOError, Vector a)
readFileAsync size path =
   openBinaryFile path ReadMode >>= hGetContentsAsync size

writeFile :: Storable a => FilePath -> Vector a -> IO ()
writeFile path =
   bracket (openBinaryFile path WriteMode) hClose . flip hPut

appendFile :: Storable a => FilePath -> Vector a -> IO ()
appendFile path =
   bracket (openBinaryFile path AppendMode) hClose . flip hPut


{-# NOINLINE moduleError #-}
moduleError :: String -> String -> a
moduleError fun msg =
   error ("Data.StorableVector.Lazy." List.++ fun List.++ ':':' ':msg)