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