{-# 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]}


-- for a list of chunk sizes see "Data.StorableVector.LazySize".
newtype ChunkSize = ChunkSize Int

chunkSize :: Int -> ChunkSize
chunkSize x =
   ChunkSize $
      if x>0
        then x
        else error ("no positive chunk size: " 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 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 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 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