git.iko.soy/streamly
on 2f31747 help sign in
streamly/src/Streamly/Streams/StreamD.hs
2652 lines 90 kB history raw
1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE CPP #-}
3{-# LANGUAGE ConstraintKinds #-}
4{-# LANGUAGE ExistentialQuantification #-}
5{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE PatternSynonyms #-}
9{-# LANGUAGE RecordWildCards #-}
10{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE ViewPatterns #-}
12{-# LANGUAGE RankNTypes #-}
13{-# LANGUAGE MagicHash #-}
15#include "inline.hs"
17-- |
18-- Module : Streamly.Streams.StreamD
19-- Copyright : (c) 2018 Harendra Kumar
20-- Copyright : (c) Roman Leshchinskiy 2008-2010
21--
22-- License : BSD3
23-- Maintainer : harendra.kumar@gmail.com
24-- Stability : experimental
25-- Portability : GHC
26--
27-- Direct style re-implementation of CPS style stream in StreamK module. The
28-- symbol or suffix 'D' in this module denotes the "Direct" style. GHC is able
29-- to INLINE and fuse direct style better, providing better performance than
30-- CPS implementation.
31--
32-- @
33-- import qualified Streamly.Streams.StreamD as D
34-- @
36-- Some of the functions in this file have been adapted from the vector
37-- library, https://hackage.haskell.org/package/vector.
39module Streamly.Streams.StreamD
40 (
41 -- * The stream type
42 Step (..)
43 , Stream (..)
45 -- * Construction
46 , nil
47 , cons
49 -- * Deconstruction
50 , uncons
52 -- * Generation
53 -- ** Unfolds
54 , unfoldr
55 , unfoldrM
57 -- ** Specialized Generation
58 -- | Generate a monadic stream from a seed.
59 , repeat
60 , replicate
61 , replicateM
62 , fromIndices
63 , fromIndicesM
64 , generate
65 , generateM
67 -- ** Enumerations
68 , enumerateFromStepIntegral
69 , enumerateFromIntegral
70 , enumerateFromThenIntegral
71 , enumerateFromToIntegral
72 , enumerateFromThenToIntegral
74 , enumerateFromStepNum
75 , numFrom
76 , numFromThen
77 , enumerateFromToFractional
78 , enumerateFromThenToFractional
80 -- ** Conversions
81 -- | Transform an input structure into a stream.
82 -- | Direct style stream does not support @fromFoldable@.
83 , yield
84 , yieldM
85 , fromList
86 , fromListM
87 , fromStreamK
88 , fromStreamD
90 -- * Elimination
91 -- ** General Folds
92 , foldrS
93 , foldrT
94 , foldrM
95 , foldrMx
96 , foldr
97 , foldr1
99 , foldl'
100 , foldlM'
101 , foldlS
102 , foldlT
103 , reverse
104 , reverse'
106 , foldlx'
107 , foldlMx'
109 -- ** Specialized Folds
110 , tap
111 , drain
112 , null
113 , head
114 , tail
115 , last
116 , elem
117 , notElem
118 , all
119 , any
120 , maximum
121 , maximumBy
122 , minimum
123 , minimumBy
124 , findIndices
125 , lookup
126 , findM
127 , find
128 , (!!)
130 -- ** Flattening nested streams
131 , concatMapM
132 , concatMap
134 -- ** Grouping
135 , groupsOf
136 , groupsBy
137 , groupsRollingBy
139 -- ** Splitting
140 , splitBy
141 , splitSuffixBy
142 , wordsBy
143 , splitSuffixBy'
145 , splitOn
146 , splitSuffixOn
148 -- ** Substreams
149 , isPrefixOf
150 , isSubsequenceOf
151 , stripPrefix
153 -- ** Map and Fold
154 , mapM_
156 -- ** Conversions
157 -- | Transform a stream into another type.
158 , toList
159 , toListRev
160 , toStreamK
161 , toStreamD
163 -- * Transformation
164 , transform
166 -- ** By folding (scans)
167 , scanlM'
168 , scanl'
169 , scanlM
170 , scanl
171 , scanl1M'
172 , scanl1'
173 , scanl1M
174 , scanl1
176 , prescanl'
177 , prescanlM'
179 , postscanl
180 , postscanlM
181 , postscanl'
182 , postscanlM'
184 , postscanlx'
185 , postscanlMx'
186 , scanlMx'
187 , scanlx'
189 -- * Filtering
190 , filter
191 , filterM
192 , uniq
193 , take
194 , takeWhile
195 , takeWhileM
196 , drop
197 , dropWhile
198 , dropWhileM
200 -- * Mapping
201 , map
202 , mapM
203 , sequence
205 -- * Inserting
206 , intersperseM
207 , intersperse
208 , insertAfterEach
209 , insertBy
211 -- * Deleting
212 , deleteBy
214 -- ** Map and Filter
215 , mapMaybe
216 , mapMaybeM
218 -- * Zipping
219 , indexed
220 , indexedR
221 , zipWith
222 , zipWithM
224 -- * Comparisons
225 , eqBy
226 , cmpBy
228 -- * Merging
229 , mergeBy
230 , mergeByM
232 -- * Transformation comprehensions
233 , the
235 -- * Exceptions
236 , before
237 , after
238 , bracket
239 , onException
240 , finally
241 , handle
243 -- * UTF8 Encoding / Decoding transformations.
244 , decodeUtf8
245 , encodeUtf8
246 )
247where
249import Control.Exception (Exception)
250import Control.Monad.Catch (MonadCatch)
251import Control.Monad.IO.Class (MonadIO(..))
252import Control.Monad.Trans (MonadTrans(lift))
253import Data.Bits (shiftR, shiftL, (.|.), (.&.))
254import Data.Maybe (fromJust, isJust)
255import Data.Word (Word32)
256import Foreign.Ptr (Ptr)
257import Foreign.Storable (Storable(..))
258import GHC.Base (assert, Char(..), unsafeChr, (-#), (+#), uncheckedIShiftL#,
259 word2Int#, chr#, ord)
260import GHC.IO.Encoding.Failure (isSurrogate)
261import GHC.Types (SPEC(..))
262import GHC.Word (Word8(..))
263import Prelude
264 hiding (map, mapM, mapM_, repeat, foldr, last, take, filter,
265 takeWhile, drop, dropWhile, all, any, maximum, minimum, elem,
266 notElem, null, head, tail, zipWith, lookup, foldr1, sequence,
267 (!!), scanl, scanl1, concatMap, replicate, enumFromTo, concat,
268 reverse)
270import qualified Control.Monad.Catch as MC
272import Streamly.Mem.Array.Types (Array(..))
273import Streamly.Fold.Types (Fold(..))
274import Streamly.Pipe.Types (Pipe(..), PipeState(..))
275import Streamly.SVar (MonadAsync, defState, adaptState)
276import Streamly.Sink.Types (Sink(..))
278import Streamly.Streams.StreamD.Type
280import qualified Streamly.Pipe.Types as Pipe
281import qualified Streamly.Mem.Array.Types as A
282import qualified Streamly.Mem.Ring as RB
283import qualified Streamly.Streams.StreamK as K
285------------------------------------------------------------------------------
286-- Construction
287------------------------------------------------------------------------------
289-- | An empty 'Stream'.
290{-# INLINE_NORMAL nil #-}
291nil :: Monad m => Stream m a
292nil = Stream (\_ _ -> return Stop) ()
294{-# INLINE_NORMAL consM #-}
295consM :: Monad m => m a -> Stream m a -> Stream m a
296consM m (Stream step state) = Stream step1 Nothing
297 where
298 {-# INLINE_LATE step1 #-}
299 step1 _ Nothing = m >>= \x -> return $ Yield x (Just state)
300 step1 gst (Just st) = do
301 r <- step gst st
302 return $
303 case r of
304 Yield a s -> Yield a (Just s)
305 Skip s -> Skip (Just s)
306 Stop -> Stop
308-- XXX implement in terms of consM?
309-- cons x = consM (return x)
310--
311-- | Can fuse but has O(n^2) complexity.
312{-# INLINE_NORMAL cons #-}
313cons :: Monad m => a -> Stream m a -> Stream m a
314cons x (Stream step state) = Stream step1 Nothing
315 where
316 {-# INLINE_LATE step1 #-}
317 step1 _ Nothing = return $ Yield x (Just state)
318 step1 gst (Just st) = do
319 r <- step gst st
320 return $
321 case r of
322 Yield a s -> Yield a (Just s)
323 Skip s -> Skip (Just s)
324 Stop -> Stop
326-------------------------------------------------------------------------------
327-- Deconstruction
328-------------------------------------------------------------------------------
330-- Does not fuse, has the same performance as the StreamK version.
331{-# INLINE_NORMAL uncons #-}
332uncons :: Monad m => Stream m a -> m (Maybe (a, Stream m a))
333uncons (UnStream step state) = go state
334 where
335 go st = do
336 r <- step defState st
337 case r of
338 Yield x s -> return $ Just (x, Stream step s)
339 Skip s -> go s
340 Stop -> return Nothing
342------------------------------------------------------------------------------
343-- Generation by unfold
344------------------------------------------------------------------------------
346{-# INLINE_NORMAL unfoldrM #-}
347unfoldrM :: Monad m => (s -> m (Maybe (a, s))) -> s -> Stream m a
348unfoldrM next state = Stream step state
349 where
350 {-# INLINE_LATE step #-}
351 step _ st = do
352 r <- next st
353 return $ case r of
354 Just (x, s) -> Yield x s
355 Nothing -> Stop
357{-# INLINE_LATE unfoldr #-}
358unfoldr :: Monad m => (s -> Maybe (a, s)) -> s -> Stream m a
359unfoldr f = unfoldrM (return . f)
361------------------------------------------------------------------------------
362-- Specialized Generation
363------------------------------------------------------------------------------
365repeat :: Monad m => a -> Stream m a
366repeat x = Stream (\_ _ -> return $ Yield x ()) ()
368{-# INLINE_NORMAL replicateM #-}
369replicateM :: Monad m => Int -> m a -> Stream m a
370replicateM n p = Stream step n
371 where
372 {-# INLINE_LATE step #-}
373 step _ i | i <= 0 = return Stop
374 | otherwise = do
375 x <- p
376 return $ Yield x (i - 1)
378{-# INLINE_NORMAL replicate #-}
379replicate :: Monad m => Int -> a -> Stream m a
380replicate n x = replicateM n (return x)
382-- This would not work properly for floats, therefore we put an Integral
383-- constraint.
384-- | Can be used to enumerate unbounded integrals. This does not check for
385-- overflow or underflow for bounded integrals.
386{-# INLINE_NORMAL enumerateFromStepIntegral #-}
387enumerateFromStepIntegral :: (Integral a, Monad m) => a -> a -> Stream m a
388enumerateFromStepIntegral from stride =
389 from `seq` stride `seq` Stream step from
390 where
391 {-# INLINE_LATE step #-}
392 step _ !x = return $ Yield x $! (x + stride)
394-- We are assuming that "to" is constrained by the type to be within
395-- max/min bounds.
396{-# INLINE enumerateFromToIntegral #-}
397enumerateFromToIntegral :: (Monad m, Integral a) => a -> a -> Stream m a
398enumerateFromToIntegral from to =
399 takeWhile (<= to) $ enumerateFromStepIntegral from 1
401{-# INLINE enumerateFromIntegral #-}
402enumerateFromIntegral :: (Monad m, Integral a, Bounded a) => a -> Stream m a
403enumerateFromIntegral from = enumerateFromToIntegral from maxBound
405data EnumState a = EnumInit | EnumYield a a a | EnumStop
407{-# INLINE_NORMAL enumerateFromThenToIntegralUp #-}
408enumerateFromThenToIntegralUp
409 :: (Monad m, Integral a)
410 => a -> a -> a -> Stream m a
411enumerateFromThenToIntegralUp from next to = Stream step EnumInit
412 where
413 {-# INLINE_LATE step #-}
414 step _ EnumInit =
415 return $
416 if to < next
417 then if to < from
418 then Stop
419 else Yield from EnumStop
420 else -- from <= next <= to
421 let stride = next - from
422 in Skip $ EnumYield from stride (to - stride)
424 step _ (EnumYield x stride toMinus) =
425 return $
426 if x > toMinus
427 then Yield x EnumStop
428 else Yield x $ EnumYield (x + stride) stride toMinus
430 step _ EnumStop = return Stop
432{-# INLINE_NORMAL enumerateFromThenToIntegralDn #-}
433enumerateFromThenToIntegralDn
434 :: (Monad m, Integral a)
435 => a -> a -> a -> Stream m a
436enumerateFromThenToIntegralDn from next to = Stream step EnumInit
437 where
438 {-# INLINE_LATE step #-}
439 step _ EnumInit =
440 return $ if to > next
441 then if to > from
442 then Stop
443 else Yield from EnumStop
444 else -- from >= next >= to
445 let stride = next - from
446 in Skip $ EnumYield from stride (to - stride)
448 step _ (EnumYield x stride toMinus) =
449 return $
450 if x < toMinus
451 then Yield x EnumStop
452 else Yield x $ EnumYield (x + stride) stride toMinus
454 step _ EnumStop = return Stop
456{-# INLINE_NORMAL enumerateFromThenToIntegral #-}
457enumerateFromThenToIntegral
458 :: (Monad m, Integral a)
459 => a -> a -> a -> Stream m a
460enumerateFromThenToIntegral from next to
461 | next >= from = enumerateFromThenToIntegralUp from next to
462 | otherwise = enumerateFromThenToIntegralDn from next to
464{-# INLINE_NORMAL enumerateFromThenIntegral #-}
465enumerateFromThenIntegral
466 :: (Monad m, Integral a, Bounded a)
467 => a -> a -> Stream m a
468enumerateFromThenIntegral from next =
469 if next > from
470 then enumerateFromThenToIntegralUp from next maxBound
471 else enumerateFromThenToIntegralDn from next minBound
473-- For floating point numbers if the increment is less than the precision then
474-- it just gets lost. Therefore we cannot always increment it correctly by just
475-- repeated addition.
476-- 9007199254740992 + 1 + 1 :: Double => 9.007199254740992e15
477-- 9007199254740992 + 2 :: Double => 9.007199254740994e15
479-- Instead we accumulate the increment counter and compute the increment
480-- everytime before adding it to the starting number.
481--
482-- This works for Integrals as well as floating point numbers, but
483-- enumerateFromStepIntegral is faster for integrals.
484{-# INLINE_NORMAL enumerateFromStepNum #-}
485enumerateFromStepNum :: (Monad m, Num a) => a -> a -> Stream m a
486enumerateFromStepNum from stride = Stream step 0
487 where
488 {-# INLINE_LATE step #-}
489 step _ !i = return $ (Yield $! (from + i * stride)) $! (i + 1)
491{-# INLINE_NORMAL numFrom #-}
492numFrom :: (Monad m, Num a) => a -> Stream m a
493numFrom from = enumerateFromStepNum from 1
495{-# INLINE_NORMAL numFromThen #-}
496numFromThen :: (Monad m, Num a) => a -> a -> Stream m a
497numFromThen from next = enumerateFromStepNum from (next - from)
499-- We cannot write a general function for Num. The only way to write code
500-- portable between the two is to use a 'Real' constraint and convert between
501-- Fractional and Integral using fromRational which is horribly slow.
502{-# INLINE_NORMAL enumerateFromToFractional #-}
503enumerateFromToFractional
504 :: (Monad m, Fractional a, Ord a)
505 => a -> a -> Stream m a
506enumerateFromToFractional from to =
507 takeWhile (<= to + 1 / 2) $ enumerateFromStepNum from 1
509{-# INLINE_NORMAL enumerateFromThenToFractional #-}
510enumerateFromThenToFractional
511 :: (Monad m, Fractional a, Ord a)
512 => a -> a -> a -> Stream m a
513enumerateFromThenToFractional from next to =
514 takeWhile predicate $ numFromThen from next
515 where
516 mid = (next - from) / 2
517 predicate | next >= from = (<= to + mid)
518 | otherwise = (>= to + mid)
520-------------------------------------------------------------------------------
521-- Generation by Conversion
522-------------------------------------------------------------------------------
524{-# INLINE_NORMAL fromIndicesM #-}
525fromIndicesM :: Monad m => (Int -> m a) -> Stream m a
526fromIndicesM gen = Stream step 0
527 where
528 {-# INLINE_LATE step #-}
529 step _ i = do
530 x <- gen i
531 return $ Yield x (i + 1)
533{-# INLINE fromIndices #-}
534fromIndices :: Monad m => (Int -> a) -> Stream m a
535fromIndices gen = fromIndicesM (return . gen)
537{-# INLINE_NORMAL generateM #-}
538generateM :: Monad m => Int -> (Int -> m a) -> Stream m a
539generateM n gen = n `seq` Stream step 0
540 where
541 {-# INLINE_LATE step #-}
542 step _ i | i < n = do
543 x <- gen i
544 return $ Yield x (i + 1)
545 | otherwise = return Stop
547{-# INLINE generate #-}
548generate :: Monad m => Int -> (Int -> a) -> Stream m a
549generate n gen = generateM n (return . gen)
551-- XXX we need the MonadAsync constraint because of a rewrite rule.
552-- | Convert a list of monadic actions to a 'Stream'
553{-# INLINE_LATE fromListM #-}
554fromListM :: MonadAsync m => [m a] -> Stream m a
555fromListM = Stream step
556 where
557 {-# INLINE_LATE step #-}
558 step _ (m:ms) = m >>= \x -> return $ Yield x ms
559 step _ [] = return Stop
561{-# INLINE toStreamD #-}
562toStreamD :: (K.IsStream t, Monad m) => t m a -> Stream m a
563toStreamD = fromStreamK . K.toStream
565------------------------------------------------------------------------------
566-- Elimination by Folds
567------------------------------------------------------------------------------
569------------------------------------------------------------------------------
570-- Right Folds
571------------------------------------------------------------------------------
573{-# INLINE_NORMAL foldr1 #-}
574foldr1 :: Monad m => (a -> a -> a) -> Stream m a -> m (Maybe a)
575foldr1 f m = do
576 r <- uncons m
577 case r of
578 Nothing -> return Nothing
579 Just (h, t) -> fmap Just (foldr f h t)
581------------------------------------------------------------------------------
582-- Left Folds
583------------------------------------------------------------------------------
585{-# INLINE_NORMAL foldlT #-}
586foldlT :: (Monad m, Monad (s m), MonadTrans s)
587 => (s m b -> a -> s m b) -> s m b -> Stream m a -> s m b
588foldlT fstep begin (Stream step state) = go SPEC begin state
589 where
590 go !_ acc st = do
591 r <- lift $ step defState st
592 case r of
593 Yield x s -> go SPEC (fstep acc x) s
594 Skip s -> go SPEC acc s
595 Stop -> acc
597-- Note, this is going to have horrible performance, because of the nature of
598-- the stream type (i.e. direct stream vs CPS). Its only for reference, it is
599-- likely be practically unusable.
600{-# INLINE_NORMAL foldlS #-}
601foldlS :: Monad m
602 => (Stream m b -> a -> Stream m b) -> Stream m b -> Stream m a -> Stream m b
603foldlS fstep begin (Stream step state) = Stream step' (Left (state, begin))
604 where
605 step' gst (Left (st, acc)) = do
606 r <- step (adaptState gst) st
607 return $ case r of
608 Yield x s -> Skip (Left (s, fstep acc x))
609 Skip s -> Skip (Left (s, acc))
610 Stop -> Skip (Right acc)
612 step' gst (Right (Stream stp stt)) = do
613 r <- stp (adaptState gst) stt
614 return $ case r of
615 Yield x s -> Yield x (Right (Stream stp s))
616 Skip s -> Skip (Right (Stream stp s))
617 Stop -> Stop
619------------------------------------------------------------------------------
620-- Specialized Folds
621------------------------------------------------------------------------------
623-- | Run a streaming composition, discard the results.
624{-# INLINE_LATE drain #-}
625drain :: Monad m => Stream m a -> m ()
626-- drain = foldrM (\_ xs -> xs) (return ())
627drain (Stream step state) = go SPEC state
628 where
629 go !_ st = do
630 r <- step defState st
631 case r of
632 Yield _ s -> go SPEC s
633 Skip s -> go SPEC s
634 Stop -> return ()
636{-# INLINE_NORMAL null #-}
637null :: Monad m => Stream m a -> m Bool
638null m = foldrM (\_ _ -> return False) (return True) m
640-- XXX SPEC?
641{-# INLINE_NORMAL head #-}
642head :: Monad m => Stream m a -> m (Maybe a)
643head m = foldrM (\x _ -> return (Just x)) (return Nothing) m
645-- Does not fuse, has the same performance as the StreamK version.
646{-# INLINE_NORMAL tail #-}
647tail :: Monad m => Stream m a -> m (Maybe (Stream m a))
648tail (UnStream step state) = go state
649 where
650 go st = do
651 r <- step defState st
652 case r of
653 Yield _ s -> return (Just $ Stream step s)
654 Skip s -> go s
655 Stop -> return Nothing
657-- XXX will it fuse? need custom impl?
658{-# INLINE_NORMAL last #-}
659last :: Monad m => Stream m a -> m (Maybe a)
660last = foldl' (\_ y -> Just y) Nothing
662{-# INLINE_NORMAL elem #-}
663elem :: (Monad m, Eq a) => a -> Stream m a -> m Bool
664-- elem e m = foldrM (\x xs -> if x == e then return True else xs) (return False) m
665elem e (Stream step state) = go state
666 where
667 go st = do
668 r <- step defState st
669 case r of
670 Yield x s
671 | x == e -> return True
672 | otherwise -> go s
673 Skip s -> go s
674 Stop -> return False
676{-# INLINE_NORMAL notElem #-}
677notElem :: (Monad m, Eq a) => a -> Stream m a -> m Bool
678notElem e s = fmap not (elem e s)
680{-# INLINE_NORMAL all #-}
681all :: Monad m => (a -> Bool) -> Stream m a -> m Bool
682-- all p m = foldrM (\x xs -> if p x then xs else return False) (return True) m
683all p (Stream step state) = go state
684 where
685 go st = do
686 r <- step defState st
687 case r of
688 Yield x s
689 | p x -> go s
690 | otherwise -> return False
691 Skip s -> go s
692 Stop -> return True
694{-# INLINE_NORMAL any #-}
695any :: Monad m => (a -> Bool) -> Stream m a -> m Bool
696-- any p m = foldrM (\x xs -> if p x then return True else xs) (return False) m
697any p (Stream step state) = go state
698 where
699 go st = do
700 r <- step defState st
701 case r of
702 Yield x s
703 | p x -> return True
704 | otherwise -> go s
705 Skip s -> go s
706 Stop -> return False
708{-# INLINE_NORMAL maximum #-}
709maximum :: (Monad m, Ord a) => Stream m a -> m (Maybe a)
710maximum (Stream step state) = go Nothing state
711 where
712 go Nothing st = do
713 r <- step defState st
714 case r of
715 Yield x s -> go (Just x) s
716 Skip s -> go Nothing s
717 Stop -> return Nothing
718 go (Just acc) st = do
719 r <- step defState st
720 case r of
721 Yield x s
722 | acc <= x -> go (Just x) s
723 | otherwise -> go (Just acc) s
724 Skip s -> go (Just acc) s
725 Stop -> return (Just acc)
727{-# INLINE_NORMAL maximumBy #-}
728maximumBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> m (Maybe a)
729maximumBy cmp (Stream step state) = go Nothing state
730 where
731 go Nothing st = do
732 r <- step defState st
733 case r of
734 Yield x s -> go (Just x) s
735 Skip s -> go Nothing s
736 Stop -> return Nothing
737 go (Just acc) st = do
738 r <- step defState st
739 case r of
740 Yield x s -> case cmp acc x of
741 GT -> go (Just acc) s
742 _ -> go (Just x) s
743 Skip s -> go (Just acc) s
744 Stop -> return (Just acc)
746{-# INLINE_NORMAL minimum #-}
747minimum :: (Monad m, Ord a) => Stream m a -> m (Maybe a)
748minimum (Stream step state) = go Nothing state
749 where
750 go Nothing st = do
751 r <- step defState st
752 case r of
753 Yield x s -> go (Just x) s
754 Skip s -> go Nothing s
755 Stop -> return Nothing
756 go (Just acc) st = do
757 r <- step defState st
758 case r of
759 Yield x s
760 | acc <= x -> go (Just acc) s
761 | otherwise -> go (Just x) s
762 Skip s -> go (Just acc) s
763 Stop -> return (Just acc)
765{-# INLINE_NORMAL minimumBy #-}
766minimumBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> m (Maybe a)
767minimumBy cmp (Stream step state) = go Nothing state
768 where
769 go Nothing st = do
770 r <- step defState st
771 case r of
772 Yield x s -> go (Just x) s
773 Skip s -> go Nothing s
774 Stop -> return Nothing
775 go (Just acc) st = do
776 r <- step defState st
777 case r of
778 Yield x s -> case cmp acc x of
779 GT -> go (Just x) s
780 _ -> go (Just acc) s
781 Skip s -> go (Just acc) s
782 Stop -> return (Just acc)
784{-# INLINE_NORMAL (!!) #-}
785(!!) :: (Monad m) => Stream m a -> Int -> m (Maybe a)
786(Stream step state) !! i = go i state
787 where
788 go n st = do
789 r <- step defState st
790 case r of
791 Yield x s | n < 0 -> return Nothing
792 | n == 0 -> return $ Just x
793 | otherwise -> go (n - 1) s
794 Skip s -> go n s
795 Stop -> return Nothing
797{-# INLINE_NORMAL lookup #-}
798lookup :: (Monad m, Eq a) => a -> Stream m (a, b) -> m (Maybe b)
799lookup e m = foldrM (\(a, b) xs -> if e == a then return (Just b) else xs)
800 (return Nothing) m
802{-# INLINE_NORMAL findM #-}
803findM :: Monad m => (a -> m Bool) -> Stream m a -> m (Maybe a)
804findM p m = foldrM (\x xs -> p x >>= \r -> if r then return (Just x) else xs)
805 (return Nothing) m
807{-# INLINE find #-}
808find :: Monad m => (a -> Bool) -> Stream m a -> m (Maybe a)
809find p = findM (return . p)
811{-# INLINE_NORMAL findIndices #-}
812findIndices :: Monad m => (a -> Bool) -> Stream m a -> Stream m Int
813findIndices p (Stream step state) = Stream step' (state, 0)
814 where
815 {-# INLINE_LATE step' #-}
816 step' gst (st, i) = do
817 r <- step (adaptState gst) st
818 return $ case r of
819 Yield x s -> if p x then Yield i (s, i+1) else Skip (s, i+1)
820 Skip s -> Skip (s, i+1)
821 Stop -> Stop
823{-# INLINE toListRev #-}
824toListRev :: Monad m => Stream m a -> m [a]
825toListRev = foldl' (flip (:)) []
827-- We can implement reverse as:
828--
829-- > reverse = foldlS (flip cons) nil
830--
831-- However, this implementation is unusable because of the horrible performance
832-- of cons. So we just convert it to a list first and then stream from the
833-- list.
834--
835-- XXX Maybe we can use an Array instead of a list here?
836{-# INLINE_NORMAL reverse #-}
837reverse :: Monad m => Stream m a -> Stream m a
838reverse m = Stream step Nothing
839 where
840 {-# INLINE_LATE step #-}
841 step _ Nothing = do
842 xs <- toListRev m
843 return $ Skip (Just xs)
844 step _ (Just (x:xs)) = return $ Yield x (Just xs)
845 step _ (Just []) = return Stop
847-- Much faster reverse for Storables
848{-# INLINE_NORMAL reverse' #-}
849reverse' :: forall m a. (MonadIO m, Storable a) => Stream m a -> Stream m a
850{-
851-- This commented implementation copies the whole stream into one single array
852-- and then streams from that array, this is 3-4x faster than the chunked code
853-- that follows. Though this could be problematic due to unbounded large
854-- allocations. We need to figure out why the chunked code is slower and if we
855-- can optimize the chunked code to work as fast as this one. It may be a
856-- fusion issue?
857import Foreign.ForeignPtr (touchForeignPtr)
858import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
859import Foreign.Ptr (Ptr, plusPtr)
860reverse' m = Stream step Nothing
861 where
862 {-# INLINE_LATE step #-}
863 step _ Nothing = do
864 arr <- A.fromStreamD m
865 let p = aEnd arr `plusPtr` negate (sizeOf (undefined :: a))
866 return $ Skip $ Just (aStart arr, p)
868 step _ (Just (start, p)) | p < unsafeForeignPtrToPtr start = return Stop
870 step _ (Just (start, p)) = do
871 let !x = A.unsafeInlineIO $ do
872 r <- peek p
873 touchForeignPtr start
874 return r
875 next = p `plusPtr` negate (sizeOf (undefined :: a))
876 return $ Yield x (Just (start, next))
877-}
878reverse' m =
879 A.flattenArraysRev
880 $ fromStreamK
881 $ K.reverse
882 $ toStreamK
883 $ A.fromStreamDArraysOf A.defaultChunkSize m
886------------------------------------------------------------------------------
887-- Grouping/Splitting
888------------------------------------------------------------------------------
890{-# INLINE_NORMAL splitSuffixBy' #-}
891splitSuffixBy' :: Monad m
892 => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
893splitSuffixBy' predicate f (Stream step state) =
894 Stream (stepOuter f) (Just state)
896 where
898 {-# INLINE_LATE stepOuter #-}
899 stepOuter (Fold fstep initial done) gst (Just st) = do
900 res <- step (adaptState gst) st
901 case res of
902 Yield x s -> do
903 acc <- initial
904 acc' <- fstep acc x
905 if (predicate x)
906 then done acc' >>= \val -> return $ Yield val (Just s)
907 else go SPEC s acc'
909 Skip s -> return $ Skip $ Just s
910 Stop -> return Stop
912 where
914 go !_ stt !acc = do
915 res <- step (adaptState gst) stt
916 case res of
917 Yield x s -> do
918 acc' <- fstep acc x
919 if (predicate x)
920 then done acc' >>= \val -> return $ Yield val (Just s)
921 else go SPEC s acc'
922 Skip s -> go SPEC s acc
923 Stop -> done acc >>= \val -> return $ Yield val Nothing
925 stepOuter _ _ Nothing = return Stop
927{-# INLINE_NORMAL groupsBy #-}
928groupsBy :: Monad m
929 => (a -> a -> Bool)
930 -> Fold m a b
931 -> Stream m a
932 -> Stream m b
933groupsBy cmp f (Stream step state) = Stream (stepOuter f) (Just state, Nothing)
935 where
937 {-# INLINE_LATE stepOuter #-}
938 stepOuter (Fold fstep initial done) gst (Just st, Nothing) = do
939 res <- step (adaptState gst) st
940 case res of
941 Yield x s -> do
942 acc <- initial
943 acc' <- fstep acc x
944 go SPEC x s acc'
946 Skip s -> return $ Skip $ (Just s, Nothing)
947 Stop -> return Stop
949 where
951 go !_ prev stt !acc = do
952 res <- step (adaptState gst) stt
953 case res of
954 Yield x s -> do
955 if cmp x prev
956 then do
957 acc' <- fstep acc x
958 go SPEC prev s acc'
959 else done acc >>= \r -> return $ Yield r (Just s, Just x)
960 Skip s -> go SPEC prev s acc
961 Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
963 stepOuter (Fold fstep initial done) gst (Just st, Just prev) = do
964 acc <- initial
965 acc' <- fstep acc prev
966 go SPEC st acc'
968 where
970 -- XXX code duplicated from the previous equation
971 go !_ stt !acc = do
972 res <- step (adaptState gst) stt
973 case res of
974 Yield x s -> do
975 if cmp x prev
976 then do
977 acc' <- fstep acc x
978 go SPEC s acc'
979 else done acc >>= \r -> return $ Yield r (Just s, Just x)
980 Skip s -> go SPEC s acc
981 Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
983 stepOuter _ _ (Nothing,_) = return Stop
985{-# INLINE_NORMAL groupsRollingBy #-}
986groupsRollingBy :: Monad m
987 => (a -> a -> Bool)
988 -> Fold m a b
989 -> Stream m a
990 -> Stream m b
991groupsRollingBy cmp f (Stream step state) =
992 Stream (stepOuter f) (Just state, Nothing)
993 where
995 {-# INLINE_LATE stepOuter #-}
996 stepOuter (Fold fstep initial done) gst (Just st, Nothing) = do
997 res <- step (adaptState gst) st
998 case res of
999 Yield x s -> do
1000 acc <- initial
1001 acc' <- fstep acc x
1002 go SPEC x s acc'
1004 Skip s -> return $ Skip $ (Just s, Nothing)
1005 Stop -> return Stop
1007 where
1008 go !_ prev stt !acc = do
1009 res <- step (adaptState gst) stt
1010 case res of
1011 Yield x s -> do
1012 if cmp prev x
1013 then do
1014 acc' <- fstep acc x
1015 go SPEC x s acc'
1016 else
1017 done acc >>= \r -> return $ Yield r (Just s, Just x)
1018 Skip s -> go SPEC prev s acc
1019 Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1021 stepOuter (Fold fstep initial done) gst (Just st, Just prev') = do
1022 acc <- initial
1023 acc' <- fstep acc prev'
1024 go SPEC prev' st acc'
1026 where
1027 go !_ prevv stt !acc = do
1028 res <- step (adaptState gst) stt
1029 case res of
1030 Yield x s -> do
1031 if cmp prevv x
1032 then do
1033 acc' <- fstep acc x
1034 go SPEC x s acc'
1035 else done acc >>= \r -> return $ Yield r (Just s, Just x)
1036 Skip s -> go SPEC prevv s acc
1037 Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1039 stepOuter _ _ (Nothing, _) = return Stop
1041{-# INLINE_NORMAL splitBy #-}
1042splitBy :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
1043splitBy predicate f (Stream step state) = Stream (step' f) (Just state)
1045 where
1047 {-# INLINE_LATE step' #-}
1048 step' (Fold fstep initial done) gst (Just st) = initial >>= go SPEC st
1050 where
1052 go !_ stt !acc = do
1053 res <- step (adaptState gst) stt
1054 case res of
1055 Yield x s -> do
1056 if predicate x
1057 then done acc >>= \r -> return $ Yield r (Just s)
1058 else do
1059 acc' <- fstep acc x
1060 go SPEC s acc'
1061 Skip s -> go SPEC s acc
1062 Stop -> done acc >>= \r -> return $ Yield r Nothing
1064 step' _ _ Nothing = return Stop
1066{-# INLINE_NORMAL splitSuffixBy #-}
1067splitSuffixBy :: Monad m
1068 => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
1069splitSuffixBy predicate f (Stream step state) = Stream (step' f) (Just state)
1071 where
1073 {-# INLINE_LATE step' #-}
1074 step' (Fold fstep initial done) gst (Just st) = do
1075 res <- step (adaptState gst) st
1076 case res of
1077 Yield x s -> do
1078 acc <- initial
1079 if predicate x
1080 then done acc >>= \val -> return $ Yield val (Just s)
1081 else do
1082 acc' <- fstep acc x
1083 go SPEC s acc'
1085 Skip s -> return $ Skip $ Just s
1086 Stop -> return Stop
1088 where
1090 go !_ stt !acc = do
1091 res <- step (adaptState gst) stt
1092 case res of
1093 Yield x s -> do
1094 if predicate x
1095 then done acc >>= \r -> return $ Yield r (Just s)
1096 else do
1097 acc' <- fstep acc x
1098 go SPEC s acc'
1099 Skip s -> go SPEC s acc
1100 Stop -> done acc >>= \r -> return $ Yield r Nothing
1102 step' _ _ Nothing = return Stop
1104{-# INLINE_NORMAL wordsBy #-}
1105wordsBy :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
1106wordsBy predicate f (Stream step state) = Stream (stepOuter f) (Just state)
1108 where
1110 {-# INLINE_LATE stepOuter #-}
1111 stepOuter (Fold fstep initial done) gst (Just st) = do
1112 res <- step (adaptState gst) st
1113 case res of
1114 Yield x s -> do
1115 if predicate x
1116 then return $ Skip (Just s)
1117 else do
1118 acc <- initial
1119 acc' <- fstep acc x
1120 go SPEC s acc'
1122 Skip s -> return $ Skip $ Just s
1123 Stop -> return Stop
1125 where
1127 go !_ stt !acc = do
1128 res <- step (adaptState gst) stt
1129 case res of
1130 Yield x s -> do
1131 if predicate x
1132 then done acc >>= \r -> return $ Yield r (Just s)
1133 else do
1134 acc' <- fstep acc x
1135 go SPEC s acc'
1136 Skip s -> go SPEC s acc
1137 Stop -> done acc >>= \r -> return $ Yield r Nothing
1139 stepOuter _ _ Nothing = return Stop
1141-- String search algorithms:
1142-- http://www-igm.univ-mlv.fr/~lecroq/string/index.html
1145-- TODO can we unify the splitting operations using a splitting configuration
1146-- like in the split package.
1148data SplitStyle = Infix | Suffix | Prefix deriving (Eq, Show)
1150data SplitOptions = SplitOptions
1151 { style :: SplitStyle
1152 , withSep :: Bool -- ^ keep the separators in output
1153 -- , compact :: Bool -- ^ treat multiple consecutive separators as one
1154 -- , trimHead :: Bool -- ^ drop blank at head
1155 -- , trimTail :: Bool -- ^ drop blank at tail
1159data SplitOnState s a =
1160 GO_START
1161 | GO_EMPTY_PAT s
1162 | GO_SINGLE_PAT s a
1163 | GO_SHORT_PAT s
1164 | GO_KARP_RABIN s !(RB.Ring a) !(Ptr a)
1165 | GO_DONE
1167{-# INLINE_NORMAL splitOn #-}
1168splitOn
1169 :: forall m a b. (MonadIO m, Storable a, Enum a, Eq a)
1170 => Array a
1171 -> Fold m a b
1172 -> Stream m a
1173 -> Stream m b
1174splitOn patArr@Array{..} (Fold fstep initial done) (Stream step state) =
1175 Stream stepOuter GO_START
1177 where
1179 patLen = A.length patArr
1180 maxIndex = patLen - 1
1181 elemBits = sizeOf (undefined :: a) * 8
1183 {-# INLINE_LATE stepOuter #-}
1184 stepOuter _ GO_START =
1185 if patLen == 0
1186 then return $ Skip $ GO_EMPTY_PAT state
1187 else if patLen == 1
1188 then do
1189 r <- liftIO $ (A.unsafeIndexIO patArr 0)
1190 return $ Skip $ GO_SINGLE_PAT state r
1191 else if sizeOf (undefined :: a) * patLen
1192 <= sizeOf (undefined :: Word)
1193 then return $ Skip $ GO_SHORT_PAT state
1194 else do
1195 (rb, rhead) <- liftIO $ RB.new patLen
1196 return $ Skip $ GO_KARP_RABIN state rb rhead
1198 stepOuter gst (GO_SINGLE_PAT stt pat) = initial >>= go SPEC stt
1200 where
1202 go !_ st !acc = do
1203 res <- step (adaptState gst) st
1204 case res of
1205 Yield x s -> do
1206 if pat == x
1207 then do
1208 r <- done acc
1209 return $ Yield r (GO_SINGLE_PAT s pat)
1210 else fstep acc x >>= go SPEC s
1211 Skip s -> go SPEC s acc
1212 Stop -> done acc >>= \r -> return $ Yield r GO_DONE
1214 stepOuter gst (GO_SHORT_PAT stt) = initial >>= go0 SPEC 0 (0 :: Word) stt
1216 where
1218 mask :: Word
1219 mask = (1 `shiftL` (elemBits * patLen)) - 1
1221 addToWord wrd a = (wrd `shiftL` elemBits) .|. fromIntegral (fromEnum a)
1223 patWord :: Word
1224 patWord = mask .&. A.foldl' addToWord 0 patArr
1226 go0 !_ !idx wrd st !acc = do
1227 res <- step (adaptState gst) st
1228 case res of
1229 Yield x s -> do
1230 let wrd' = addToWord wrd x
1231 if idx == maxIndex
1232 then do
1233 if wrd' .&. mask == patWord
1234 then do
1235 r <- done acc
1236 return $ Yield r (GO_SHORT_PAT s)
1237 else go1 SPEC wrd' s acc
1238 else go0 SPEC (idx + 1) wrd' s acc
1239 Skip s -> go0 SPEC idx wrd s acc
1240 Stop -> do
1241 acc' <- if idx /= 0
1242 then go2 wrd idx acc
1243 else return acc
1244 done acc' >>= \r -> return $ Yield r GO_DONE
1246 {-# INLINE go1 #-}
1247 go1 !_ wrd st !acc = do
1248 res <- step (adaptState gst) st
1249 case res of
1250 Yield x s -> do
1251 let wrd' = addToWord wrd x
1252 old = (mask .&. wrd) `shiftR` (elemBits * (patLen - 1))
1253 acc' <- fstep acc (toEnum $ fromIntegral old)
1254 if wrd' .&. mask == patWord
1255 then done acc' >>= \r -> return $ Yield r (GO_SHORT_PAT s)
1256 else go1 SPEC wrd' s acc'
1257 Skip s -> go1 SPEC wrd s acc
1258 Stop -> do
1259 acc' <- go2 wrd patLen acc
1260 done acc' >>= \r -> return $ Yield r GO_DONE
1262 go2 !wrd !n !acc | n > 0 = do
1263 let old = (mask .&. wrd) `shiftR` (elemBits * (n - 1))
1264 fstep acc (toEnum $ fromIntegral old) >>= go2 wrd (n - 1)
1265 go2 _ _ acc = return acc
1267 stepOuter gst (GO_KARP_RABIN stt rb rhead) = do
1268 initial >>= go0 SPEC 0 rhead stt
1270 where
1272 k = 2891336453 :: Word32
1273 coeff = k ^ patLen
1274 addCksum cksum a = cksum * k + fromIntegral (fromEnum a)
1275 deltaCksum cksum old new =
1276 addCksum cksum new - coeff * fromIntegral (fromEnum old)
1278 -- XXX shall we use a random starting hash or 1 instead of 0?
1279 patHash = A.foldl' addCksum 0 patArr
1281 -- rh == ringHead
1282 go0 !_ !idx !rh st !acc = do
1283 res <- step (adaptState gst) st
1284 case res of
1285 Yield x s -> do
1286 rh' <- liftIO $ RB.unsafeInsert rb rh x
1287 if idx == maxIndex
1288 then do
1289 let fold = RB.unsafeFoldRing (RB.ringBound rb)
1290 let !ringHash = fold addCksum 0 rb
1291 if ringHash == patHash
1292 then go2 SPEC ringHash rh' s acc
1293 else go1 SPEC ringHash rh' s acc
1294 else go0 SPEC (idx + 1) rh' s acc
1295 Skip s -> go0 SPEC idx rh s acc
1296 Stop -> do
1297 !acc' <- if idx /= 0
1298 then RB.unsafeFoldRingM rh fstep acc rb
1299 else return acc
1300 done acc' >>= \r -> return $ Yield r GO_DONE
1302 -- XXX Theoretically this code can do 4 times faster if GHC generates
1303 -- optimal code. If we use just "(cksum' == patHash)" condition it goes
1304 -- 4x faster, as soon as we add the "RB.unsafeEqArray rb v" condition
1305 -- the generated code changes drastically and becomes 4x slower. Need
1306 -- to investigate what is going on with GHC.
1307 {-# INLINE go1 #-}
1308 go1 !_ !cksum !rh st !acc = do
1309 res <- step (adaptState gst) st
1310 case res of
1311 Yield x s -> do
1312 old <- liftIO $ peek rh
1313 let cksum' = deltaCksum cksum old x
1314 acc' <- fstep acc old
1316 if (cksum' == patHash)
1317 then do
1318 rh' <- liftIO (RB.unsafeInsert rb rh x)
1319 go2 SPEC cksum' rh' s acc'
1320 else do
1321 rh' <- liftIO (RB.unsafeInsert rb rh x)
1322 go1 SPEC cksum' rh' s acc'
1323 Skip s -> go1 SPEC cksum rh s acc
1324 Stop -> do
1325 acc' <- RB.unsafeFoldRingFullM rh fstep acc rb
1326 done acc' >>= \r -> return $ Yield r GO_DONE
1328 go2 !_ !cksum' !rh' s !acc' = do
1329 if RB.unsafeEqArray rb rh' patArr
1330 then do
1331 r <- done acc'
1332 return $ Yield r (GO_KARP_RABIN s rb rhead)
1333 else go1 SPEC cksum' rh' s acc'
1335 stepOuter gst (GO_EMPTY_PAT st) = do
1336 res <- step (adaptState gst) st
1337 case res of
1338 Yield x s -> do
1339 acc <- initial
1340 acc' <- fstep acc x
1341 done acc' >>= \r -> return $ Yield r (GO_EMPTY_PAT s)
1342 Skip s -> return $ Skip (GO_EMPTY_PAT s)
1343 Stop -> return Stop
1345 stepOuter _ GO_DONE = return Stop
1347{-# INLINE_NORMAL splitSuffixOn #-}
1348splitSuffixOn
1349 :: forall m a b. (MonadIO m, Storable a, Enum a, Eq a)
1350 => Bool
1351 -> Array a
1352 -> Fold m a b
1353 -> Stream m a
1354 -> Stream m b
1355splitSuffixOn withSep patArr@Array{..} (Fold fstep initial done)
1356 (Stream step state) =
1357 Stream stepOuter GO_START
1359 where
1361 patLen = A.length patArr
1362 maxIndex = patLen - 1
1363 elemBits = sizeOf (undefined :: a) * 8
1365 {-# INLINE_LATE stepOuter #-}
1366 stepOuter _ GO_START =
1367 if patLen == 0
1368 then return $ Skip $ GO_EMPTY_PAT state
1369 else if patLen == 1
1370 then do
1371 r <- liftIO $ (A.unsafeIndexIO patArr 0)
1372 return $ Skip $ GO_SINGLE_PAT state r
1373 else if sizeOf (undefined :: a) * patLen
1374 <= sizeOf (undefined :: Word)
1375 then return $ Skip $ GO_SHORT_PAT state
1376 else do
1377 (rb, rhead) <- liftIO $ RB.new patLen
1378 return $ Skip $ GO_KARP_RABIN state rb rhead
1380 stepOuter gst (GO_SINGLE_PAT stt pat) = do
1381 -- This first part is the only difference between splitOn and
1382 -- splitSuffixOn.
1383 -- If the last element is a separator do not issue a blank segment.
1384 res <- step (adaptState gst) stt
1385 case res of
1386 Yield x s -> do
1387 acc <- initial
1388 if pat == x
1389 then do
1390 acc' <- if withSep then fstep acc x else return acc
1391 done acc' >>= \r -> return $ Yield r (GO_SINGLE_PAT s pat)
1392 else fstep acc x >>= go SPEC s
1393 Skip s -> return $ Skip $ (GO_SINGLE_PAT s pat)
1394 Stop -> return Stop
1396 where
1398 -- This is identical for splitOn and splitSuffixOn
1399 go !_ st !acc = do
1400 res <- step (adaptState gst) st
1401 case res of
1402 Yield x s -> do
1403 if pat == x
1404 then do
1405 acc' <- if withSep then fstep acc x else return acc
1406 r <- done acc'
1407 return $ Yield r (GO_SINGLE_PAT s pat)
1408 else fstep acc x >>= go SPEC s
1409 Skip s -> go SPEC s acc
1410 Stop -> done acc >>= \r -> return $ Yield r GO_DONE
1412 stepOuter gst (GO_SHORT_PAT stt) = do
1414 -- Call "initial" only if the stream yields an element, otherwise we
1415 -- may call "initial" but never yield anything. initial may produce a
1416 -- side effect, therefore we will end up doing and discard a side
1417 -- effect.
1419 let idx = 0
1420 let wrd = 0
1421 res <- step (adaptState gst) stt
1422 case res of
1423 Yield x s -> do
1424 acc <- initial
1425 let wrd' = addToWord wrd x
1426 acc' <- if withSep then fstep acc x else return acc
1427 if idx == maxIndex
1428 then do
1429 if wrd' .&. mask == patWord
1430 then done acc' >>= \r -> return $ Yield r (GO_SHORT_PAT s)
1431 else go0 SPEC (idx + 1) wrd' s acc'
1432 else go0 SPEC (idx + 1) wrd' s acc'
1433 Skip s -> return $ Skip (GO_SHORT_PAT s)
1434 Stop -> return Stop
1436 where
1438 mask :: Word
1439 mask = (1 `shiftL` (elemBits * patLen)) - 1
1441 addToWord wrd a = (wrd `shiftL` elemBits) .|. fromIntegral (fromEnum a)
1443 patWord :: Word
1444 patWord = mask .&. A.foldl' addToWord 0 patArr
1446 go0 !_ !idx wrd st !acc = do
1447 res <- step (adaptState gst) st
1448 case res of
1449 Yield x s -> do
1450 let wrd' = addToWord wrd x
1451 acc' <- if withSep then fstep acc x else return acc
1452 if idx == maxIndex
1453 then do
1454 if wrd' .&. mask == patWord
1455 then do
1456 r <- done acc'
1457 return $ Yield r (GO_SHORT_PAT s)
1458 else go1 SPEC wrd' s acc'
1459 else go0 SPEC (idx + 1) wrd' s acc'
1460 Skip s -> go0 SPEC idx wrd s acc
1461 Stop -> do
1462 if (idx == maxIndex) && (wrd .&. mask == patWord)
1463 then return Stop
1464 else do
1465 acc' <- if idx /= 0 && not withSep
1466 then go2 wrd idx acc
1467 else return acc
1468 done acc' >>= \r -> return $ Yield r GO_DONE
1470 {-# INLINE go1 #-}
1471 go1 !_ wrd st !acc = do
1472 res <- step (adaptState gst) st
1473 case res of
1474 Yield x s -> do
1475 let wrd' = addToWord wrd x
1476 old = (mask .&. wrd) `shiftR` (elemBits * (patLen - 1))
1477 acc' <- if withSep
1478 then fstep acc x
1479 else fstep acc (toEnum $ fromIntegral old)
1480 if wrd' .&. mask == patWord
1481 then done acc' >>= \r -> return $ Yield r (GO_SHORT_PAT s)
1482 else go1 SPEC wrd' s acc'
1483 Skip s -> go1 SPEC wrd s acc
1484 Stop ->
1485 -- If the last sequence is a separator do not issue a blank
1486 -- segment.
1487 if wrd .&. mask == patWord
1488 then return Stop
1489 else do
1490 acc' <- if withSep
1491 then return acc
1492 else go2 wrd patLen acc
1493 done acc' >>= \r -> return $ Yield r GO_DONE
1495 go2 !wrd !n !acc | n > 0 = do
1496 let old = (mask .&. wrd) `shiftR` (elemBits * (n - 1))
1497 fstep acc (toEnum $ fromIntegral old) >>= go2 wrd (n - 1)
1498 go2 _ _ acc = return acc
1500 stepOuter gst (GO_KARP_RABIN stt rb rhead) = do
1501 let idx = 0
1502 res <- step (adaptState gst) stt
1503 case res of
1504 Yield x s -> do
1505 acc <- initial
1506 acc' <- if withSep then fstep acc x else return acc
1507 rh' <- liftIO (RB.unsafeInsert rb rhead x)
1508 if idx == maxIndex
1509 then do
1510 let fold = RB.unsafeFoldRing (RB.ringBound rb)
1511 let !ringHash = fold addCksum 0 rb
1512 if ringHash == patHash
1513 then go2 SPEC ringHash rh' s acc'
1514 else go0 SPEC (idx + 1) rh' s acc'
1515 else go0 SPEC (idx + 1) rh' s acc'
1516 Skip s -> return $ Skip (GO_KARP_RABIN s rb rhead)
1517 Stop -> return Stop
1519 where
1521 k = 2891336453 :: Word32
1522 coeff = k ^ patLen
1523 addCksum cksum a = cksum * k + fromIntegral (fromEnum a)
1524 deltaCksum cksum old new =
1525 addCksum cksum new - coeff * fromIntegral (fromEnum old)
1527 -- XXX shall we use a random starting hash or 1 instead of 0?
1528 patHash = A.foldl' addCksum 0 patArr
1530 -- rh == ringHead
1531 go0 !_ !idx !rh st !acc = do
1532 res <- step (adaptState gst) st
1533 case res of
1534 Yield x s -> do
1535 acc' <- if withSep then fstep acc x else return acc
1536 rh' <- liftIO (RB.unsafeInsert rb rh x)
1537 if idx == maxIndex
1538 then do
1539 let fold = RB.unsafeFoldRing (RB.ringBound rb)
1540 let !ringHash = fold addCksum 0 rb
1541 if ringHash == patHash
1542 then go2 SPEC ringHash rh' s acc'
1543 else go1 SPEC ringHash rh' s acc'
1544 else go0 SPEC (idx + 1) rh' s acc'
1545 Skip s -> go0 SPEC idx rh s acc
1546 Stop -> do
1547 -- do not issue a blank segment when we end at pattern
1548 if (idx == maxIndex) && RB.unsafeEqArray rb rh patArr
1549 then return Stop
1550 else do
1551 !acc' <- if idx /= 0 && not withSep
1552 then RB.unsafeFoldRingM rh fstep acc rb
1553 else return acc
1554 done acc' >>= \r -> return $ Yield r GO_DONE
1556 -- XXX Theoretically this code can do 4 times faster if GHC generates
1557 -- optimal code. If we use just "(cksum' == patHash)" condition it goes
1558 -- 4x faster, as soon as we add the "RB.unsafeEqArray rb v" condition
1559 -- the generated code changes drastically and becomes 4x slower. Need
1560 -- to investigate what is going on with GHC.
1561 {-# INLINE go1 #-}
1562 go1 !_ !cksum !rh st !acc = do
1563 res <- step (adaptState gst) st
1564 case res of
1565 Yield x s -> do
1566 old <- liftIO $ peek rh
1567 let cksum' = deltaCksum cksum old x
1568 acc' <- if withSep
1569 then fstep acc x
1570 else fstep acc old
1572 if (cksum' == patHash)
1573 then do
1574 rh' <- liftIO (RB.unsafeInsert rb rh x)
1575 go2 SPEC cksum' rh' s acc'
1576 else do
1577 rh' <- liftIO (RB.unsafeInsert rb rh x)
1578 go1 SPEC cksum' rh' s acc'
1579 Skip s -> go1 SPEC cksum rh s acc
1580 Stop -> do
1581 if RB.unsafeEqArray rb rh patArr
1582 then return Stop
1583 else do
1584 acc' <- if withSep
1585 then return acc
1586 else RB.unsafeFoldRingFullM rh fstep acc rb
1587 done acc' >>= \r -> return $ Yield r GO_DONE
1589 go2 !_ !cksum' !rh' s !acc' = do
1590 if RB.unsafeEqArray rb rh' patArr
1591 then do
1592 r <- done acc'
1593 return $ Yield r (GO_KARP_RABIN s rb rhead)
1594 else go1 SPEC cksum' rh' s acc'
1596 stepOuter gst (GO_EMPTY_PAT st) = do
1597 res <- step (adaptState gst) st
1598 case res of
1599 Yield x s -> do
1600 acc <- initial
1601 acc' <- fstep acc x
1602 done acc' >>= \r -> return $ Yield r (GO_EMPTY_PAT s)
1603 Skip s -> return $ Skip (GO_EMPTY_PAT s)
1604 Stop -> return Stop
1606 stepOuter _ GO_DONE = return Stop
1608------------------------------------------------------------------------------
1609-- Substreams
1610------------------------------------------------------------------------------
1612{-# INLINE_NORMAL isPrefixOf #-}
1613isPrefixOf :: (Eq a, Monad m) => Stream m a -> Stream m a -> m Bool
1614isPrefixOf (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)
1615 where
1616 go (sa, sb, Nothing) = do
1617 r <- stepa defState sa
1618 case r of
1619 Yield x sa' -> go (sa', sb, Just x)
1620 Skip sa' -> go (sa', sb, Nothing)
1621 Stop -> return True
1623 go (sa, sb, Just x) = do
1624 r <- stepb defState sb
1625 case r of
1626 Yield y sb' ->
1627 if x == y
1628 then go (sa, sb', Nothing)
1629 else return False
1630 Skip sb' -> go (sa, sb', Just x)
1631 Stop -> return False
1633{-# INLINE_NORMAL isSubsequenceOf #-}
1634isSubsequenceOf :: (Eq a, Monad m) => Stream m a -> Stream m a -> m Bool
1635isSubsequenceOf (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)
1636 where
1637 go (sa, sb, Nothing) = do
1638 r <- stepa defState sa
1639 case r of
1640 Yield x sa' -> go (sa', sb, Just x)
1641 Skip sa' -> go (sa', sb, Nothing)
1642 Stop -> return True
1644 go (sa, sb, Just x) = do
1645 r <- stepb defState sb
1646 case r of
1647 Yield y sb' ->
1648 if x == y
1649 then go (sa, sb', Nothing)
1650 else go (sa, sb', Just x)
1651 Skip sb' -> go (sa, sb', Just x)
1652 Stop -> return False
1654{-# INLINE_NORMAL stripPrefix #-}
1655stripPrefix
1656 :: (Eq a, Monad m)
1657 => Stream m a -> Stream m a -> m (Maybe (Stream m a))
1658stripPrefix (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)
1659 where
1660 go (sa, sb, Nothing) = do
1661 r <- stepa defState sa
1662 case r of
1663 Yield x sa' -> go (sa', sb, Just x)
1664 Skip sa' -> go (sa', sb, Nothing)
1665 Stop -> return $ Just (Stream stepb sb)
1667 go (sa, sb, Just x) = do
1668 r <- stepb defState sb
1669 case r of
1670 Yield y sb' ->
1671 if x == y
1672 then go (sa, sb', Nothing)
1673 else return Nothing
1674 Skip sb' -> go (sa, sb', Just x)
1675 Stop -> return Nothing
1677------------------------------------------------------------------------------
1678-- Map and Fold
1679------------------------------------------------------------------------------
1681-- | Execute a monadic action for each element of the 'Stream'
1682{-# INLINE_NORMAL mapM_ #-}
1683mapM_ :: Monad m => (a -> m b) -> Stream m a -> m ()
1684mapM_ m = drain . mapM m
1686------------------------------------------------------------------------------
1687-- Exceptions
1688------------------------------------------------------------------------------
1690-- | Run a side effect before the stream yields its first element.
1691{-# INLINE_NORMAL before #-}
1692before :: Monad m => m b -> Stream m a -> Stream m a
1693before action (Stream step state) = Stream step' Nothing
1695 where
1697 {-# INLINE_LATE step' #-}
1698 step' _ Nothing = action >> return (Skip (Just state))
1700 step' gst (Just st) = do
1701 res <- step gst st
1702 case res of
1703 Yield x s -> return $ Yield x (Just s)
1704 Skip s -> return $ Skip (Just s)
1705 Stop -> return Stop
1707-- | Run a side effect whenever the stream stops normally.
1708{-# INLINE_NORMAL after #-}
1709after :: Monad m => m b -> Stream m a -> Stream m a
1710after action (Stream step state) = Stream step' state
1712 where
1714 {-# INLINE_LATE step' #-}
1715 step' gst st = do
1716 res <- step gst st
1717 case res of
1718 Yield x s -> return $ Yield x s
1719 Skip s -> return $ Skip s
1720 Stop -> action >> return Stop
1722-- XXX These combinators are expensive due to the call to
1723-- onException/handle/try on each step. Therefore, when possible, they should
1724-- be called in an outer loop where we perform less iterations. For example, we
1725-- cannot call them on each iteration in a char stream, instead we can call
1726-- them when doing an IO on an array.
1728-- XXX For high performance error checks in busy streams we may need another
1729-- Error constructor in step.
1731-- | Run a side effect whenever the stream aborts due to an exception. The
1732-- exception is not caught simply rethrown.
1733{-# INLINE_NORMAL onException #-}
1734onException :: MonadCatch m => m b -> Stream m a -> Stream m a
1735onException action (Stream step state) = Stream step' state
1737 where
1739 {-# INLINE_LATE step' #-}
1740 step' gst st = do
1741 res <- step gst st `MC.onException` action
1742 case res of
1743 Yield x s -> return $ Yield x s
1744 Skip s -> return $ Skip s
1745 Stop -> return Stop
1747-- | Run a side effect whenever the stream stops normally or aborts due to an
1748-- exception.
1749{-# INLINE finally #-}
1750finally :: MonadCatch m => m b -> Stream m a -> Stream m a
1751finally action xs = after action $ onException action xs
1753-- XXX bracket is like concatMap, it generates a stream and then flattens it.
1754-- Like concatMap it has 10x worse performance compared to linear fused
1755-- compositions.
1757-- | Run the first action before the stream starts and remember its output,
1758-- generate a stream using the output, run the second action using the
1759-- remembered value as an argument whenever the stream ends normally or due to
1760-- an exception.
1761{-# INLINE_NORMAL bracket #-}
1762bracket :: MonadCatch m => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a
1763bracket bef aft bet = Stream step' Nothing
1765 where
1767 {-# INLINE_LATE step' #-}
1768 step' _ Nothing = bef >>= \x -> return (Skip (Just (bet x, x)))
1770 -- NOTE: It is important to use UnStream instead of the Stream pattern
1771 -- here, otherwise we get huge perf degradation, see note in concatMap.
1772 step' gst (Just (UnStream step state, v)) = do
1773 res <- step gst state `MC.onException` aft v
1774 case res of
1775 Yield x s -> return $ Yield x (Just (Stream step s, v))
1776 Skip s -> return $ Skip (Just (Stream step s, v))
1777 Stop -> aft v >> return Stop
1779-- | When evaluating a stream if an exception occurs, stream evaluation aborts
1780-- and the specified exception handler is run with the exception as argument.
1781{-# INLINE_NORMAL handle #-}
1782handle :: (MonadCatch m, Exception e) => (e -> m a) -> Stream m a -> Stream m a
1783handle f (Stream step state) = Stream step' (Just state)
1785 where
1787 {-# INLINE_LATE step' #-}
1788 step' gst (Just st) = do
1789 res <- MC.try $ step gst st
1790 case res of
1791 Left e -> f e >>= \x -> return (Yield x Nothing)
1792 Right r -> case r of
1793 Yield x s -> return $ Yield x (Just s)
1794 Skip s -> return $ Skip (Just s)
1795 Stop -> return Stop
1797 step' _ Nothing = return Stop
1799-------------------------------------------------------------------------------
1800-- General transformation
1801-------------------------------------------------------------------------------
1803{-# INLINE_NORMAL transform #-}
1804transform :: Monad m => Pipe m a b -> Stream m a -> Stream m b
1805transform (Pipe pstep1 pstep2 pstate) (Stream step state) =
1806 Stream step' (Consume pstate, state)
1808 where
1810 {-# INLINE_LATE step' #-}
1812 step' gst (Consume pst, st) = pst `seq` do
1813 r <- step (adaptState gst) st
1814 case r of
1815 Yield x s -> do
1816 res <- pstep1 pst x
1817 case res of
1818 Pipe.Yield b pst' -> return $ Yield b (pst', s)
1819 Pipe.Continue pst' -> return $ Skip (pst', s)
1820 Skip s -> return $ Skip (Consume pst, s)
1821 Stop -> return Stop
1823 step' _ (Produce pst, st) = pst `seq` do
1824 res <- pstep2 pst
1825 case res of
1826 Pipe.Yield b pst' -> return $ Yield b (pst', st)
1827 Pipe.Continue pst' -> return $ Skip (pst', st)
1829------------------------------------------------------------------------------
1830-- Transformation by Folding (Scans)
1831------------------------------------------------------------------------------
1833------------------------------------------------------------------------------
1834-- Prescans
1835------------------------------------------------------------------------------
1837-- XXX Is a prescan useful, discarding the last step does not sound useful? I
1838-- am not sure about the utility of this function, so this is implemented but
1839-- not exposed. We can expose it if someone provides good reasons why this is
1840-- useful.
1842-- XXX We have to execute the stream one step ahead to know that we are at the
1843-- last step. The vector implementation of prescan executes the last fold step
1844-- but does not yield the result. This means we have executed the effect but
1845-- discarded value. This does not sound right. In this implementation we are
1846-- not executing the last fold step.
1847{-# INLINE_NORMAL prescanlM' #-}
1848prescanlM' :: Monad m => (b -> a -> m b) -> m b -> Stream m a -> Stream m b
1849prescanlM' f mz (Stream step state) = Stream step' (state, mz)
1850 where
1851 {-# INLINE_LATE step' #-}
1852 step' gst (st, prev) = do
1853 r <- step (adaptState gst) st
1854 case r of
1855 Yield x s -> do
1856 acc <- prev
1857 return $ Yield acc (s, f acc x)
1858 Skip s -> return $ Skip (s, prev)
1859 Stop -> return Stop
1861{-# INLINE prescanl' #-}
1862prescanl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b
1863prescanl' f z = prescanlM' (\a b -> return (f a b)) (return z)
1865------------------------------------------------------------------------------
1866-- Monolithic postscans (postscan followed by a map)
1867------------------------------------------------------------------------------
1869-- The performance of a modular postscan followed by a map seems to be
1870-- equivalent to this monolithic scan followed by map therefore we may not need
1871-- this implementation. We just have it for performance comparison and in case
1872-- modular version does not perform well in some situation.
1874{-# INLINE_NORMAL postscanlMx' #-}
1875postscanlMx' :: Monad m
1876 => (x -> a -> m x) -> m x -> (x -> m b) -> Stream m a -> Stream m b
1877postscanlMx' fstep begin done (Stream step state) = do
1878 Stream step' (state, begin)
1879 where
1880 {-# INLINE_LATE step' #-}
1881 step' gst (st, acc) = do
1882 r <- step (adaptState gst) st
1883 case r of
1884 Yield x s -> do
1885 old <- acc
1886 y <- fstep old x
1887 v <- done y
1888 v `seq` y `seq` return (Yield v (s, return y))
1889 Skip s -> return $ Skip (s, acc)
1890 Stop -> return Stop
1892{-# INLINE_NORMAL postscanlx' #-}
1893postscanlx' :: Monad m
1894 => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> Stream m b
1895postscanlx' fstep begin done s =
1896 postscanlMx' (\b a -> return (fstep b a)) (return begin) (return . done) s
1898-- XXX do we need consM strict to evaluate the begin value?
1899{-# INLINE scanlMx' #-}
1900scanlMx' :: Monad m
1901 => (x -> a -> m x) -> m x -> (x -> m b) -> Stream m a -> Stream m b
1902scanlMx' fstep begin done s =
1903 (begin >>= \x -> x `seq` done x) `consM` postscanlMx' fstep begin done s
1905{-# INLINE scanlx' #-}
1906scanlx' :: Monad m
1907 => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> Stream m b
1908scanlx' fstep begin done s =
1909 scanlMx' (\b a -> return (fstep b a)) (return begin) (return . done) s
1911------------------------------------------------------------------------------
1912-- postscans
1913------------------------------------------------------------------------------
1915{-# INLINE_NORMAL postscanlM' #-}
1916postscanlM' :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
1917postscanlM' fstep begin (Stream step state) =
1918 begin `seq` Stream step' (state, begin)
1919 where
1920 {-# INLINE_LATE step' #-}
1921 step' gst (st, acc) = acc `seq` do
1922 r <- step (adaptState gst) st
1923 case r of
1924 Yield x s -> do
1925 y <- fstep acc x
1926 y `seq` return (Yield y (s, y))
1927 Skip s -> return $ Skip (s, acc)
1928 Stop -> return Stop
1930{-# INLINE_NORMAL postscanl' #-}
1931postscanl' :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a
1932postscanl' f = postscanlM' (\a b -> return (f a b))
1934{-# INLINE_NORMAL postscanlM #-}
1935postscanlM :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
1936postscanlM fstep begin (Stream step state) = Stream step' (state, begin)
1937 where
1938 {-# INLINE_LATE step' #-}
1939 step' gst (st, acc) = do
1940 r <- step (adaptState gst) st
1941 case r of
1942 Yield x s -> do
1943 y <- fstep acc x
1944 return (Yield y (s, y))
1945 Skip s -> return $ Skip (s, acc)
1946 Stop -> return Stop
1948{-# INLINE_NORMAL postscanl #-}
1949postscanl :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a
1950postscanl f = postscanlM (\a b -> return (f a b))
1952{-# INLINE_NORMAL scanlM' #-}
1953scanlM' :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
1954scanlM' fstep begin s = begin `seq` (begin `cons` postscanlM' fstep begin s)
1956{-# INLINE scanl' #-}
1957scanl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b
1958scanl' f = scanlM' (\a b -> return (f a b))
1960{-# INLINE_NORMAL scanlM #-}
1961scanlM :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
1962scanlM fstep begin s = begin `cons` postscanlM fstep begin s
1964{-# INLINE scanl #-}
1965scanl :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b
1966scanl f = scanlM (\a b -> return (f a b))
1968{-# INLINE_NORMAL scanl1M #-}
1969scanl1M :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a
1970scanl1M fstep (Stream step state) = Stream step' (state, Nothing)
1971 where
1972 {-# INLINE_LATE step' #-}
1973 step' gst (st, Nothing) = do
1974 r <- step gst st
1975 case r of
1976 Yield x s -> return $ Yield x (s, Just x)
1977 Skip s -> return $ Skip (s, Nothing)
1978 Stop -> return Stop
1980 step' gst (st, Just acc) = do
1981 r <- step gst st
1982 case r of
1983 Yield y s -> do
1984 z <- fstep acc y
1985 return $ Yield z (s, Just z)
1986 Skip s -> return $ Skip (s, Just acc)
1987 Stop -> return Stop
1989{-# INLINE scanl1 #-}
1990scanl1 :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a
1991scanl1 f = scanl1M (\x y -> return (f x y))
1993{-# INLINE_NORMAL scanl1M' #-}
1994scanl1M' :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a
1995scanl1M' fstep (Stream step state) = Stream step' (state, Nothing)
1996 where
1997 {-# INLINE_LATE step' #-}
1998 step' gst (st, Nothing) = do
1999 r <- step gst st
2000 case r of
2001 Yield x s -> x `seq` return $ Yield x (s, Just x)
2002 Skip s -> return $ Skip (s, Nothing)
2003 Stop -> return Stop
2005 step' gst (st, Just acc) = acc `seq` do
2006 r <- step gst st
2007 case r of
2008 Yield y s -> do
2009 z <- fstep acc y
2010 z `seq` return $ Yield z (s, Just z)
2011 Skip s -> return $ Skip (s, Just acc)
2012 Stop -> return Stop
2014{-# INLINE scanl1' #-}
2015scanl1' :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a
2016scanl1' f = scanl1M' (\x y -> return (f x y))
2018{-# INLINE tap #-}
2019tap :: Monad m => Sink m a -> Stream m a -> Stream m a
2020tap (Sink fstep) (Stream step state) = Stream step' state
2022 where
2024 step' gst st = do
2025 r <- step gst st
2026 case r of
2027 Yield x s -> do
2028 fstep x
2029 return $ Yield x s
2030 Skip s -> return $ Skip s
2031 Stop -> return $ Stop
2033-------------------------------------------------------------------------------
2034-- Filtering
2035-------------------------------------------------------------------------------
2037{-# INLINE_NORMAL takeWhileM #-}
2038takeWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a
2039takeWhileM f (Stream step state) = Stream step' state
2040 where
2041 {-# INLINE_LATE step' #-}
2042 step' gst st = do
2043 r <- step gst st
2044 case r of
2045 Yield x s -> do
2046 b <- f x
2047 return $ if b then Yield x s else Stop
2048 Skip s -> return $ Skip s
2049 Stop -> return Stop
2051{-# INLINE takeWhile #-}
2052takeWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
2053takeWhile f = takeWhileM (return . f)
2055{-# INLINE_NORMAL drop #-}
2056drop :: Monad m => Int -> Stream m a -> Stream m a
2057drop n (Stream step state) = Stream step' (state, Just n)
2058 where
2059 {-# INLINE_LATE step' #-}
2060 step' gst (st, Just i)
2061 | i > 0 = do
2062 r <- step gst st
2063 return $
2064 case r of
2065 Yield _ s -> Skip (s, Just (i - 1))
2066 Skip s -> Skip (s, Just i)
2067 Stop -> Stop
2068 | otherwise = return $ Skip (st, Nothing)
2070 step' gst (st, Nothing) = do
2071 r <- step gst st
2072 return $
2073 case r of
2074 Yield x s -> Yield x (s, Nothing)
2075 Skip s -> Skip (s, Nothing)
2076 Stop -> Stop
2078data DropWhileState s a
2079 = DropWhileDrop s
2080 | DropWhileYield a s
2081 | DropWhileNext s
2083{-# INLINE_NORMAL dropWhileM #-}
2084dropWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a
2085dropWhileM f (Stream step state) = Stream step' (DropWhileDrop state)
2086 where
2087 {-# INLINE_LATE step' #-}
2088 step' gst (DropWhileDrop st) = do
2089 r <- step gst st
2090 case r of
2091 Yield x s -> do
2092 b <- f x
2093 if b
2094 then return $ Skip (DropWhileDrop s)
2095 else return $ Skip (DropWhileYield x s)
2096 Skip s -> return $ Skip (DropWhileDrop s)
2097 Stop -> return Stop
2099 step' gst (DropWhileNext st) = do
2100 r <- step gst st
2101 case r of
2102 Yield x s -> return $ Skip (DropWhileYield x s)
2103 Skip s -> return $ Skip (DropWhileNext s)
2104 Stop -> return Stop
2106 step' _ (DropWhileYield x st) = return $ Yield x (DropWhileNext st)
2108{-# INLINE dropWhile #-}
2109dropWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
2110dropWhile f = dropWhileM (return . f)
2112{-# INLINE_NORMAL filterM #-}
2113filterM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a
2114filterM f (Stream step state) = Stream step' state
2115 where
2116 {-# INLINE_LATE step' #-}
2117 step' gst st = do
2118 r <- step gst st
2119 case r of
2120 Yield x s -> do
2121 b <- f x
2122 return $ if b
2123 then Yield x s
2124 else Skip s
2125 Skip s -> return $ Skip s
2126 Stop -> return Stop
2128{-# INLINE filter #-}
2129filter :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
2130filter f = filterM (return . f)
2132{-# INLINE_NORMAL uniq #-}
2133uniq :: (Eq a, Monad m) => Stream m a -> Stream m a
2134uniq (Stream step state) = Stream step' (Nothing, state)
2135 where
2136 {-# INLINE_LATE step' #-}
2137 step' gst (Nothing, st) = do
2138 r <- step gst st
2139 case r of
2140 Yield x s -> return $ Yield x (Just x, s)
2141 Skip s -> return $ Skip (Nothing, s)
2142 Stop -> return Stop
2143 step' gst (Just x, st) = do
2144 r <- step gst st
2145 case r of
2146 Yield y s | x == y -> return $ Skip (Just x, s)
2147 | otherwise -> return $ Yield y (Just y, s)
2148 Skip s -> return $ Skip (Just x, s)
2149 Stop -> return Stop
2151------------------------------------------------------------------------------
2152-- Transformation by Mapping
2153------------------------------------------------------------------------------
2155{-# INLINE_NORMAL sequence #-}
2156sequence :: Monad m => Stream m (m a) -> Stream m a
2157sequence (Stream step state) = Stream step' state
2158 where
2159 {-# INLINE_LATE step' #-}
2160 step' gst st = do
2161 r <- step (adaptState gst) st
2162 case r of
2163 Yield x s -> x >>= \a -> return (Yield a s)
2164 Skip s -> return $ Skip s
2165 Stop -> return Stop
2167------------------------------------------------------------------------------
2168-- Inserting
2169------------------------------------------------------------------------------
2171data LoopState x s = FirstYield s
2172 | InterspersingYield s
2173 | YieldAndCarry x s
2175{-# INLINE_NORMAL intersperseM #-}
2176intersperseM :: Monad m => m a -> Stream m a -> Stream m a
2177intersperseM m (Stream step state) = Stream step' (FirstYield state)
2178 where
2179 {-# INLINE_LATE step' #-}
2180 step' gst (FirstYield st) = do
2181 r <- step gst st
2182 return $
2183 case r of
2184 Yield x s -> Skip (YieldAndCarry x s)
2185 Skip s -> Skip (FirstYield s)
2186 Stop -> Stop
2188 step' gst (InterspersingYield st) = do
2189 r <- step gst st
2190 case r of
2191 Yield x s -> do
2192 a <- m
2193 return $ Yield a (YieldAndCarry x s)
2194 Skip s -> return $ Skip $ InterspersingYield s
2195 Stop -> return Stop
2197 step' _ (YieldAndCarry x st) = return $ Yield x (InterspersingYield st)
2199data SuffixState s a
2200 = SuffixElem s
2201 | SuffixSuffix s
2202 | SuffixYield a (SuffixState s a)
2204{-# INLINE_NORMAL insertAfterEach #-}
2205insertAfterEach :: forall m a. Monad m => m a -> Stream m a -> Stream m a
2206insertAfterEach action (Stream step state) = Stream step' (SuffixElem state)
2207 where
2208 {-# INLINE_LATE step' #-}
2209 step' gst (SuffixElem st) = do
2210 r <- step gst st
2211 return $ case r of
2212 Yield x s -> Skip (SuffixYield x (SuffixSuffix s))
2213 Skip s -> Skip (SuffixElem s)
2214 Stop -> Stop
2216 step' _ (SuffixSuffix st) = do
2217 action >>= \r -> return $ Skip (SuffixYield r (SuffixElem st))
2219 step' _ (SuffixYield x next) = return $ Yield x next
2221{-# INLINE intersperse #-}
2222intersperse :: Monad m => a -> Stream m a -> Stream m a
2223intersperse a = intersperseM (return a)
2225{-# INLINE_NORMAL insertBy #-}
2226insertBy :: Monad m => (a -> a -> Ordering) -> a -> Stream m a -> Stream m a
2227insertBy cmp a (Stream step state) = Stream step' (state, False, Nothing)
2228 where
2229 {-# INLINE_LATE step' #-}
2230 step' gst (st, False, _) = do
2231 r <- step gst st
2232 case r of
2233 Yield x s -> case cmp a x of
2234 GT -> return $ Yield x (s, False, Nothing)
2235 _ -> return $ Yield a (s, True, Just x)
2236 Skip s -> return $ Skip (s, False, Nothing)
2237 Stop -> return $ Yield a (st, True, Nothing)
2239 step' _ (_, True, Nothing) = return Stop
2241 step' gst (st, True, Just prev) = do
2242 r <- step gst st
2243 case r of
2244 Yield x s -> return $ Yield prev (s, True, Just x)
2245 Skip s -> return $ Skip (s, True, Just prev)
2246 Stop -> return $ Yield prev (st, True, Nothing)
2248------------------------------------------------------------------------------
2249-- Deleting
2250------------------------------------------------------------------------------
2252{-# INLINE_NORMAL deleteBy #-}
2253deleteBy :: Monad m => (a -> a -> Bool) -> a -> Stream m a -> Stream m a
2254deleteBy eq x (Stream step state) = Stream step' (state, False)
2255 where
2256 {-# INLINE_LATE step' #-}
2257 step' gst (st, False) = do
2258 r <- step gst st
2259 case r of
2260 Yield y s -> return $
2261 if eq x y then Skip (s, True) else Yield y (s, False)
2262 Skip s -> return $ Skip (s, False)
2263 Stop -> return Stop
2265 step' gst (st, True) = do
2266 r <- step gst st
2267 case r of
2268 Yield y s -> return $ Yield y (s, True)
2269 Skip s -> return $ Skip (s, True)
2270 Stop -> return Stop
2272------------------------------------------------------------------------------
2273-- Transformation by Map and Filter
2274------------------------------------------------------------------------------
2276-- XXX Will this always fuse properly?
2277{-# INLINE_NORMAL mapMaybe #-}
2278mapMaybe :: Monad m => (a -> Maybe b) -> Stream m a -> Stream m b
2279mapMaybe f = fmap fromJust . filter isJust . map f
2281{-# INLINE_NORMAL mapMaybeM #-}
2282mapMaybeM :: Monad m => (a -> m (Maybe b)) -> Stream m a -> Stream m b
2283mapMaybeM f = fmap fromJust . filter isJust . mapM f
2285------------------------------------------------------------------------------
2286-- Zipping
2287------------------------------------------------------------------------------
2289{-# INLINE_NORMAL indexed #-}
2290indexed :: Monad m => Stream m a -> Stream m (Int, a)
2291indexed (Stream step state) = Stream step' (state, 0)
2292 where
2293 {-# INLINE_LATE step' #-}
2294 step' gst (st, i) = i `seq` do
2295 r <- step (adaptState gst) st
2296 case r of
2297 Yield x s -> return $ Yield (i, x) (s, i+1)
2298 Skip s -> return $ Skip (s, i)
2299 Stop -> return Stop
2301{-# INLINE_NORMAL indexedR #-}
2302indexedR :: Monad m => Int -> Stream m a -> Stream m (Int, a)
2303indexedR m (Stream step state) = Stream step' (state, m)
2304 where
2305 {-# INLINE_LATE step' #-}
2306 step' gst (st, i) = i `seq` do
2307 r <- step (adaptState gst) st
2308 case r of
2309 Yield x s -> let i' = i - 1
2310 in return $ Yield (i, x) (s, i')
2311 Skip s -> return $ Skip (s, i)
2312 Stop -> return Stop
2314{-# INLINE_NORMAL zipWithM #-}
2315zipWithM :: Monad m
2316 => (a -> b -> m c) -> Stream m a -> Stream m b -> Stream m c
2317zipWithM f (Stream stepa ta) (Stream stepb tb) = Stream step (ta, tb, Nothing)
2318 where
2319 {-# INLINE_LATE step #-}
2320 step gst (sa, sb, Nothing) = do
2321 r <- stepa (adaptState gst) sa
2322 return $
2323 case r of
2324 Yield x sa' -> Skip (sa', sb, Just x)
2325 Skip sa' -> Skip (sa', sb, Nothing)
2326 Stop -> Stop
2328 step gst (sa, sb, Just x) = do
2329 r <- stepb (adaptState gst) sb
2330 case r of
2331 Yield y sb' -> do
2332 z <- f x y
2333 return $ Yield z (sa, sb', Nothing)
2334 Skip sb' -> return $ Skip (sa, sb', Just x)
2335 Stop -> return Stop
2337{-# RULES "zipWithM xs xs"
2338 forall f xs. zipWithM f xs xs = mapM (\x -> f x x) xs #-}
2340{-# INLINE zipWith #-}
2341zipWith :: Monad m => (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c
2342zipWith f = zipWithM (\a b -> return (f a b))
2344------------------------------------------------------------------------------
2345-- Merging
2346------------------------------------------------------------------------------
2348{-# INLINE_NORMAL mergeByM #-}
2349mergeByM
2350 :: (Monad m)
2351 => (a -> a -> m Ordering) -> Stream m a -> Stream m a -> Stream m a
2352mergeByM cmp (Stream stepa ta) (Stream stepb tb) =
2353 Stream step (Just ta, Just tb, Nothing, Nothing)
2354 where
2355 {-# INLINE_LATE step #-}
2357 -- one of the values is missing, and the corresponding stream is running
2358 step gst (Just sa, sb, Nothing, b) = do
2359 r <- stepa gst sa
2360 return $ case r of
2361 Yield a sa' -> Skip (Just sa', sb, Just a, b)
2362 Skip sa' -> Skip (Just sa', sb, Nothing, b)
2363 Stop -> Skip (Nothing, sb, Nothing, b)
2365 step gst (sa, Just sb, a, Nothing) = do
2366 r <- stepb gst sb
2367 return $ case r of
2368 Yield b sb' -> Skip (sa, Just sb', a, Just b)
2369 Skip sb' -> Skip (sa, Just sb', a, Nothing)
2370 Stop -> Skip (sa, Nothing, a, Nothing)
2372 -- both the values are available
2373 step _ (sa, sb, Just a, Just b) = do
2374 res <- cmp a b
2375 return $ case res of
2376 GT -> Yield b (sa, sb, Just a, Nothing)
2377 _ -> Yield a (sa, sb, Nothing, Just b)
2379 -- one of the values is missing, corresponding stream is done
2380 step _ (Nothing, sb, Nothing, Just b) =
2381 return $ Yield b (Nothing, sb, Nothing, Nothing)
2383 step _ (sa, Nothing, Just a, Nothing) =
2384 return $ Yield a (sa, Nothing, Nothing, Nothing)
2386 step _ (Nothing, Nothing, Nothing, Nothing) = return Stop
2388{-# INLINE mergeBy #-}
2389mergeBy
2390 :: (Monad m)
2391 => (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a
2392mergeBy cmp = mergeByM (\a b -> return $ cmp a b)
2394------------------------------------------------------------------------------
2395-- Transformation comprehensions
2396------------------------------------------------------------------------------
2398{-# INLINE_NORMAL the #-}
2399the :: (Eq a, Monad m) => Stream m a -> m (Maybe a)
2400the (Stream step state) = go state
2401 where
2402 go st = do
2403 r <- step defState st
2404 case r of
2405 Yield x s -> go' x s
2406 Skip s -> go s
2407 Stop -> return Nothing
2408 go' n st = do
2409 r <- step defState st
2410 case r of
2411 Yield x s | x == n -> go' n s
2412 | otherwise -> return Nothing
2413 Skip s -> go' n s
2414 Stop -> return (Just n)
2416--------------------------------------------------------------------------------
2417-- UTF8 Encoding / Decoding
2418--------------------------------------------------------------------------------
2420-- UTF-8 primitives, Lifted from GHC.IO.Encoding.UTF8.
2422ord2 :: Char -> [Word8]
2423ord2 c = assert (n >= 0x80 && n <= 0x07ff) [x1, x2]
2424 where
2425 n = ord c
2426 x1 = fromIntegral $ (n `shiftR` 6) + 0xC0
2427 x2 = fromIntegral $ (n .&. 0x3F) + 0x80
2429ord3 :: Char -> [Word8]
2430ord3 c = assert (n >= 0x0800 && n <= 0xffff) [x1, x2, x3]
2431 where
2432 n = ord c
2433 x1 = fromIntegral $ (n `shiftR` 12) + 0xE0
2434 x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
2435 x3 = fromIntegral $ (n .&. 0x3F) + 0x80
2437ord4 :: Char -> [Word8]
2438ord4 c = assert (n >= 0x10000) [x1, x2, x3, x4]
2439 where
2440 n = ord c
2441 x1 = fromIntegral $ (n `shiftR` 18) + 0xF0
2442 x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80
2443 x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
2444 x4 = fromIntegral $ (n .&. 0x3F) + 0x80
2446{-# INLINE chr2 #-}
2447chr2 :: Word8 -> Word8 -> Char
2448chr2 (W8# x1#) (W8# x2#) = C# (chr# (z1# +# z2#))
2449 where
2450 !y1# = word2Int# x1#
2451 !y2# = word2Int# x2#
2452 !z1# = uncheckedIShiftL# (y1# -# 192#) 6#
2453 !z2# = y2# -# 128#
2455{-# INLINE chr3 #-}
2456chr3 :: Word8 -> Word8 -> Word8 -> Char
2457chr3 (W8# x1#) (W8# x2#) (W8# x3#) = C# (chr# (z1# +# z2# +# z3#))
2458 where
2459 !y1# = word2Int# x1#
2460 !y2# = word2Int# x2#
2461 !y3# = word2Int# x3#
2462 !z1# = uncheckedIShiftL# (y1# -# 224#) 12#
2463 !z2# = uncheckedIShiftL# (y2# -# 128#) 6#
2464 !z3# = y3# -# 128#
2466{-# INLINE chr4 #-}
2467chr4 :: Word8 -> Word8 -> Word8 -> Word8 -> Char
2468chr4 (W8# x1#) (W8# x2#) (W8# x3#) (W8# x4#) =
2469 C# (chr# (z1# +# z2# +# z3# +# z4#))
2470 where
2471 !y1# = word2Int# x1#
2472 !y2# = word2Int# x2#
2473 !y3# = word2Int# x3#
2474 !y4# = word2Int# x4#
2475 !z1# = uncheckedIShiftL# (y1# -# 240#) 18#
2476 !z2# = uncheckedIShiftL# (y2# -# 128#) 12#
2477 !z3# = uncheckedIShiftL# (y3# -# 128#) 6#
2478 !z4# = y4# -# 128#
2480{-# INLINE between #-}
2481between ::
2482 Word8 -- ^ byte to check
2483 -> Word8 -- ^ lower bound
2484 -> Word8 -- ^ upper bound
2485 -> Bool
2486between x y z = x >= y && x <= z
2488{-# INLINE validate3 #-}
2489validate3 :: Word8 -> Word8 -> Word8 -> Bool
2490validate3 x1 x2 x3 = validate3_1 ||
2491 validate3_2 ||
2492 validate3_3 ||
2493 validate3_4
2494 where
2495 validate3_1 = (x1 == 0xE0) &&
2496 between x2 0xA0 0xBF &&
2497 between x3 0x80 0xBF
2498 validate3_2 = between x1 0xE1 0xEC &&
2499 between x2 0x80 0xBF &&
2500 between x3 0x80 0xBF
2501 validate3_3 = x1 == 0xED &&
2502 between x2 0x80 0x9F &&
2503 between x3 0x80 0xBF
2504 validate3_4 = between x1 0xEE 0xEF &&
2505 between x2 0x80 0xBF &&
2506 between x3 0x80 0xBF
2508{-# INLINE validate4 #-}
2509validate4 :: Word8 -> Word8 -> Word8 -> Word8 -> Bool
2510validate4 x1 x2 x3 x4 = validate4_1 ||
2511 validate4_2 ||
2512 validate4_3
2513 where
2514 validate4_1 = x1 == 0xF0 &&
2515 between x2 0x90 0xBF &&
2516 between x3 0x80 0xBF &&
2517 between x4 0x80 0xBF
2518 validate4_2 = between x1 0xF1 0xF3 &&
2519 between x2 0x80 0xBF &&
2520 between x3 0x80 0xBF &&
2521 between x4 0x80 0xBF
2522 validate4_3 = x1 == 0xF4 &&
2523 between x2 0x80 0x8F &&
2524 between x3 0x80 0xBF &&
2525 between x4 0x80 0xBF
2527data CodePoint = FreshPoint
2528 | Two !Word8
2529 | GoThree !Word8
2530 | Three !Word8 !Word8
2531 | GoFour !Word8
2532 | Four1 !Word8 !Word8
2533 | Four !Word8 !Word8 !Word8
2534 | YieldPoint !Char
2536{-# INLINE_NORMAL decodeUtf8 #-}
2537decodeUtf8 :: Monad m => Stream m Word8 -> Stream m Char
2538decodeUtf8 (Stream step state) = Stream step' (state, FreshPoint)
2539 where
2540 {-# INLINE_LATE step' #-}
2541 step' gst (st, FreshPoint) = do
2542 r <- step (adaptState gst) st
2543 return $
2544 case r of
2545 Yield c0 s
2546 | c0 <= 0x7f ->
2547 Skip (s, YieldPoint $ unsafeChr (fromIntegral c0))
2548 | c0 >= 0xc0 && c0 <= 0xc1 -> error "Invalid Overlong forms"
2549 | c0 >= 0xc2 && c0 <= 0xdf -> Skip (s, Two c0)
2550 | c0 >= 0xe0 && c0 <= 0xef -> Skip (s, GoThree c0)
2551 | c0 >= 0xf0 -> Skip (s, GoFour c0)
2552 | otherwise -> error "Invalid Sequence"
2553 Skip s -> Skip (s, FreshPoint)
2554 Stop -> Stop
2556 -- Decoding of a UTF8 character that spans two bytes with one byte (c0)
2557 -- known.
2558 step' gst (st, Two c0) = do
2559 r <- step (adaptState gst) st
2560 return $
2561 case r of
2562 Yield c1 s
2563 | c1 < 0x80 || c1 >= 0xc0 -> error "Invalid Sequence"
2564 | otherwise -> Skip (s, YieldPoint $ chr2 c0 c1)
2565 Skip s -> Skip (s, Two c0)
2566 Stop -> error "Input Underflow"
2568 -- Decoding of a UTF8 character that spans three bytes with first byte (c0)
2569 -- known.
2570 step' gst (st, GoThree c0) = do
2571 r <- step (adaptState gst) st
2572 return $
2573 case r of
2574 Yield c1 s
2575 | not (validate3 c0 c1 0x80) -> error "Invalid Sequence"
2576 -- See #3341@ghc
2577 | otherwise -> Skip (s, Three c0 c1)
2578 Skip s -> Skip (s, GoThree c0)
2579 Stop -> error "Input Underflow"
2581 -- Two bytes known of a 3 byte UTF8 encoded unicode character.
2582 step' gst (st, Three c0 c1) = do
2583 r <- step (adaptState gst) st
2584 return $
2585 case r of
2586 Yield c2 s
2587 | not (validate3 c0 c1 c2) -> error "Invalid Sequence"
2588 | otherwise -> Skip (s, YieldPoint $ chr3 c0 c1 c2)
2589 Skip s -> Skip (s, Three c0 c1)
2590 Stop -> error "Input Underflow"
2592 -- One byte known of a four byte UTF8 unicode character.
2593 step' gst (st, GoFour c0) = do
2594 r <- step (adaptState gst) st
2595 return $
2596 case r of
2597 Yield c1 s
2598 | not (validate4 c0 c1 0x80 0x80) -> error "Invalid Sequence"
2599 | otherwise -> Skip (s, Four1 c0 c1)
2600 Skip s -> Skip (s, GoFour c0)
2601 Stop -> error "Input Underflow"
2603 -- Two bytes known of a four byte UTF8 unicode character.
2604 step' gst (st, Four1 c0 c1) = do
2605 r <- step (adaptState gst) st
2606 return $
2607 case r of
2608 Yield c2 s
2609 | not (validate4 c0 c1 c2 0x80) -> error "Invalid Sequence"
2610 | otherwise -> Skip (s, Four c0 c1 c2)
2611 Skip s -> Skip (s, Four1 c0 c1)
2612 Stop -> error "Input Underflow"
2614 -- Three bytes known of a three byte UTF8 unicode character.
2615 step' gst (st, Four c0 c1 c2) = do
2616 r <- step (adaptState gst) st
2617 return $
2618 case r of
2619 Yield c3 s
2620 | not (validate4 c0 c1 c2 c3) -> error "Invalid Sequence"
2621 | otherwise -> Skip (s, YieldPoint $ chr4 c0 c1 c2 c3)
2622 Skip s -> Skip (s, Four c0 c1 c2)
2623 Stop -> error "Input Underflow"
2625 -- This way so that we only need one Yield.
2626 step' _ (s, YieldPoint c) = return $ Yield c (s, FreshPoint)
2628data YieldMany x = None
2629 | YieldMany !x
2631{-# INLINE_NORMAL encodeUtf8 #-}
2632encodeUtf8 :: Monad m => Stream m Char -> Stream m Word8
2633encodeUtf8 (Stream step state) = Stream step' (state, None)
2634 where
2635 {-# INLINE_LATE step' #-}
2636 step' gst (st, None) = do
2637 r <- step (adaptState gst) st
2638 return $
2639 case r of
2640 Yield c s ->
2641 case ord c of
2642 x | x <= 0x7F -> Skip (s, YieldMany [fromIntegral x])
2643 | x <= 0x7FF -> Skip (s, YieldMany (ord2 c))
2644 | x <= 0xFFFF ->
2645 if isSurrogate c
2646 then error "Encountered a surrogate"
2647 else Skip (s, YieldMany (ord3 c))
2648 | otherwise -> Skip (s, YieldMany (ord4 c))
2649 Skip s -> Skip (s, None)
2650 Stop -> Stop
2651 step' _ (s, YieldMany []) = return $ Skip (s, None)
2652 step' _ (s, YieldMany (x:xs)) = return $ Yield x (s, YieldMany xs)