git.iko.soy/streamly
on 364af08 help sign in
streamly/src/Streamly/Streams/StreamD.hs
2661 lines 91 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 m = foldrM (\x xs -> x `seq` xs) (return ()) m
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-- XXX if we make the initial value of the accumulator monadic then should we
1916-- execute it even if the stream is empty? In that case we would have generated
1917-- the effect but discarded the value, but that is what a fold does when the
1918-- stream is empty. Whatever we decide, need to reconcile this with prescan.
1919-- If we execute the initial value here without even using it then it is ok to
1920-- execute the last step there as well without using the value.
1921-- Looking at the duality with right fold, in case of right fold we always
1922-- perform the action when the construction terminates, so in case of left fold
1923-- we should perform it only when the reduction starts.
1924{-# INLINE_NORMAL postscanlM' #-}
1925postscanlM' :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
1926postscanlM' fstep begin (Stream step state) =
1927 begin `seq` Stream step' (state, begin)
1928 where
1929 {-# INLINE_LATE step' #-}
1930 step' gst (st, acc) = acc `seq` do
1931 r <- step (adaptState gst) st
1932 case r of
1933 Yield x s -> do
1934 y <- fstep acc x
1935 y `seq` return (Yield y (s, y))
1936 Skip s -> return $ Skip (s, acc)
1937 Stop -> return Stop
1939{-# INLINE_NORMAL postscanl' #-}
1940postscanl' :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a
1941postscanl' f = postscanlM' (\a b -> return (f a b))
1943{-# INLINE_NORMAL postscanlM #-}
1944postscanlM :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
1945postscanlM fstep begin (Stream step state) = Stream step' (state, begin)
1946 where
1947 {-# INLINE_LATE step' #-}
1948 step' gst (st, acc) = do
1949 r <- step (adaptState gst) st
1950 case r of
1951 Yield x s -> do
1952 y <- fstep acc x
1953 return (Yield y (s, y))
1954 Skip s -> return $ Skip (s, acc)
1955 Stop -> return Stop
1957{-# INLINE_NORMAL postscanl #-}
1958postscanl :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a
1959postscanl f = postscanlM (\a b -> return (f a b))
1961{-# INLINE_NORMAL scanlM' #-}
1962scanlM' :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
1963scanlM' fstep begin s = begin `seq` (begin `cons` postscanlM' fstep begin s)
1965{-# INLINE scanl' #-}
1966scanl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b
1967scanl' f = scanlM' (\a b -> return (f a b))
1969{-# INLINE_NORMAL scanlM #-}
1970scanlM :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
1971scanlM fstep begin s = begin `cons` postscanlM fstep begin s
1973{-# INLINE scanl #-}
1974scanl :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b
1975scanl f = scanlM (\a b -> return (f a b))
1977{-# INLINE_NORMAL scanl1M #-}
1978scanl1M :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a
1979scanl1M fstep (Stream step state) = Stream step' (state, Nothing)
1980 where
1981 {-# INLINE_LATE step' #-}
1982 step' gst (st, Nothing) = do
1983 r <- step gst st
1984 case r of
1985 Yield x s -> return $ Yield x (s, Just x)
1986 Skip s -> return $ Skip (s, Nothing)
1987 Stop -> return Stop
1989 step' gst (st, Just acc) = do
1990 r <- step gst st
1991 case r of
1992 Yield y s -> do
1993 z <- fstep acc y
1994 return $ Yield z (s, Just z)
1995 Skip s -> return $ Skip (s, Just acc)
1996 Stop -> return Stop
1998{-# INLINE scanl1 #-}
1999scanl1 :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a
2000scanl1 f = scanl1M (\x y -> return (f x y))
2002{-# INLINE_NORMAL scanl1M' #-}
2003scanl1M' :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a
2004scanl1M' fstep (Stream step state) = Stream step' (state, Nothing)
2005 where
2006 {-# INLINE_LATE step' #-}
2007 step' gst (st, Nothing) = do
2008 r <- step gst st
2009 case r of
2010 Yield x s -> x `seq` return $ Yield x (s, Just x)
2011 Skip s -> return $ Skip (s, Nothing)
2012 Stop -> return Stop
2014 step' gst (st, Just acc) = acc `seq` do
2015 r <- step gst st
2016 case r of
2017 Yield y s -> do
2018 z <- fstep acc y
2019 z `seq` return $ Yield z (s, Just z)
2020 Skip s -> return $ Skip (s, Just acc)
2021 Stop -> return Stop
2023{-# INLINE scanl1' #-}
2024scanl1' :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a
2025scanl1' f = scanl1M' (\x y -> return (f x y))
2027{-# INLINE tap #-}
2028tap :: Monad m => Sink m a -> Stream m a -> Stream m a
2029tap (Sink fstep) (Stream step state) = Stream step' state
2031 where
2033 step' gst st = do
2034 r <- step gst st
2035 case r of
2036 Yield x s -> do
2037 fstep x
2038 return $ Yield x s
2039 Skip s -> return $ Skip s
2040 Stop -> return $ Stop
2042-------------------------------------------------------------------------------
2043-- Filtering
2044-------------------------------------------------------------------------------
2046{-# INLINE_NORMAL takeWhileM #-}
2047takeWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a
2048takeWhileM f (Stream step state) = Stream step' state
2049 where
2050 {-# INLINE_LATE step' #-}
2051 step' gst st = do
2052 r <- step gst st
2053 case r of
2054 Yield x s -> do
2055 b <- f x
2056 return $ if b then Yield x s else Stop
2057 Skip s -> return $ Skip s
2058 Stop -> return Stop
2060{-# INLINE takeWhile #-}
2061takeWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
2062takeWhile f = takeWhileM (return . f)
2064{-# INLINE_NORMAL drop #-}
2065drop :: Monad m => Int -> Stream m a -> Stream m a
2066drop n (Stream step state) = Stream step' (state, Just n)
2067 where
2068 {-# INLINE_LATE step' #-}
2069 step' gst (st, Just i)
2070 | i > 0 = do
2071 r <- step gst st
2072 return $
2073 case r of
2074 Yield _ s -> Skip (s, Just (i - 1))
2075 Skip s -> Skip (s, Just i)
2076 Stop -> Stop
2077 | otherwise = return $ Skip (st, Nothing)
2079 step' gst (st, Nothing) = do
2080 r <- step gst st
2081 return $
2082 case r of
2083 Yield x s -> Yield x (s, Nothing)
2084 Skip s -> Skip (s, Nothing)
2085 Stop -> Stop
2087data DropWhileState s a
2088 = DropWhileDrop s
2089 | DropWhileYield a s
2090 | DropWhileNext s
2092{-# INLINE_NORMAL dropWhileM #-}
2093dropWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a
2094dropWhileM f (Stream step state) = Stream step' (DropWhileDrop state)
2095 where
2096 {-# INLINE_LATE step' #-}
2097 step' gst (DropWhileDrop st) = do
2098 r <- step gst st
2099 case r of
2100 Yield x s -> do
2101 b <- f x
2102 if b
2103 then return $ Skip (DropWhileDrop s)
2104 else return $ Skip (DropWhileYield x s)
2105 Skip s -> return $ Skip (DropWhileDrop s)
2106 Stop -> return Stop
2108 step' gst (DropWhileNext st) = do
2109 r <- step gst st
2110 case r of
2111 Yield x s -> return $ Skip (DropWhileYield x s)
2112 Skip s -> return $ Skip (DropWhileNext s)
2113 Stop -> return Stop
2115 step' _ (DropWhileYield x st) = return $ Yield x (DropWhileNext st)
2117{-# INLINE dropWhile #-}
2118dropWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
2119dropWhile f = dropWhileM (return . f)
2121{-# INLINE_NORMAL filterM #-}
2122filterM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a
2123filterM f (Stream step state) = Stream step' state
2124 where
2125 {-# INLINE_LATE step' #-}
2126 step' gst st = do
2127 r <- step gst st
2128 case r of
2129 Yield x s -> do
2130 b <- f x
2131 return $ if b
2132 then Yield x s
2133 else Skip s
2134 Skip s -> return $ Skip s
2135 Stop -> return Stop
2137{-# INLINE filter #-}
2138filter :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
2139filter f = filterM (return . f)
2141{-# INLINE_NORMAL uniq #-}
2142uniq :: (Eq a, Monad m) => Stream m a -> Stream m a
2143uniq (Stream step state) = Stream step' (Nothing, state)
2144 where
2145 {-# INLINE_LATE step' #-}
2146 step' gst (Nothing, st) = do
2147 r <- step gst st
2148 case r of
2149 Yield x s -> return $ Yield x (Just x, s)
2150 Skip s -> return $ Skip (Nothing, s)
2151 Stop -> return Stop
2152 step' gst (Just x, st) = do
2153 r <- step gst st
2154 case r of
2155 Yield y s | x == y -> return $ Skip (Just x, s)
2156 | otherwise -> return $ Yield y (Just y, s)
2157 Skip s -> return $ Skip (Just x, s)
2158 Stop -> return Stop
2160------------------------------------------------------------------------------
2161-- Transformation by Mapping
2162------------------------------------------------------------------------------
2164{-# INLINE_NORMAL sequence #-}
2165sequence :: Monad m => Stream m (m a) -> Stream m a
2166sequence (Stream step state) = Stream step' state
2167 where
2168 {-# INLINE_LATE step' #-}
2169 step' gst st = do
2170 r <- step (adaptState gst) st
2171 case r of
2172 Yield x s -> x >>= \a -> return (Yield a s)
2173 Skip s -> return $ Skip s
2174 Stop -> return Stop
2176------------------------------------------------------------------------------
2177-- Inserting
2178------------------------------------------------------------------------------
2180data LoopState x s = FirstYield s
2181 | InterspersingYield s
2182 | YieldAndCarry x s
2184{-# INLINE_NORMAL intersperseM #-}
2185intersperseM :: Monad m => m a -> Stream m a -> Stream m a
2186intersperseM m (Stream step state) = Stream step' (FirstYield state)
2187 where
2188 {-# INLINE_LATE step' #-}
2189 step' gst (FirstYield st) = do
2190 r <- step gst st
2191 return $
2192 case r of
2193 Yield x s -> Skip (YieldAndCarry x s)
2194 Skip s -> Skip (FirstYield s)
2195 Stop -> Stop
2197 step' gst (InterspersingYield st) = do
2198 r <- step gst st
2199 case r of
2200 Yield x s -> do
2201 a <- m
2202 return $ Yield a (YieldAndCarry x s)
2203 Skip s -> return $ Skip $ InterspersingYield s
2204 Stop -> return Stop
2206 step' _ (YieldAndCarry x st) = return $ Yield x (InterspersingYield st)
2208data SuffixState s a
2209 = SuffixElem s
2210 | SuffixSuffix s
2211 | SuffixYield a (SuffixState s a)
2213{-# INLINE_NORMAL insertAfterEach #-}
2214insertAfterEach :: forall m a. Monad m => m a -> Stream m a -> Stream m a
2215insertAfterEach action (Stream step state) = Stream step' (SuffixElem state)
2216 where
2217 {-# INLINE_LATE step' #-}
2218 step' gst (SuffixElem st) = do
2219 r <- step gst st
2220 return $ case r of
2221 Yield x s -> Skip (SuffixYield x (SuffixSuffix s))
2222 Skip s -> Skip (SuffixElem s)
2223 Stop -> Stop
2225 step' _ (SuffixSuffix st) = do
2226 action >>= \r -> return $ Skip (SuffixYield r (SuffixElem st))
2228 step' _ (SuffixYield x next) = return $ Yield x next
2230{-# INLINE intersperse #-}
2231intersperse :: Monad m => a -> Stream m a -> Stream m a
2232intersperse a = intersperseM (return a)
2234{-# INLINE_NORMAL insertBy #-}
2235insertBy :: Monad m => (a -> a -> Ordering) -> a -> Stream m a -> Stream m a
2236insertBy cmp a (Stream step state) = Stream step' (state, False, Nothing)
2237 where
2238 {-# INLINE_LATE step' #-}
2239 step' gst (st, False, _) = do
2240 r <- step gst st
2241 case r of
2242 Yield x s -> case cmp a x of
2243 GT -> return $ Yield x (s, False, Nothing)
2244 _ -> return $ Yield a (s, True, Just x)
2245 Skip s -> return $ Skip (s, False, Nothing)
2246 Stop -> return $ Yield a (st, True, Nothing)
2248 step' _ (_, True, Nothing) = return Stop
2250 step' gst (st, True, Just prev) = do
2251 r <- step gst st
2252 case r of
2253 Yield x s -> return $ Yield prev (s, True, Just x)
2254 Skip s -> return $ Skip (s, True, Just prev)
2255 Stop -> return $ Yield prev (st, True, Nothing)
2257------------------------------------------------------------------------------
2258-- Deleting
2259------------------------------------------------------------------------------
2261{-# INLINE_NORMAL deleteBy #-}
2262deleteBy :: Monad m => (a -> a -> Bool) -> a -> Stream m a -> Stream m a
2263deleteBy eq x (Stream step state) = Stream step' (state, False)
2264 where
2265 {-# INLINE_LATE step' #-}
2266 step' gst (st, False) = do
2267 r <- step gst st
2268 case r of
2269 Yield y s -> return $
2270 if eq x y then Skip (s, True) else Yield y (s, False)
2271 Skip s -> return $ Skip (s, False)
2272 Stop -> return Stop
2274 step' gst (st, True) = do
2275 r <- step gst st
2276 case r of
2277 Yield y s -> return $ Yield y (s, True)
2278 Skip s -> return $ Skip (s, True)
2279 Stop -> return Stop
2281------------------------------------------------------------------------------
2282-- Transformation by Map and Filter
2283------------------------------------------------------------------------------
2285-- XXX Will this always fuse properly?
2286{-# INLINE_NORMAL mapMaybe #-}
2287mapMaybe :: Monad m => (a -> Maybe b) -> Stream m a -> Stream m b
2288mapMaybe f = fmap fromJust . filter isJust . map f
2290{-# INLINE_NORMAL mapMaybeM #-}
2291mapMaybeM :: Monad m => (a -> m (Maybe b)) -> Stream m a -> Stream m b
2292mapMaybeM f = fmap fromJust . filter isJust . mapM f
2294------------------------------------------------------------------------------
2295-- Zipping
2296------------------------------------------------------------------------------
2298{-# INLINE_NORMAL indexed #-}
2299indexed :: Monad m => Stream m a -> Stream m (Int, a)
2300indexed (Stream step state) = Stream step' (state, 0)
2301 where
2302 {-# INLINE_LATE step' #-}
2303 step' gst (st, i) = i `seq` do
2304 r <- step (adaptState gst) st
2305 case r of
2306 Yield x s -> return $ Yield (i, x) (s, i+1)
2307 Skip s -> return $ Skip (s, i)
2308 Stop -> return Stop
2310{-# INLINE_NORMAL indexedR #-}
2311indexedR :: Monad m => Int -> Stream m a -> Stream m (Int, a)
2312indexedR m (Stream step state) = Stream step' (state, m)
2313 where
2314 {-# INLINE_LATE step' #-}
2315 step' gst (st, i) = i `seq` do
2316 r <- step (adaptState gst) st
2317 case r of
2318 Yield x s -> let i' = i - 1
2319 in return $ Yield (i, x) (s, i')
2320 Skip s -> return $ Skip (s, i)
2321 Stop -> return Stop
2323{-# INLINE_NORMAL zipWithM #-}
2324zipWithM :: Monad m
2325 => (a -> b -> m c) -> Stream m a -> Stream m b -> Stream m c
2326zipWithM f (Stream stepa ta) (Stream stepb tb) = Stream step (ta, tb, Nothing)
2327 where
2328 {-# INLINE_LATE step #-}
2329 step gst (sa, sb, Nothing) = do
2330 r <- stepa (adaptState gst) sa
2331 return $
2332 case r of
2333 Yield x sa' -> Skip (sa', sb, Just x)
2334 Skip sa' -> Skip (sa', sb, Nothing)
2335 Stop -> Stop
2337 step gst (sa, sb, Just x) = do
2338 r <- stepb (adaptState gst) sb
2339 case r of
2340 Yield y sb' -> do
2341 z <- f x y
2342 return $ Yield z (sa, sb', Nothing)
2343 Skip sb' -> return $ Skip (sa, sb', Just x)
2344 Stop -> return Stop
2346{-# RULES "zipWithM xs xs"
2347 forall f xs. zipWithM f xs xs = mapM (\x -> f x x) xs #-}
2349{-# INLINE zipWith #-}
2350zipWith :: Monad m => (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c
2351zipWith f = zipWithM (\a b -> return (f a b))
2353------------------------------------------------------------------------------
2354-- Merging
2355------------------------------------------------------------------------------
2357{-# INLINE_NORMAL mergeByM #-}
2358mergeByM
2359 :: (Monad m)
2360 => (a -> a -> m Ordering) -> Stream m a -> Stream m a -> Stream m a
2361mergeByM cmp (Stream stepa ta) (Stream stepb tb) =
2362 Stream step (Just ta, Just tb, Nothing, Nothing)
2363 where
2364 {-# INLINE_LATE step #-}
2366 -- one of the values is missing, and the corresponding stream is running
2367 step gst (Just sa, sb, Nothing, b) = do
2368 r <- stepa gst sa
2369 return $ case r of
2370 Yield a sa' -> Skip (Just sa', sb, Just a, b)
2371 Skip sa' -> Skip (Just sa', sb, Nothing, b)
2372 Stop -> Skip (Nothing, sb, Nothing, b)
2374 step gst (sa, Just sb, a, Nothing) = do
2375 r <- stepb gst sb
2376 return $ case r of
2377 Yield b sb' -> Skip (sa, Just sb', a, Just b)
2378 Skip sb' -> Skip (sa, Just sb', a, Nothing)
2379 Stop -> Skip (sa, Nothing, a, Nothing)
2381 -- both the values are available
2382 step _ (sa, sb, Just a, Just b) = do
2383 res <- cmp a b
2384 return $ case res of
2385 GT -> Yield b (sa, sb, Just a, Nothing)
2386 _ -> Yield a (sa, sb, Nothing, Just b)
2388 -- one of the values is missing, corresponding stream is done
2389 step _ (Nothing, sb, Nothing, Just b) =
2390 return $ Yield b (Nothing, sb, Nothing, Nothing)
2392 step _ (sa, Nothing, Just a, Nothing) =
2393 return $ Yield a (sa, Nothing, Nothing, Nothing)
2395 step _ (Nothing, Nothing, Nothing, Nothing) = return Stop
2397{-# INLINE mergeBy #-}
2398mergeBy
2399 :: (Monad m)
2400 => (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a
2401mergeBy cmp = mergeByM (\a b -> return $ cmp a b)
2403------------------------------------------------------------------------------
2404-- Transformation comprehensions
2405------------------------------------------------------------------------------
2407{-# INLINE_NORMAL the #-}
2408the :: (Eq a, Monad m) => Stream m a -> m (Maybe a)
2409the (Stream step state) = go state
2410 where
2411 go st = do
2412 r <- step defState st
2413 case r of
2414 Yield x s -> go' x s
2415 Skip s -> go s
2416 Stop -> return Nothing
2417 go' n st = do
2418 r <- step defState st
2419 case r of
2420 Yield x s | x == n -> go' n s
2421 | otherwise -> return Nothing
2422 Skip s -> go' n s
2423 Stop -> return (Just n)
2425--------------------------------------------------------------------------------
2426-- UTF8 Encoding / Decoding
2427--------------------------------------------------------------------------------
2429-- UTF-8 primitives, Lifted from GHC.IO.Encoding.UTF8.
2431ord2 :: Char -> [Word8]
2432ord2 c = assert (n >= 0x80 && n <= 0x07ff) [x1, x2]
2433 where
2434 n = ord c
2435 x1 = fromIntegral $ (n `shiftR` 6) + 0xC0
2436 x2 = fromIntegral $ (n .&. 0x3F) + 0x80
2438ord3 :: Char -> [Word8]
2439ord3 c = assert (n >= 0x0800 && n <= 0xffff) [x1, x2, x3]
2440 where
2441 n = ord c
2442 x1 = fromIntegral $ (n `shiftR` 12) + 0xE0
2443 x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
2444 x3 = fromIntegral $ (n .&. 0x3F) + 0x80
2446ord4 :: Char -> [Word8]
2447ord4 c = assert (n >= 0x10000) [x1, x2, x3, x4]
2448 where
2449 n = ord c
2450 x1 = fromIntegral $ (n `shiftR` 18) + 0xF0
2451 x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80
2452 x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
2453 x4 = fromIntegral $ (n .&. 0x3F) + 0x80
2455{-# INLINE chr2 #-}
2456chr2 :: Word8 -> Word8 -> Char
2457chr2 (W8# x1#) (W8# x2#) = C# (chr# (z1# +# z2#))
2458 where
2459 !y1# = word2Int# x1#
2460 !y2# = word2Int# x2#
2461 !z1# = uncheckedIShiftL# (y1# -# 192#) 6#
2462 !z2# = y2# -# 128#
2464{-# INLINE chr3 #-}
2465chr3 :: Word8 -> Word8 -> Word8 -> Char
2466chr3 (W8# x1#) (W8# x2#) (W8# x3#) = C# (chr# (z1# +# z2# +# z3#))
2467 where
2468 !y1# = word2Int# x1#
2469 !y2# = word2Int# x2#
2470 !y3# = word2Int# x3#
2471 !z1# = uncheckedIShiftL# (y1# -# 224#) 12#
2472 !z2# = uncheckedIShiftL# (y2# -# 128#) 6#
2473 !z3# = y3# -# 128#
2475{-# INLINE chr4 #-}
2476chr4 :: Word8 -> Word8 -> Word8 -> Word8 -> Char
2477chr4 (W8# x1#) (W8# x2#) (W8# x3#) (W8# x4#) =
2478 C# (chr# (z1# +# z2# +# z3# +# z4#))
2479 where
2480 !y1# = word2Int# x1#
2481 !y2# = word2Int# x2#
2482 !y3# = word2Int# x3#
2483 !y4# = word2Int# x4#
2484 !z1# = uncheckedIShiftL# (y1# -# 240#) 18#
2485 !z2# = uncheckedIShiftL# (y2# -# 128#) 12#
2486 !z3# = uncheckedIShiftL# (y3# -# 128#) 6#
2487 !z4# = y4# -# 128#
2489{-# INLINE between #-}
2490between ::
2491 Word8 -- ^ byte to check
2492 -> Word8 -- ^ lower bound
2493 -> Word8 -- ^ upper bound
2494 -> Bool
2495between x y z = x >= y && x <= z
2497{-# INLINE validate3 #-}
2498validate3 :: Word8 -> Word8 -> Word8 -> Bool
2499validate3 x1 x2 x3 = validate3_1 ||
2500 validate3_2 ||
2501 validate3_3 ||
2502 validate3_4
2503 where
2504 validate3_1 = (x1 == 0xE0) &&
2505 between x2 0xA0 0xBF &&
2506 between x3 0x80 0xBF
2507 validate3_2 = between x1 0xE1 0xEC &&
2508 between x2 0x80 0xBF &&
2509 between x3 0x80 0xBF
2510 validate3_3 = x1 == 0xED &&
2511 between x2 0x80 0x9F &&
2512 between x3 0x80 0xBF
2513 validate3_4 = between x1 0xEE 0xEF &&
2514 between x2 0x80 0xBF &&
2515 between x3 0x80 0xBF
2517{-# INLINE validate4 #-}
2518validate4 :: Word8 -> Word8 -> Word8 -> Word8 -> Bool
2519validate4 x1 x2 x3 x4 = validate4_1 ||
2520 validate4_2 ||
2521 validate4_3
2522 where
2523 validate4_1 = x1 == 0xF0 &&
2524 between x2 0x90 0xBF &&
2525 between x3 0x80 0xBF &&
2526 between x4 0x80 0xBF
2527 validate4_2 = between x1 0xF1 0xF3 &&
2528 between x2 0x80 0xBF &&
2529 between x3 0x80 0xBF &&
2530 between x4 0x80 0xBF
2531 validate4_3 = x1 == 0xF4 &&
2532 between x2 0x80 0x8F &&
2533 between x3 0x80 0xBF &&
2534 between x4 0x80 0xBF
2536data CodePoint = FreshPoint
2537 | Two !Word8
2538 | GoThree !Word8
2539 | Three !Word8 !Word8
2540 | GoFour !Word8
2541 | Four1 !Word8 !Word8
2542 | Four !Word8 !Word8 !Word8
2543 | YieldPoint !Char
2545{-# INLINE_NORMAL decodeUtf8 #-}
2546decodeUtf8 :: Monad m => Stream m Word8 -> Stream m Char
2547decodeUtf8 (Stream step state) = Stream step' (state, FreshPoint)
2548 where
2549 {-# INLINE_LATE step' #-}
2550 step' gst (st, FreshPoint) = do
2551 r <- step (adaptState gst) st
2552 return $
2553 case r of
2554 Yield c0 s
2555 | c0 <= 0x7f ->
2556 Skip (s, YieldPoint $ unsafeChr (fromIntegral c0))
2557 | c0 >= 0xc0 && c0 <= 0xc1 -> error "Invalid Overlong forms"
2558 | c0 >= 0xc2 && c0 <= 0xdf -> Skip (s, Two c0)
2559 | c0 >= 0xe0 && c0 <= 0xef -> Skip (s, GoThree c0)
2560 | c0 >= 0xf0 -> Skip (s, GoFour c0)
2561 | otherwise -> error "Invalid Sequence"
2562 Skip s -> Skip (s, FreshPoint)
2563 Stop -> Stop
2565 -- Decoding of a UTF8 character that spans two bytes with one byte (c0)
2566 -- known.
2567 step' gst (st, Two c0) = do
2568 r <- step (adaptState gst) st
2569 return $
2570 case r of
2571 Yield c1 s
2572 | c1 < 0x80 || c1 >= 0xc0 -> error "Invalid Sequence"
2573 | otherwise -> Skip (s, YieldPoint $ chr2 c0 c1)
2574 Skip s -> Skip (s, Two c0)
2575 Stop -> error "Input Underflow"
2577 -- Decoding of a UTF8 character that spans three bytes with first byte (c0)
2578 -- known.
2579 step' gst (st, GoThree c0) = do
2580 r <- step (adaptState gst) st
2581 return $
2582 case r of
2583 Yield c1 s
2584 | not (validate3 c0 c1 0x80) -> error "Invalid Sequence"
2585 -- See #3341@ghc
2586 | otherwise -> Skip (s, Three c0 c1)
2587 Skip s -> Skip (s, GoThree c0)
2588 Stop -> error "Input Underflow"
2590 -- Two bytes known of a 3 byte UTF8 encoded unicode character.
2591 step' gst (st, Three c0 c1) = do
2592 r <- step (adaptState gst) st
2593 return $
2594 case r of
2595 Yield c2 s
2596 | not (validate3 c0 c1 c2) -> error "Invalid Sequence"
2597 | otherwise -> Skip (s, YieldPoint $ chr3 c0 c1 c2)
2598 Skip s -> Skip (s, Three c0 c1)
2599 Stop -> error "Input Underflow"
2601 -- One byte known of a four byte UTF8 unicode character.
2602 step' gst (st, GoFour c0) = do
2603 r <- step (adaptState gst) st
2604 return $
2605 case r of
2606 Yield c1 s
2607 | not (validate4 c0 c1 0x80 0x80) -> error "Invalid Sequence"
2608 | otherwise -> Skip (s, Four1 c0 c1)
2609 Skip s -> Skip (s, GoFour c0)
2610 Stop -> error "Input Underflow"
2612 -- Two bytes known of a four byte UTF8 unicode character.
2613 step' gst (st, Four1 c0 c1) = do
2614 r <- step (adaptState gst) st
2615 return $
2616 case r of
2617 Yield c2 s
2618 | not (validate4 c0 c1 c2 0x80) -> error "Invalid Sequence"
2619 | otherwise -> Skip (s, Four c0 c1 c2)
2620 Skip s -> Skip (s, Four1 c0 c1)
2621 Stop -> error "Input Underflow"
2623 -- Three bytes known of a three byte UTF8 unicode character.
2624 step' gst (st, Four c0 c1 c2) = do
2625 r <- step (adaptState gst) st
2626 return $
2627 case r of
2628 Yield c3 s
2629 | not (validate4 c0 c1 c2 c3) -> error "Invalid Sequence"
2630 | otherwise -> Skip (s, YieldPoint $ chr4 c0 c1 c2 c3)
2631 Skip s -> Skip (s, Four c0 c1 c2)
2632 Stop -> error "Input Underflow"
2634 -- This way so that we only need one Yield.
2635 step' _ (s, YieldPoint c) = return $ Yield c (s, FreshPoint)
2637data YieldMany x = None
2638 | YieldMany !x
2640{-# INLINE_NORMAL encodeUtf8 #-}
2641encodeUtf8 :: Monad m => Stream m Char -> Stream m Word8
2642encodeUtf8 (Stream step state) = Stream step' (state, None)
2643 where
2644 {-# INLINE_LATE step' #-}
2645 step' gst (st, None) = do
2646 r <- step (adaptState gst) st
2647 return $
2648 case r of
2649 Yield c s ->
2650 case ord c of
2651 x | x <= 0x7F -> Skip (s, YieldMany [fromIntegral x])
2652 | x <= 0x7FF -> Skip (s, YieldMany (ord2 c))
2653 | x <= 0xFFFF ->
2654 if isSurrogate c
2655 then error "Encountered a surrogate"
2656 else Skip (s, YieldMany (ord3 c))
2657 | otherwise -> Skip (s, YieldMany (ord4 c))
2658 Skip s -> Skip (s, None)
2659 Stop -> Stop
2660 step' _ (s, YieldMany []) = return $ Skip (s, None)
2661 step' _ (s, YieldMany (x:xs)) = return $ Yield x (s, YieldMany xs)