leveldb-haskell-0.6: src/Data/Stream/Monadic.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ExistentialQuantification #-}
-- |
-- Module : Data.Stream.Monadic
-- Copyright : (c) 2014 Kim Altintop
-- License : BSD3
-- Maintainer : kim.altintop@gmail.com
-- Stability : experimental
-- Portability : non-portable
--
-- (Mostly mechanical) adaptation of the
-- <http://hackage.haskell.org/package/stream-fusion/docs/Data-Stream.html Data.Stream>
-- module from the
-- <http://hackage.haskell.org/package/stream-fusion stream-fusion> package to a
-- monadic 'Stream' datatype similar to the one
-- <https://www.fpcomplete.com/blog/2014/08/conduit-stream-fusion proposed> by
-- Michael Snoyman for the <http://hackage.haskell.org/package/conduit conduit>
-- package.
--
-- The intention here is to provide a high-level, "Data.List"-like interface to
-- "Database.LevelDB.Iterator"s with predictable space and time complexity (see
-- "Database.LevelDB.Streaming"), and without introducing a dependency eg. on
-- one of the streaming libraries (all relevant datatypes are fully exported,
-- though, so it should be straightforward to write wrappers for your favourite
-- streaming library).
--
-- Fusion and inlining rules and strictness annotations have been put in place
-- faithfully, and may need further profiling. Also, some functions (from
-- "Data.List") have been omitted for various reasons. Missing functions may be
-- added upon <https://github.com/kim/leveldb-haskell/pulls request>.
module Data.Stream.Monadic
( Step (..)
, Stream (..)
-- * Conversion with lists
, toList
, fromList
-- * Basic functions
, append
, cons
, snoc
, head
, last
, tail
, init
, null
, length -- finitary
-- * Transformations
, map
, mapM
, mapM_
, reverse
, intersperse
, intercalate
-- * Folds
, foldl
, foldl'
-- , foldl1
-- , foldl1'
, foldr
-- , foldr1
, foldMap
, foldM
, foldM_
-- * Special folds
, concat
, concatMap
, and
, or
, any
, all
, sum
, product
--, maximum -- non-empty
--, minimum -- non-empty
-- * Building streams
-- ** Scans
, scanl
-- , scanl1
-- , scanr
-- , scanr1
-- Accumulating maps
-- , mapAccumL
-- , mapAccumR
-- ** Infinite streams
, iterate
, repeat
, replicate
, cycle
-- ** Unfolding
, unfoldr
, unfoldrM
-- * Substreams
-- ** Extracting substreams
, take
, drop
, splitAt
, takeWhile
, dropWhile
, span
, break
-- , group
-- , inits
-- , tails
-- ** Predicates
, isPrefixOf
, isSuffixOf
-- , isInfixOf -- would need 'tails'
-- * Searching streams
-- ** Searching by equality
, elem
, notElem
, lookup
-- ** Searching with a predicate
, find
, filter
-- , partition
-- Indexing streams
-- does not make too much sense
-- , index
-- , findIndex
-- , elemIndex
-- , elemIndices
-- , findIndices
-- * Zipping and unzipping
, zip
, zip3
, zip4
, zipWith
, zipWith3
, zipWith4
, unzip
, unzip3
, unzip4
-- * Special streams
-- strings - not applicable
-- , lines
-- , words
-- , unlines
-- , unwords
-- ** \"Set\" operations
-- , nub
, delete
-- , \\
-- , union
-- , intersect
-- , sort
, insert
-- * Generalized functions
-- User-supplied equality, replacing an Eq context
-- , nubBy
, deleteBy
-- , deleteFirstsBy
-- , unionBy
-- , intersectBy
-- , groupBy
-- ** User-supplied comparison, replacing an Ord context
-- , sortBy
, insertBy
-- , maximumBy
-- , minimumBy
-- * The \"generic\" operations
, genericLength
, genericTake
, genericDrop
, genericSplitAt
-- , genericIndex
, genericReplicate
, enumFromToInt
, enumFromToChar
, enumDeltaInteger
)
where
import Control.Applicative
import Control.Monad (Monad (..), void, (=<<), (>=>))
import Data.Char (Char, chr, ord)
import Data.Monoid
import Debug.Trace
import Prelude (Bool (..), Either (..), Eq (..), Functor (..), Int, Integer,
Integral (..), Maybe (..), Num (..), Ord (..), Ordering (..),
error, flip, not, otherwise, undefined, ($), (&&), (.), (||))
data Step a s
= Yield a !s
| Skip !s
| Done
data Stream m a = forall s. Stream (s -> m (Step a s)) (m s)
instance Monad m => Functor (Stream m) where
fmap = map
toList :: (Functor m, Monad m) => Stream m a -> m [a]
toList (Stream next s0) = unfold =<< s0
where
unfold !s = do
step <- next s
case step of
Done -> return []
Skip s' -> unfold s'
Yield x s' -> (x :) <$> unfold s'
{-# INLINE [0] toList #-}
fromList :: Monad m => [a] -> Stream m a
fromList xs = Stream next (return xs)
where
{-# INLINE next #-}
next [] = return Done
next (x:xs') = return $ Yield x xs'
{-# INLINE [0] fromList #-}
{-# RULES
"Stream fromList/toList fusion" forall s.
fmap fromList (toList s) = return s
#-}
append :: (Functor m, Monad m) => Stream m a -> Stream m a -> Stream m a
append (Stream next0 s0) (Stream next1 s1) = Stream next (Left <$> s0)
where
{-# INLINE next #-}
next (Left s) = do
step <- next0 s
case step of
Done -> Skip . Right <$> s1
Skip s' -> return $ Skip (Left s')
Yield x s' -> return $ Yield x (Left s')
next (Right s) = do
step <- next1 s
return $ case step of
Done -> Done
Skip s' -> Skip (Right s')
Yield x s' -> Yield x (Right s')
{-# INLINE [0] append #-}
cons :: (Functor m, Monad m) => a -> Stream m a -> Stream m a
cons w (Stream next0 s0) = Stream next ((,) S2 <$> s0)
where
{-# INLINE next #-}
next (S2, s) = return $ Yield w (S1, s)
next (S1, s) = do
step <- next0 s
return $ case step of
Done -> Done
Skip s' -> Skip (S1, s')
Yield x s' -> Yield x (S1, s')
{-# INLINE [0] cons #-}
snoc :: (Functor m, Monad m) => Stream m a -> a -> Stream m a
snoc (Stream next0 s0) y = Stream next (Just <$> s0)
where
{-# INLINE next #-}
next Nothing = return Done
next (Just s) = do
step <- next0 s
return $ case step of
Done -> Yield y Nothing
Skip s' -> Skip (Just s')
Yield x s' -> Yield x (Just s')
{-# INLINE [0] snoc #-}
-- | Unlike 'Data.List.head', this function does not diverge if the 'Stream' is
-- empty. Instead, 'Nothing' is returned.
head :: Monad m => Stream m a -> m (Maybe a)
head (Stream next s0) = loop =<< s0
where
loop !s = do
step <- next s
case step of
Yield x _ -> return $ Just x
Skip s' -> loop s'
Done -> return Nothing
{-# INLINE [0] head #-}
-- | Unlike 'Data.List.last', this function does not diverge if the 'Stream' is
-- empty. Instead, 'Nothing' is returned.
last :: Monad m => Stream m a -> m (Maybe a)
last (Stream next s0) = loop =<< s0
where
loop !s = do
step <- next s
case step of
Done -> return Nothing
Skip s' -> loop s'
Yield x s' -> loop' x s'
loop' x !s = do
step <- next s
case step of
Done -> return $ Just x
Skip s' -> loop' x s'
Yield x' s' -> loop' x' s'
{-# INLINE [0] last #-}
data Switch = S1 | S2
-- | Unlike 'Data.List.tail', this function does not diverge if the 'Stream' is
-- empty. Instead, it is the identity in this case.
tail :: (Functor m, Monad m) => Stream m a -> Stream m a
tail (Stream next0 s0) = Stream next ((,) S1 <$> s0)
where
{-# INLINE next #-}
next (S1, s) = do
step <- next0 s
return $ case step of
Done -> Done
Skip s' -> Skip (S1, s')
Yield _ s' -> Skip (S2, s')
next (S2, s) = do
step <- next0 s
return $ case step of
Done -> Done
Skip s' -> Skip (S2, s')
Yield x s' -> Yield x (S2, s')
{-# INLINE [0] tail #-}
-- | Unlike 'Data.List.init', this function does not diverge if the 'Stream' is
-- empty. Instead, it is the identity in this case.
init :: (Functor m, Monad m) => Stream m a -> Stream m a
init (Stream next0 s0) = Stream next ((,) Nothing <$> s0)
where
{-# INLINE next #-}
next (Nothing, s) = do
step <- next0 s
return $ case step of
Done -> Done
Skip s' -> Skip (Nothing, s')
Yield x s' -> Skip (Just x , s')
next (Just x, s) = do
step <- next0 s
return $ case step of
Done -> Done
Skip s' -> Skip (Just x , s')
Yield x' s' -> Yield x (Just x', s')
{-# INLINE [0] init #-}
null :: Monad m => Stream m a -> m Bool
null (Stream next s0) = loop =<< s0
where
loop !s = do
step <- next s
case step of
Done -> return True
Yield _ _ -> return False
Skip s' -> loop s'
{-# INLINE [0] null #-}
length :: Monad m => Stream m a -> m Int
length (Stream next s0) = loop 0 =<< s0
where
loop !z !s = do
step <- next s
case step of
Done -> return z
Skip s' -> loop z s'
Yield _ s' -> loop (z+1) s'
{-# INLINE [0] length #-}
elem :: (Eq a, Monad m) => a -> Stream m a -> m Bool
elem x (Stream next s0) = loop =<< s0
where
loop !s = do
step <- next s
case step of
Done -> return False
Skip s' -> loop s'
Yield y s' | y == x -> return True
| otherwise -> loop s'
{-# INLINE [0] elem #-}
notElem :: (Eq a, Monad m) => a -> Stream m a -> m Bool
notElem x s = elem x s >>= return . not
lookup :: (Eq a, Monad m) => a -> Stream m (a, b) -> m (Maybe b)
lookup key (Stream next s0) = loop =<< s0
where
loop !s = do
step <- next s
case step of
Done -> return Nothing
Skip s' -> loop s'
Yield (x, y) s' | key == x -> return $ Just y
| otherwise -> loop s'
{-# INLINE [0] lookup #-}
find :: Monad m => (a -> Bool) -> Stream m a -> m (Maybe a)
find p = head . filter p
{-# INLINE [0] find #-}
filter :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
filter p (Stream next0 s0) = Stream next s0
where
{-# INLINE next #-}
next !s = do
step <- next0 s
return $ case step of
Done -> Done
Skip s' -> Skip s'
Yield x s' | p x -> Yield x s'
| otherwise -> Skip s'
{-# INLINE [0] filter #-}
{-# RULES
"Stream filter/filter fusion" forall p q s.
filter p (filter q s) = filter (\ x -> q x && p x) s
#-}
map :: Monad m => (a -> b) -> Stream m a -> Stream m b
map f (Stream next0 s0) = Stream next s0
where
{-# INLINE next #-}
next !s = do
step <- next0 s
return $ case step of
Done -> Done
Skip s' -> Skip s'
Yield x s' -> Yield (f x) s'
{-# INLINE [0] map #-}
{-# RULES
"Stream map/map fusion" forall f g s.
map f (map g s) = map (f . g) s
#-}
mapM :: (Functor m, Monad m) => (a -> m b) -> Stream m a -> Stream m b
mapM f (Stream next0 s0) = Stream next s0
where
{-# INLINE next #-}
next !s = do
step <- next0 s
case step of
Done -> return Done
Skip s' -> return $ Skip s'
Yield x s' -> (`Yield` s') <$> f x
{-# INLINE [0] mapM #-}
{-# RULES
"Stream mapM/mapM fusion" forall f g s.
mapM f (mapM g s) = mapM (g >=> f) s
"Stream map/mapM fusion" forall f g s.
map f (mapM g s) = mapM (fmap f . g) s
"Stream mapM/map fusion" forall f g s.
mapM f (map g s) = mapM (f . g) s
#-}
mapM_ :: (Functor m, Monad m) => (a -> m b) -> Stream m a -> Stream m ()
mapM_ f s = Stream go (return ())
where
{-# INLINE go #-}
go _ = foldM_ (\ _ -> void . f) () s >> return Done
{-# INLINE [0] mapM_ #-}
{-# RULES
"Stream mapM_/mapM fusion" forall f g s.
mapM_ f (mapM g s) = mapM_ (g >=> f) s
"Stream mapM_/map fusion" forall f g s.
mapM_ f (map g s) = mapM_ (f . g) s
#-}
reverse :: (Functor m, Monad m) => Stream m a -> m (Stream m a)
reverse = foldl' (flip cons) (fromList [])
{-# INLINE reverse #-}
intersperse :: (Functor m, Monad m) => a -> Stream m a -> Stream m a
intersperse sep (Stream next0 s0) = Stream next ((,,) Nothing S1 <$> s0)
where
{-# INLINE next #-}
next (Nothing, S1, s) = do
step <- next0 s
return $ case step of
Done -> Done
Skip s' -> Skip (Nothing, S1, s')
Yield x s' -> Skip (Just x , S1, s')
next (Just x, S1, s) = return $ Yield x (Nothing, S2, s)
next (Nothing, S2, s) = do
step <- next0 s
return $ case step of
Done -> Done
Skip s' -> Skip (Nothing, S2, s')
Yield x s' -> Yield sep (Just x , S1, s')
next (Just _, S2, _) = error "Data.Stream.Monadic.intersperse: impossible"
{-# INLINE [0] intersperse #-}
intercalate :: (Functor m, Monad m) => Stream m a -> Stream m [a] -> Stream m a
intercalate sep s = first s `append` rest s
where
first = concat . take 1
rest = concatMap (append sep . fromList) . drop 1
{-# INLINE intercalate #-}
--transpose :: Monad m => Stream m [a] -> Stream m [a]
foldMap :: (Monoid m, Functor n, Monad n) => (a -> m) -> Stream n a -> n m
foldMap f (Stream next s0) = loop mempty =<< s0
where
loop z !s = do
step <- next s
case step of
Done -> return z
Skip s' -> loop z s'
Yield x s' -> loop (z <> f x) s'
{-# INLINE [0] foldMap #-}
{-# RULES
"Stream foldMap/map fusion" forall f g s.
foldMap f (map g s) = foldMap (f . g) s
"Stream foldMap/mapM fusion" forall f g s.
foldMap f (mapM g s) = foldM (\ z' -> fmap ((z' <>) . f) . g) mempty s
#-}
foldl :: Monad m => (b -> a -> b) -> b -> Stream m a -> m b
foldl f z0 (Stream next s0) = loop z0 =<< s0
where
loop z !s = do
step <- next s
case step of
Done -> return z
Skip s' -> loop z s'
Yield x s' -> loop (f z x) s'
{-# INLINE [0] foldl #-}
{-# RULES
"Stream foldl/map fusion" forall f g z s.
foldl f z (map g s) = foldl (\ z' -> f z' . g) z s
"Stream foldl/mapM fusion" forall f g z s.
foldl f z (mapM g s) = foldM (\ z' -> fmap (f z') . g) z s
#-}
foldl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> m b
foldl' f z0 (Stream next s0) = loop z0 =<< s0
where
loop !z !s = do
step <- next s
case step of
Done -> return z
Skip s' -> loop z s'
Yield x s' -> loop (f z x) s'
{-# INLINE [0] foldl' #-}
{-# RULES
"Stream foldl'/map fusion" forall f g z s.
foldl' f z (map g s) = foldl' (\ z' -> f z' . g) z s
"Stream foldl'/mapM fusion" forall f g z s.
foldl' f z (mapM g s) = foldM (\ z' -> fmap (f z') . g) z s
#-}
foldr :: (Functor m, Monad m) => (a -> b -> b) -> b -> Stream m a -> m b
foldr f z (Stream next s0) = loop =<< s0
where
loop !s = do
step <- next s
case step of
Done -> return z
Skip s' -> loop s'
Yield x s' -> f x <$> loop s'
{-# INLINE [0] foldr #-}
{-# RULES
"Stream foldr/map fusion" forall f g z s.
foldr f z (map g s) = foldr (f . g) z s
"Stream foldr/mapM fusion" forall f g z s.
foldr f z (mapM g s) = foldM (\ z' -> fmap (`f` z') . g) z s
#-}
foldM :: Monad m => (b -> a -> m b) -> b -> Stream m a -> m b
foldM f z0 (Stream next s0) = loop z0 =<< s0
where
loop z !s = do
step <- next s
case step of
Done -> return z
Skip s' -> loop z s'
Yield x s' -> f z x >>= (`loop` s')
{-# INLINE [0] foldM #-}
{-# RULES
"Stream foldM/map fusion" forall f g z s.
foldM f z (map g s) = foldM (\ z' -> f z' . g) z s
"Stream foldM/mapM fusion" forall f g z s.
foldM f z (mapM g s) = foldM (\ z' -> g >=> f z') z s
#-}
foldM_ :: Monad m => (b -> a -> m b) -> b -> Stream m a -> m ()
foldM_ f z s = foldM f z s >> return ()
{-# INLINE foldM_ #-}
concat :: (Functor m, Monad m) => Stream m [a] -> Stream m a
concat = concatMap fromList
{-# INLINE concat #-}
concatMap :: (Functor m, Monad m) => (a -> Stream m b) -> Stream m a -> Stream m b
concatMap f (Stream next0 s0) = Stream next ((,) Nothing <$> s0)
where
{-# INLINE next #-}
next (Nothing, s) = do
step <- next0 s
return $ case step of
Done -> Done
Skip s' -> Skip (Nothing , s')
Yield x s' -> Skip (Just (f x), s')
next (Just (Stream g t), s) = do
step <- g =<< t
return $ case step of
Done -> Skip (Nothing , s)
Skip t' -> Skip (Just (Stream g (return t')), s)
Yield x t' -> Yield x (Just (Stream g (return t')), s)
{-# INLINE [0] concatMap #-}
{-# RULES
"Stream concatMap/map fusion" forall f g s.
concatMap f (map g s) = concatMap (f . g) s
#-}
and :: (Functor m, Monad m) => Stream m Bool -> m Bool
and = foldr (&&) True
{-# INLINE and #-}
or :: (Functor m, Monad m) => Stream m Bool -> m Bool
or = foldr (||) False
{-# INLINE or #-}
any :: Monad m => (a -> Bool) -> Stream m a -> m Bool
any p (Stream next s0) = loop =<< s0
where
loop !s = do
step <- next s
case step of
Done -> return False
Skip s' -> loop s'
Yield x s' | p x -> return True
| otherwise -> loop s'
{-# INLINE [0] any #-}
all :: Monad m => (a -> Bool) -> Stream m a -> m Bool
all p (Stream next s0) = loop =<< s0
where
loop !s = do
step <- next s
case step of
Done -> return True
Skip s' -> loop s'
Yield x s' | p x -> loop s'
| otherwise -> return False
{-# INLINE [0] all #-}
sum :: (Num a, Monad m) => Stream m a -> m a
sum (Stream next s0) = loop 0 =<< s0
where
loop !a !s = do
step <- next s
case step of
Done -> return a
Skip s' -> loop a s'
Yield x s' -> loop (a + x) s'
{-# INLINE [0] sum #-}
product :: (Num a, Monad m) => Stream m a -> m a
product (Stream next s0) = loop 1 =<< s0
where
loop !a !s = do
step <- next s
case step of
Done -> return a
Skip s' -> loop a s'
Yield x s' -> loop (a * x) s'
{-# INLINE [0] product #-}
scanl :: (Functor m, Monad m) => (b -> a -> b) -> b -> Stream m a -> Stream m b
scanl f z0 = go . (`snoc` undefined)
where
{-# INLINE go #-}
go (Stream step s0) = Stream (next step) ((,) z0 <$> s0)
{-# INLINE next #-}
next step (z, s) = do
step' <- step s
return $ case step' of
Done -> Done
Skip s' -> Skip (z , s')
Yield x s' -> Yield z (f z x, s')
{-# INLINE [0] scanl #-}
iterate :: Monad m => (a -> a) -> a -> Stream m a
iterate f x0 = Stream next (return x0)
where
{-# INLINE next #-}
next x = return $ Yield x (f x)
{-# INLINE [0] iterate #-}
repeat :: Monad m => a -> Stream m a
repeat x = Stream next (return ())
where
{-# INLINE next #-}
next _ = return $ Yield x ()
{-# INLINE [0] repeat #-}
{-# RULES
"map/repeat" forall f x.
map f (repeat x) = repeat (f x)
#-}
replicate :: Monad m => Int -> a -> Stream m a
replicate n x = Stream next (return n)
where
{-# INLINE next #-}
next !i | i <= 0 = return Done
| otherwise = return $ Yield x (i-1)
{-# INLINE [0] replicate #-}
{-# RULES
"map/replicate" forall f n x.
map f (replicate n x) = replicate n (f x)
#-}
-- | Unlike 'Data.List.cycle', this function does not diverge if the 'Stream' is
-- empty. Instead, it is the identity in this case.
cycle :: (Functor m, Monad m) => Stream m a -> Stream m a
cycle (Stream next0 s0) = Stream next ((,) S1 <$> s0)
where
{-# INLINE next #-}
next (S1, s) = do
step <- next0 s
return $ case step of
Done -> Done -- error?
Skip s' -> Skip (S1, s')
Yield x s' -> Yield x (S2, s')
next (S2, s) = do
step <- next0 s
case step of
Done -> Skip . (,) S2 <$> s0
Skip s' -> return $ Skip (S2, s')
Yield x s' -> return $ Yield x (S2, s')
{-# INLINE [0] cycle #-}
unfoldr :: Monad m => (b -> Maybe (a, b)) -> b -> Stream m a
unfoldr f s0 = Stream next (return s0)
where
{-# INLINE next #-}
next s = return $ case f s of
Nothing -> Done
Just (w, s') -> Yield w s'
{-# INLINE [0] unfoldr #-}
-- | Build a stream from a monadic seed (or state function).
unfoldrM :: (Functor m, Monad m) => (b -> Maybe (a, m b)) -> m b -> Stream m a
unfoldrM f = Stream next
where
{-# INLINE next #-}
next s = case f s of
Nothing -> return Done
Just (w, s') -> Yield w <$> s'
{-# INLINE [0] unfoldrM #-}
isPrefixOf :: (Eq a, Monad m) => Stream m a -> Stream m a -> m Bool
isPrefixOf (Stream nexta sa0) (Stream nextb sb0) = do
sa0' <- sa0
sb0' <- sb0
loop sa0' sb0' Nothing
where
loop !sa !sb Nothing = do
stepa <- nexta sa
case stepa of
Done -> return True
Skip sa' -> loop sa' sb Nothing
Yield x sa' -> loop sa' sb (Just x)
loop !sa !sb (Just x) = do
stepb <- nextb sb
case stepb of
Done -> return False
Skip sb' -> loop sa sb' (Just x)
Yield y sb' | x == y -> loop sa sb' Nothing
| otherwise -> return False
{-# INLINE [0] isPrefixOf #-}
-- | Note that this is:
--
-- > isSuffixOf a b = reverse a `isPrefixOf` reverse b
--
-- It might be more efficient to construct the 'Stream's in reverse order and
-- use 'isPrefixOf' directly, as 'reverse' is /O(n)/ and requires a finite
-- stream argument.
isSuffixOf :: (Eq a, Functor m, Monad m) => Stream m a -> Stream m a -> m Bool
isSuffixOf sa sb = do
ra <- reverse sa
rb <- reverse sb
ra `isPrefixOf` rb
take :: (Functor m, Monad m) => Int -> Stream m a -> Stream m a
take n0 (Stream next0 s0) = Stream next ((,) n0 <$> s0)
where
{-# INLINE next #-}
next (!n, s)
| n <= 0 = return Done
| otherwise = do
step <- next0 s
return $ case step of
Done -> Done
Skip s' -> Skip (n , s')
Yield x s' -> Yield x (n-1, s')
{-# INLINE [0] take #-}
drop :: (Functor m, Monad m) => Int -> Stream m a -> Stream m a
drop n0 (Stream next0 s0) = Stream next ((,) (Just (max 0 n0)) <$> s0)
where
{-# INLINE next #-}
next (Just !n, s)
| n == 0 = return $ Skip (Nothing, s)
| otherwise = do
step <- next0 s
return $ case step of
Done -> Done
Skip s' -> Skip (Just n , s')
Yield _ s' -> Skip (Just (n-1), s')
next (Nothing, s) = do
step <- next0 s
return $ case step of
Done -> Done
Skip s' -> Skip (Nothing, s')
Yield x s' -> Yield x (Nothing, s')
{-# INLINE [0] drop #-}
-- |
--
-- > splitAt n s = (take n s, drop n s)
--
-- Note that the resulting 'Streams' share their state, so do not interleave
-- traversals.
splitAt :: (Functor m, Monad m) => Int -> Stream m a -> (Stream m a, Stream m a)
-- not the most efficient solution, but allows the stream argument to be
-- infinite
splitAt n s = (take n s, drop n s)
{-# INLINE splitAt #-}
takeWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
takeWhile p (Stream next0 s0) = Stream next s0
where
{-# INLINE next #-}
next !s = do
step <- next0 s
return $ case step of
Done -> Done
Skip s' -> Skip s'
Yield x s' | p x -> Yield x s'
| otherwise -> Done
{-# INLINE [0] takeWhile #-}
dropWhile :: (Functor m, Monad m) => (a -> Bool) -> Stream m a -> Stream m a
dropWhile p (Stream next0 s0) = Stream next ((,) S1 <$> s0)
where
{-# INLINE next #-}
next (S1, s) = do
step <- next0 s
return $ case step of
Done -> Done
Skip s' -> Skip (S1, s')
Yield x s' | p x -> Skip (S1, s')
| otherwise -> Yield x (S2, s')
next (S2, s) = do
step <- next0 s
return $ case step of
Done -> Done
Skip s' -> Skip (S2, s')
Yield x s' -> Yield x (S2, s')
{-# INLINE [0] dropWhile #-}
span :: (Functor m, Monad m) => (a -> Bool) -> Stream m a -> (Stream m a, Stream m a)
span p s = (takeWhile p s, dropWhile p s)
{-# INLINE span #-}
break :: (Functor m, Monad m) => (a -> Bool) -> Stream m a -> (Stream m a, Stream m a)
break p = span (not . p)
{-# INLINE break #-}
zip :: (Functor m, Applicative m, Monad m)
=> Stream m a
-> Stream m b
-> Stream m (a, b)
zip = zipWith (,)
{-# INLINE zip #-}
zip3 :: (Functor m, Applicative m, Monad m)
=> Stream m a
-> Stream m b
-> Stream m c
-> Stream m (a, b, c)
zip3 = zipWith3 (,,)
{-# INLINE zip3 #-}
zip4 :: (Functor m, Applicative m, Monad m)
=> Stream m a
-> Stream m b
-> Stream m c
-> Stream m d
-> Stream m (a, b, c, d)
zip4 = zipWith4 (,,,)
{-# INLINE zip4 #-}
zipWith :: (Functor m, Applicative m, Monad m)
=> (a -> b -> c)
-> Stream m a
-> Stream m b
-> Stream m c
zipWith f (Stream nexta sa0) (Stream nextb sb0) =
Stream next ((,,) Nothing <$> sa0 <*> sb0)
where
{-# INLINE next #-}
next (Nothing, sa, sb) = do
step <- nexta sa
return $ case step of
Done -> Done
Skip sa' -> Skip (Nothing, sa', sb)
Yield a sa' -> Skip (Just a , sa', sb)
next (Just a, sa', sb) = do
step <- nextb sb
return $ case step of
Done -> Done
Skip sb' -> Skip (Just a, sa', sb')
Yield b sb' -> Yield (f a b) (Nothing, sa', sb')
{-# INLINE [0] zipWith #-}
zipWith3 :: (Functor m, Applicative m , Monad m)
=> (a -> b -> c -> d)
-> Stream m a
-> Stream m b
-> Stream m c
-> Stream m d
zipWith3 f (Stream nexta sa0)
(Stream nextb sb0)
(Stream nextc sc0)
= Stream next ((,,,) Nothing <$> sa0 <*> sb0 <*> sc0)
where
{-# INLINE next #-}
next (Nothing, sa, sb, sc) = do
step <- nexta sa
return $ case step of
Done -> Done
Skip sa' -> Skip (Nothing , sa', sb, sc)
Yield a sa' -> Skip (Just (a, Nothing), sa', sb, sc)
next (Just (a, Nothing), sa', sb, sc) = do
step <- nextb sb
return $ case step of
Done -> Done
Skip sb' -> Skip (Just (a, Nothing), sa', sb', sc)
Yield b sb' -> Skip (Just (a, Just b ), sa', sb', sc)
next (Just (a, Just b), sa', sb', sc) = do
step <- nextc sc
return $ case step of
Done -> Done
Skip sc' -> Skip (Just (a, Just b), sa', sb', sc')
Yield c sc' -> Yield (f a b c) (Nothing , sa', sb', sc')
{-# INLINE [0] zipWith3 #-}
zipWith4 :: (Functor m, Applicative m , Monad m)
=> (a -> b -> c -> d -> e)
-> Stream m a
-> Stream m b
-> Stream m c
-> Stream m d
-> Stream m e
zipWith4 f (Stream nexta sa0)
(Stream nextb sb0)
(Stream nextc sc0)
(Stream nextd sd0)
= Stream next ((,,,,) Nothing <$> sa0 <*> sb0 <*> sc0 <*> sd0)
where
{-# INLINE next #-}
next (Nothing, sa, sb, sc, sd) = do
step <- nexta sa
return $ case step of
Done -> Done
Skip sa' -> Skip (Nothing , sa', sb, sc, sd)
Yield a sa' -> Skip (Just (a, Nothing), sa', sb, sc, sd)
next (Just (a, Nothing), sa', sb, sc, sd) = do
step <- nextb sb
return $ case step of
Done -> Done
Skip sb' -> Skip (Just (a, Nothing) , sa', sb', sc, sd)
Yield b sb' -> Skip (Just (a, Just (b, Nothing)), sa', sb', sc, sd)
next (Just (a, Just (b, Nothing)), sa', sb', sc, sd) = do
step <- nextc sc
return $ case step of
Done -> Done
Skip sc' -> Skip (Just (a, Just (b, Nothing)), sa', sb', sc', sd)
Yield c sc' -> Skip (Just (a, Just (b, Just c)) , sa', sb', sc', sd)
next (Just (a, Just (b, Just c)), sa', sb', sc', sd) = do
step <- nextd sd
return $ case step of
Done -> Done
Skip sd' -> Skip (Just (a, Just (b, Just c)), sa', sb', sc', sd')
Yield d sd' -> Yield (f a b c d) (Nothing , sa', sb', sc', sd')
{-# INLINE [0] zipWith4 #-}
unzip :: (Functor m, Monad m) => Stream m (a, b) -> m ([a], [b])
unzip = foldr (\ (a,b) ~(as,bs) -> (a:as, b:bs)) ([],[])
{-# INLINE unzip #-}
unzip3 :: (Functor m, Monad m) => Stream m (a, b, c) -> m ([a], [b], [c])
unzip3 = foldr (\ (a,b,c) ~(as,bs,cs) -> (a:as, b:bs, c:cs)) ([],[],[])
{-# INLINE unzip3 #-}
unzip4 :: (Functor m, Monad m) => Stream m (a, b, c, d) -> m ([a], [b], [c], [d])
unzip4 = foldr (\ (a,b,c,d) ~(as,bs,cs,ds) -> (a:as, b:bs, c:cs, d:ds)) ([],[],[],[])
{-# INLINE unzip4 #-}
delete :: (Eq a, Functor m, Monad m) => a -> Stream m a -> Stream m a
delete = deleteBy (==)
{-# INLINE delete #-}
insert :: (Ord a, Functor m, Monad m) => a -> Stream m a -> Stream m a
insert = insertBy compare
{-# INLINE insert #-}
deleteBy :: (Functor m, Monad m)
=> (a -> a -> Bool)
-> a
-> Stream m a
-> Stream m a
deleteBy eq a (Stream next0 s0) = Stream next ((,) S1 <$> s0)
where
{-# INLINE next #-}
next (S1, s) = do
step <- next0 s
return $ case step of
Done -> Done
Skip s' -> Skip (S1, s')
Yield x s' | a `eq` x -> Skip (S2, s')
| otherwise -> Yield x (S1, s')
next (S2, s) = do
step <- next0 s
return $ case step of
Done -> Done
Skip s' -> Skip (S2, s')
Yield x s' -> Yield x (S2, s')
{-# INLINE [0] deleteBy #-}
insertBy :: (Functor m, Monad m)
=> (a -> a -> Ordering)
-> a
-> Stream m a
-> Stream m a
insertBy cmp x (Stream next0 s0) = Stream next ((,,) S2 Nothing <$> s0)
where
{-# INLINE next #-}
next (S2, Nothing, s) = do
step <- next0 s
return $ case step of
Done -> Yield x (S1, Nothing, s ) -- a snoc
Skip s' -> Skip (S2, Nothing, s')
Yield y s' | GT == cmp x y -> Yield y (S2, Nothing, s')
| otherwise -> Yield x (S1, Just y , s ) -- insert
next (S2, Just _, _) = error "Data.Stream.Monadic.insertBy: impossible"
next (S1, Just y, s) = return $ Yield y (S1, Nothing, s)
next (S1, Nothing, s) = do
step <- next0 s
return $ case step of
Done -> Done
Skip s' -> Skip (S1, Nothing, s')
Yield y s' -> Yield y (S1, Nothing, s')
{-# INLINE [0] insertBy #-}
-- not sure why this is defined recursively (unlike 'length')
genericLength :: (Num i, Functor m, Monad m) => Stream m a -> m i
genericLength (Stream next s0) = loop =<< s0
where
loop !s = do
step <- next s
case step of
Done -> return 0
Skip s' -> loop s'
Yield _ s' -> (1 +) <$> loop s'
{-# INLINE [0] genericLength #-}
genericTake :: (Integral i, Functor m, Monad m) => i -> Stream m a -> Stream m a
genericTake n0 (Stream next0 s0) = Stream next ((,) n0 <$> s0)
where
{-# INLINE next #-}
next (0, _) = return Done
next (n, s) = do
step <- next0 s
return $ case step of
Done -> Done
Skip s' -> Skip (n , s')
Yield x s'
| n > 0 -> Yield x (n-1, s')
| otherwise -> error "List.genericTake: negative argument"
{-# INLINE [0] genericTake #-}
genericDrop :: (Integral i, Functor m, Monad m) => i -> Stream m a -> Stream m a
genericDrop n0 (Stream next0 s0) = Stream next ((,) (Just n0) <$> s0)
where
{-# INLINE next #-}
next (Just 0, s) = return $ Skip (Nothing, s)
next (Just n, s) = do
step <- next0 s
return $ case step of
Done -> Done
Skip s' -> Skip (Just n , s')
Yield _ s' | n > 0 -> Skip (Just (n-1), s')
| otherwise -> error "List.genericDrop: negative argument"
next (Nothing, s) = do
step <- next0 s
return $ case step of
Done -> Done
Skip s' -> Skip (Nothing, s')
Yield x s' -> Yield x (Nothing, s')
{-# INLINE [0] genericDrop #-}
genericSplitAt :: (Integral i, Functor m, Monad m)
=> i
-> Stream m a
-> (Stream m a, Stream m a)
genericSplitAt i s = (genericTake i s, genericDrop i s)
{-# INLINE genericSplitAt #-}
genericReplicate :: (Integral i, Functor m, Monad m) => i -> a -> Stream m a
genericReplicate n = genericTake n . repeat
{-# INLINE [0] genericReplicate #-}
{-# RULES
"genericReplicate -> replicate/Int"
genericReplicate = replicate :: Monad m => Int -> a -> Stream m a
#-}
-- TODO: is it possible to define rules which would rewrite @fromList [n..m]@ to
-- one of the below?
-- | Like @fromList ([n..m] :: [Int])@ but avoids allocating a list
enumFromToInt :: Monad m => Int -> Int -> Stream m Int
enumFromToInt x y = trace "enumFromToInt" $ Stream next (return x)
where
{-# INLINE next #-}
next !n
| n > y = return Done
| otherwise = return $ Yield n (n+1)
{-# INLINE [0] enumFromToInt #-}
-- | Like @fromList ([n,n+d..] :: [Integer])@ but avoids allocating a list
enumDeltaInteger :: Monad m => Integer -> Integer -> Stream m Integer
enumDeltaInteger a d = trace "enumDeltaInteger" $ Stream next (return a)
where
{-# INLINE next #-}
next !x = return $ Yield x (x+d)
{-# INLINE [0] enumDeltaInteger #-}
-- | Like @fromList ([n..m] :: [Char])@ but avoids allocating a list
enumFromToChar :: Monad m => Char -> Char -> Stream m Char
enumFromToChar x y = Stream next (return (ord x))
where
m = ord y
{-# INLINE next #-}
next !n
| n > m = return Done
| otherwise = return $ Yield (chr n) (n+1)
{-# INLINE [0] enumFromToChar #-}