1{-# LANGUAGE BangPatterns #-}
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 #-}
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-- Copyright : (c) Bjoern Hoehrmann 2008-2009
29-- Maintainer : harendra.kumar@gmail.com
30-- Stability : experimental
33-- Direct style re-implementation of CPS style stream in StreamK module. The
34-- symbol or suffix 'D' in this module denotes the "Direct" style. GHC is able
35-- to INLINE and fuse direct style better, providing better performance than
39-- import qualified Streamly.Streams.StreamD as D
42-- Some of the functions in this file have been adapted from the vector
43-- library, https://hackage.haskell.org/package/vector.
45module Streamly.Streams.StreamD
65 -- ** Specialized Generation
66 -- | Generate a monadic stream from a seed.
77 , enumerateFromStepIntegral
78 , enumerateFromIntegral
79 , enumerateFromThenIntegral
80 , enumerateFromToIntegral
81 , enumerateFromThenToIntegral
83 , enumerateFromStepNum
86 , enumerateFromToFractional
87 , enumerateFromThenToFractional
90 -- | Transform an input structure into a stream.
91 -- | Direct style stream does not support @fromFoldable@.
118 -- ** Specialized Folds
139 -- ** Flattening nested streams
142 , ConcatMapUState (..)
144 , ConcatUnfoldInterleaveState (..)
145 , concatUnfoldInterleave
146 , concatUnfoldRoundrobin
149 , InterleaveState(..)
154 , roundRobin -- interleaveFair?/ParallelFair
186 -- | Transform a stream into another type.
195 -- ** By folding (scans)
261 -- * Transformation comprehensions
273 -- * UTF8 Encoding / Decoding transformations.
281 , resumeDecodeUtf8Either
283 , decodeUtf8ArraysLenient
287import Control.Exception (Exception, SomeException)
288import Control.Monad (void)
289import Control.Monad.Catch (MonadCatch)
290import Control.Monad.IO.Class (MonadIO(..))
291import Control.Monad.Trans (MonadTrans(lift))
292import Data.Bits (shiftR, shiftL, (.|.), (.&.))
293#if __GLASGOW_HASKELL__ >= 801
294import Data.Functor.Identity (Identity)
296import Data.Maybe (fromJust, isJust)
297import Data.Word (Word32)
298import Foreign.Ptr (Ptr)
299import Foreign.Storable (Storable(..))
300import GHC.Base (assert, Char(..), unsafeChr, ord)
301import GHC.IO.Encoding.Failure (isSurrogate)
302import GHC.Types (SPEC(..))
303import GHC.Word (Word8(..))
304import System.IO.Unsafe (unsafePerformIO)
306 hiding (map, mapM, mapM_, repeat, foldr, last, take, filter,
307 takeWhile, drop, dropWhile, all, any, maximum, minimum, elem,
308 notElem, null, head, tail, zipWith, lookup, foldr1, sequence,
309 (!!), scanl, scanl1, concatMap, replicate, enumFromTo, concat,
312import qualified Control.Monad.Catch as MC
314import Streamly.Internal.Memory.Array.Types (Array(..))
315import Streamly.Internal.Data.Fold.Types (Fold(..))
316import Streamly.Internal.Data.Pipe.Types (Pipe(..), PipeState(..))
317import Streamly.Internal.Data.SVar (MonadAsync, defState, adaptState)
318import Streamly.Internal.Data.Unfold.Types (Unfold(..))
319import Streamly.Internal.Data.Strict (Tuple'(..))
321import Streamly.Streams.StreamD.Type
323import qualified Streamly.Internal.Data.Pipe.Types as Pipe
324import qualified Streamly.Internal.Memory.Array.Types as A
325import qualified Streamly.Memory.Ring as RB
326import qualified Streamly.Streams.StreamK as K
328import Foreign.Ptr (plusPtr)
329import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
330import Foreign.ForeignPtr (ForeignPtr, touchForeignPtr)
332------------------------------------------------------------------------------
334------------------------------------------------------------------------------
336-- | An empty 'Stream'.
337{-# INLINE_NORMAL nil #-}
338nil :: Monad m => Stream m a
339nil = Stream (\_ _ -> return Stop) ()
341-- | An empty 'Stream' with a side effect.
342{-# INLINE_NORMAL nilM #-}
343nilM :: Monad m => m b -> Stream m a
344nilM m = Stream (\_ _ -> m >> return Stop) ()
346{-# INLINE_NORMAL consM #-}
347consM :: Monad m => m a -> Stream m a -> Stream m a
348consM m (Stream step state) = Stream step1 Nothing
350 {-# INLINE_LATE step1 #-}
351 step1 _ Nothing = m >>= \x -> return $ Yield x (Just state)
352 step1 gst (Just st) = do
356 Yield a s -> Yield a (Just s)
357 Skip s -> Skip (Just s)
360-- XXX implement in terms of consM?
361-- cons x = consM (return x)
363-- | Can fuse but has O(n^2) complexity.
364{-# INLINE_NORMAL cons #-}
365cons :: Monad m => a -> Stream m a -> Stream m a
366cons x (Stream step state) = Stream step1 Nothing
368 {-# INLINE_LATE step1 #-}
369 step1 _ Nothing = return $ Yield x (Just state)
370 step1 gst (Just st) = do
374 Yield a s -> Yield a (Just s)
375 Skip s -> Skip (Just s)
378-------------------------------------------------------------------------------
380-------------------------------------------------------------------------------
382-- Does not fuse, has the same performance as the StreamK version.
383{-# INLINE_NORMAL uncons #-}
384uncons :: Monad m => Stream m a -> m (Maybe (a, Stream m a))
385uncons (UnStream step state) = go state
388 r <- step defState st
390 Yield x s -> return $ Just (x, Stream step s)
392 Stop -> return Nothing
394------------------------------------------------------------------------------
395-- Generation by unfold
396------------------------------------------------------------------------------
398{-# INLINE_NORMAL unfoldrM #-}
399unfoldrM :: Monad m => (s -> m (Maybe (a, s))) -> s -> Stream m a
400unfoldrM next state = Stream step state
402 {-# INLINE_LATE step #-}
406 Just (x, s) -> Yield x s
409{-# INLINE_LATE unfoldr #-}
410unfoldr :: Monad m => (s -> Maybe (a, s)) -> s -> Stream m a
411unfoldr f = unfoldrM (return . f)
413-- | Convert an 'Unfold' into a 'Stream' by supplying it a seed.
415{-# INLINE_NORMAL unfold #-}
416unfold :: Monad m => Unfold m a b -> a -> Stream m b
417unfold (Unfold ustep inject) seed = Stream step Nothing
419 {-# INLINE_LATE step #-}
420 step _ Nothing = inject seed >>= return . Skip . Just
421 step _ (Just st) = do
424 Yield x s -> Yield x (Just s)
425 Skip s -> Skip (Just s)
428------------------------------------------------------------------------------
429-- Specialized Generation
430------------------------------------------------------------------------------
432repeatM :: Monad m => m a -> Stream m a
433repeatM x = Stream (\_ _ -> x >>= \r -> return $ Yield r ()) ()
435repeat :: Monad m => a -> Stream m a
436repeat x = Stream (\_ _ -> return $ Yield x ()) ()
438{-# INLINE_NORMAL replicateM #-}
439replicateM :: forall m a. Monad m => Int -> m a -> Stream m a
440replicateM n p = Stream step n
442 {-# INLINE_LATE step #-}
444 | i <= 0 = return Stop
447 return $ Yield x (i - 1)
449{-# INLINE_NORMAL replicate #-}
450replicate :: Monad m => Int -> a -> Stream m a
451replicate n x = replicateM n (return x)
453-- This would not work properly for floats, therefore we put an Integral
455-- | Can be used to enumerate unbounded integrals. This does not check for
456-- overflow or underflow for bounded integrals.
457{-# INLINE_NORMAL enumerateFromStepIntegral #-}
458enumerateFromStepIntegral :: (Integral a, Monad m) => a -> a -> Stream m a
459enumerateFromStepIntegral from stride =
460 from `seq` stride `seq` Stream step from
462 {-# INLINE_LATE step #-}
463 step _ !x = return $ Yield x $! (x + stride)
465-- We are assuming that "to" is constrained by the type to be within
467{-# INLINE enumerateFromToIntegral #-}
468enumerateFromToIntegral :: (Monad m, Integral a) => a -> a -> Stream m a
469enumerateFromToIntegral from to =
470 takeWhile (<= to) $ enumerateFromStepIntegral from 1
472{-# INLINE enumerateFromIntegral #-}
473enumerateFromIntegral :: (Monad m, Integral a, Bounded a) => a -> Stream m a
474enumerateFromIntegral from = enumerateFromToIntegral from maxBound
476data EnumState a = EnumInit | EnumYield a a a | EnumStop
478{-# INLINE_NORMAL enumerateFromThenToIntegralUp #-}
479enumerateFromThenToIntegralUp
480 :: (Monad m, Integral a)
481 => a -> a -> a -> Stream m a
482enumerateFromThenToIntegralUp from next to = Stream step EnumInit
484 {-# INLINE_LATE step #-}
490 else Yield from EnumStop
491 else -- from <= next <= to
492 let stride = next - from
493 in Skip $ EnumYield from stride (to - stride)
495 step _ (EnumYield x stride toMinus) =
498 then Yield x EnumStop
499 else Yield x $ EnumYield (x + stride) stride toMinus
501 step _ EnumStop = return Stop
503{-# INLINE_NORMAL enumerateFromThenToIntegralDn #-}
504enumerateFromThenToIntegralDn
505 :: (Monad m, Integral a)
506 => a -> a -> a -> Stream m a
507enumerateFromThenToIntegralDn from next to = Stream step EnumInit
509 {-# INLINE_LATE step #-}
511 return $ if to > next
514 else Yield from EnumStop
515 else -- from >= next >= to
516 let stride = next - from
517 in Skip $ EnumYield from stride (to - stride)
519 step _ (EnumYield x stride toMinus) =
522 then Yield x EnumStop
523 else Yield x $ EnumYield (x + stride) stride toMinus
525 step _ EnumStop = return Stop
527{-# INLINE_NORMAL enumerateFromThenToIntegral #-}
528enumerateFromThenToIntegral
529 :: (Monad m, Integral a)
530 => a -> a -> a -> Stream m a
531enumerateFromThenToIntegral from next to
532 | next >= from = enumerateFromThenToIntegralUp from next to
533 | otherwise = enumerateFromThenToIntegralDn from next to
535{-# INLINE_NORMAL enumerateFromThenIntegral #-}
536enumerateFromThenIntegral
537 :: (Monad m, Integral a, Bounded a)
538 => a -> a -> Stream m a
539enumerateFromThenIntegral from next =
541 then enumerateFromThenToIntegralUp from next maxBound
542 else enumerateFromThenToIntegralDn from next minBound
544-- For floating point numbers if the increment is less than the precision then
545-- it just gets lost. Therefore we cannot always increment it correctly by just
547-- 9007199254740992 + 1 + 1 :: Double => 9.007199254740992e15
548-- 9007199254740992 + 2 :: Double => 9.007199254740994e15
550-- Instead we accumulate the increment counter and compute the increment
551-- everytime before adding it to the starting number.
553-- This works for Integrals as well as floating point numbers, but
554-- enumerateFromStepIntegral is faster for integrals.
555{-# INLINE_NORMAL enumerateFromStepNum #-}
556enumerateFromStepNum :: (Monad m, Num a) => a -> a -> Stream m a
557enumerateFromStepNum from stride = Stream step 0
559 {-# INLINE_LATE step #-}
560 step _ !i = return $ (Yield $! (from + i * stride)) $! (i + 1)
562{-# INLINE_NORMAL numFrom #-}
563numFrom :: (Monad m, Num a) => a -> Stream m a
564numFrom from = enumerateFromStepNum from 1
566{-# INLINE_NORMAL numFromThen #-}
567numFromThen :: (Monad m, Num a) => a -> a -> Stream m a
568numFromThen from next = enumerateFromStepNum from (next - from)
570-- We cannot write a general function for Num. The only way to write code
571-- portable between the two is to use a 'Real' constraint and convert between
572-- Fractional and Integral using fromRational which is horribly slow.
573{-# INLINE_NORMAL enumerateFromToFractional #-}
574enumerateFromToFractional
575 :: (Monad m, Fractional a, Ord a)
576 => a -> a -> Stream m a
577enumerateFromToFractional from to =
578 takeWhile (<= to + 1 / 2) $ enumerateFromStepNum from 1
580{-# INLINE_NORMAL enumerateFromThenToFractional #-}
581enumerateFromThenToFractional
582 :: (Monad m, Fractional a, Ord a)
583 => a -> a -> a -> Stream m a
584enumerateFromThenToFractional from next to =
585 takeWhile predicate $ numFromThen from next
587 mid = (next - from) / 2
588 predicate | next >= from = (<= to + mid)
589 | otherwise = (>= to + mid)
591-------------------------------------------------------------------------------
592-- Generation by Conversion
593-------------------------------------------------------------------------------
595{-# INLINE_NORMAL fromIndicesM #-}
596fromIndicesM :: Monad m => (Int -> m a) -> Stream m a
597fromIndicesM gen = Stream step 0
599 {-# INLINE_LATE step #-}
602 return $ Yield x (i + 1)
604{-# INLINE fromIndices #-}
605fromIndices :: Monad m => (Int -> a) -> Stream m a
606fromIndices gen = fromIndicesM (return . gen)
608{-# INLINE_NORMAL generateM #-}
609generateM :: Monad m => Int -> (Int -> m a) -> Stream m a
610generateM n gen = n `seq` Stream step 0
612 {-# INLINE_LATE step #-}
613 step _ i | i < n = do
615 return $ Yield x (i + 1)
616 | otherwise = return Stop
618{-# INLINE generate #-}
619generate :: Monad m => Int -> (Int -> a) -> Stream m a
620generate n gen = generateM n (return . gen)
622-- XXX we need the MonadAsync constraint because of a rewrite rule.
623-- | Convert a list of monadic actions to a 'Stream'
624{-# INLINE_LATE fromListM #-}
625fromListM :: MonadAsync m => [m a] -> Stream m a
626fromListM = Stream step
628 {-# INLINE_LATE step #-}
629 step _ (m:ms) = m >>= \x -> return $ Yield x ms
630 step _ [] = return Stop
632{-# INLINE toStreamD #-}
633toStreamD :: (K.IsStream t, Monad m) => t m a -> Stream m a
634toStreamD = fromStreamK . K.toStream
636------------------------------------------------------------------------------
637-- Elimination by Folds
638------------------------------------------------------------------------------
640------------------------------------------------------------------------------
642------------------------------------------------------------------------------
644{-# INLINE_NORMAL foldr1 #-}
645foldr1 :: Monad m => (a -> a -> a) -> Stream m a -> m (Maybe a)
649 Nothing -> return Nothing
650 Just (h, t) -> fmap Just (foldr f h t)
652------------------------------------------------------------------------------
654------------------------------------------------------------------------------
656{-# INLINE_NORMAL foldlT #-}
657foldlT :: (Monad m, Monad (s m), MonadTrans s)
658 => (s m b -> a -> s m b) -> s m b -> Stream m a -> s m b
659foldlT fstep begin (Stream step state) = go SPEC begin state
662 r <- lift $ step defState st
664 Yield x s -> go SPEC (fstep acc x) s
665 Skip s -> go SPEC acc s
668-- Note, this is going to have horrible performance, because of the nature of
669-- the stream type (i.e. direct stream vs CPS). Its only for reference, it is
670-- likely be practically unusable.
671{-# INLINE_NORMAL foldlS #-}
673 => (Stream m b -> a -> Stream m b) -> Stream m b -> Stream m a -> Stream m b
674foldlS fstep begin (Stream step state) = Stream step' (Left (state, begin))
676 step' gst (Left (st, acc)) = do
677 r <- step (adaptState gst) st
679 Yield x s -> Skip (Left (s, fstep acc x))
680 Skip s -> Skip (Left (s, acc))
681 Stop -> Skip (Right acc)
683 step' gst (Right (Stream stp stt)) = do
684 r <- stp (adaptState gst) stt
686 Yield x s -> Yield x (Right (Stream stp s))
687 Skip s -> Skip (Right (Stream stp s))
690------------------------------------------------------------------------------
692------------------------------------------------------------------------------
694-- | Run a streaming composition, discard the results.
695{-# INLINE_LATE drain #-}
696drain :: Monad m => Stream m a -> m ()
697-- drain = foldrM (\_ xs -> xs) (return ())
698drain (Stream step state) = go SPEC state
701 r <- step defState st
703 Yield _ s -> go SPEC s
707{-# INLINE_NORMAL null #-}
708null :: Monad m => Stream m a -> m Bool
709null m = foldrM (\_ _ -> return False) (return True) m
711{-# INLINE_NORMAL head #-}
712head :: Monad m => Stream m a -> m (Maybe a)
713head m = foldrM (\x _ -> return (Just x)) (return Nothing) m
715-- Does not fuse, has the same performance as the StreamK version.
716{-# INLINE_NORMAL tail #-}
717tail :: Monad m => Stream m a -> m (Maybe (Stream m a))
718tail (UnStream step state) = go state
721 r <- step defState st
723 Yield _ s -> return (Just $ Stream step s)
725 Stop -> return Nothing
727-- XXX will it fuse? need custom impl?
728{-# INLINE_NORMAL last #-}
729last :: Monad m => Stream m a -> m (Maybe a)
730last = foldl' (\_ y -> Just y) Nothing
732{-# INLINE_NORMAL elem #-}
733elem :: (Monad m, Eq a) => a -> Stream m a -> m Bool
734-- elem e m = foldrM (\x xs -> if x == e then return True else xs) (return False) m
735elem e (Stream step state) = go state
738 r <- step defState st
741 | x == e -> return True
746{-# INLINE_NORMAL notElem #-}
747notElem :: (Monad m, Eq a) => a -> Stream m a -> m Bool
748notElem e s = fmap not (elem e s)
750{-# INLINE_NORMAL all #-}
751all :: Monad m => (a -> Bool) -> Stream m a -> m Bool
752-- all p m = foldrM (\x xs -> if p x then xs else return False) (return True) m
753all p (Stream step state) = go state
756 r <- step defState st
760 | otherwise -> return False
764{-# INLINE_NORMAL any #-}
765any :: Monad m => (a -> Bool) -> Stream m a -> m Bool
766-- any p m = foldrM (\x xs -> if p x then return True else xs) (return False) m
767any p (Stream step state) = go state
770 r <- step defState st
778{-# INLINE_NORMAL maximum #-}
779maximum :: (Monad m, Ord a) => Stream m a -> m (Maybe a)
780maximum (Stream step state) = go Nothing state
783 r <- step defState st
785 Yield x s -> go (Just x) s
786 Skip s -> go Nothing s
787 Stop -> return Nothing
788 go (Just acc) st = do
789 r <- step defState st
792 | acc <= x -> go (Just x) s
793 | otherwise -> go (Just acc) s
794 Skip s -> go (Just acc) s
795 Stop -> return (Just acc)
797{-# INLINE_NORMAL maximumBy #-}
798maximumBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> m (Maybe a)
799maximumBy cmp (Stream step state) = go Nothing state
802 r <- step defState st
804 Yield x s -> go (Just x) s
805 Skip s -> go Nothing s
806 Stop -> return Nothing
807 go (Just acc) st = do
808 r <- step defState st
810 Yield x s -> case cmp acc x of
811 GT -> go (Just acc) s
813 Skip s -> go (Just acc) s
814 Stop -> return (Just acc)
816{-# INLINE_NORMAL minimum #-}
817minimum :: (Monad m, Ord a) => Stream m a -> m (Maybe a)
818minimum (Stream step state) = go Nothing state
821 r <- step defState st
823 Yield x s -> go (Just x) s
824 Skip s -> go Nothing s
825 Stop -> return Nothing
826 go (Just acc) st = do
827 r <- step defState st
830 | acc <= x -> go (Just acc) s
831 | otherwise -> go (Just x) s
832 Skip s -> go (Just acc) s
833 Stop -> return (Just acc)
835{-# INLINE_NORMAL minimumBy #-}
836minimumBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> m (Maybe a)
837minimumBy cmp (Stream step state) = go Nothing state
840 r <- step defState st
842 Yield x s -> go (Just x) s
843 Skip s -> go Nothing s
844 Stop -> return Nothing
845 go (Just acc) st = do
846 r <- step defState st
848 Yield x s -> case cmp acc x of
851 Skip s -> go (Just acc) s
852 Stop -> return (Just acc)
854{-# INLINE_NORMAL (!!) #-}
855(!!) :: (Monad m) => Stream m a -> Int -> m (Maybe a)
856(Stream step state) !! i = go i state
859 r <- step defState st
861 Yield x s | n < 0 -> return Nothing
862 | n == 0 -> return $ Just x
863 | otherwise -> go (n - 1) s
865 Stop -> return Nothing
867{-# INLINE_NORMAL lookup #-}
868lookup :: (Monad m, Eq a) => a -> Stream m (a, b) -> m (Maybe b)
869lookup e m = foldrM (\(a, b) xs -> if e == a then return (Just b) else xs)
872{-# INLINE_NORMAL findM #-}
873findM :: Monad m => (a -> m Bool) -> Stream m a -> m (Maybe a)
874findM p m = foldrM (\x xs -> p x >>= \r -> if r then return (Just x) else xs)
878find :: Monad m => (a -> Bool) -> Stream m a -> m (Maybe a)
879find p = findM (return . p)
881{-# INLINE_NORMAL findIndices #-}
882findIndices :: Monad m => (a -> Bool) -> Stream m a -> Stream m Int
883findIndices p (Stream step state) = Stream step' (state, 0)
885 {-# INLINE_LATE step' #-}
886 step' gst (st, i) = do
887 r <- step (adaptState gst) st
889 Yield x s -> if p x then Yield i (s, i+1) else Skip (s, i+1)
890 Skip s -> Skip (s, i+1)
893{-# INLINE toListRev #-}
894toListRev :: Monad m => Stream m a -> m [a]
895toListRev = foldl' (flip (:)) []
897-- We can implement reverse as:
899-- > reverse = foldlS (flip cons) nil
901-- However, this implementation is unusable because of the horrible performance
902-- of cons. So we just convert it to a list first and then stream from the
905-- XXX Maybe we can use an Array instead of a list here?
906{-# INLINE_NORMAL reverse #-}
907reverse :: Monad m => Stream m a -> Stream m a
908reverse m = Stream step Nothing
910 {-# INLINE_LATE step #-}
913 return $ Skip (Just xs)
914 step _ (Just (x:xs)) = return $ Yield x (Just xs)
915 step _ (Just []) = return Stop
917-- Much faster reverse for Storables
918{-# INLINE_NORMAL reverse' #-}
919reverse' :: forall m a. (MonadIO m, Storable a) => Stream m a -> Stream m a
921-- This commented implementation copies the whole stream into one single array
922-- and then streams from that array, this is 3-4x faster than the chunked code
923-- that follows. Though this could be problematic due to unbounded large
924-- allocations. We need to figure out why the chunked code is slower and if we
925-- can optimize the chunked code to work as fast as this one. It may be a
927import Foreign.ForeignPtr (touchForeignPtr)
928import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
929import Foreign.Ptr (Ptr, plusPtr)
930reverse' m = Stream step Nothing
932 {-# INLINE_LATE step #-}
934 arr <- A.fromStreamD m
935 let p = aEnd arr `plusPtr` negate (sizeOf (undefined :: a))
936 return $ Skip $ Just (aStart arr, p)
938 step _ (Just (start, p)) | p < unsafeForeignPtrToPtr start = return Stop
940 step _ (Just (start, p)) = do
941 let !x = A.unsafeInlineIO $ do
943 touchForeignPtr start
945 next = p `plusPtr` negate (sizeOf (undefined :: a))
946 return $ Yield x (Just (start, next))
953 $ A.fromStreamDArraysOf A.defaultChunkSize m
956------------------------------------------------------------------------------
958------------------------------------------------------------------------------
960{-# INLINE_NORMAL splitSuffixBy' #-}
961splitSuffixBy' :: Monad m
962 => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
963splitSuffixBy' predicate f (Stream step state) =
964 Stream (stepOuter f) (Just state)
968 {-# INLINE_LATE stepOuter #-}
969 stepOuter (Fold fstep initial done) gst (Just st) = do
970 res <- step (adaptState gst) st
976 then done acc' >>= \val -> return $ Yield val (Just s)
979 Skip s -> return $ Skip $ Just s
985 res <- step (adaptState gst) stt
990 then done acc' >>= \val -> return $ Yield val (Just s)
992 Skip s -> go SPEC s acc
993 Stop -> done acc >>= \val -> return $ Yield val Nothing
995 stepOuter _ _ Nothing = return Stop
997{-# INLINE_NORMAL groupsBy #-}
1003groupsBy cmp f (Stream step state) = Stream (stepOuter f) (Just state, Nothing)
1007 {-# INLINE_LATE stepOuter #-}
1008 stepOuter (Fold fstep initial done) gst (Just st, Nothing) = do
1009 res <- step (adaptState gst) st
1016 Skip s -> return $ Skip $ (Just s, Nothing)
1021 go !_ prev stt !acc = do
1022 res <- step (adaptState gst) stt
1029 else done acc >>= \r -> return $ Yield r (Just s, Just x)
1030 Skip s -> go SPEC prev s acc
1031 Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1033 stepOuter (Fold fstep initial done) gst (Just st, Just prev) = do
1035 acc' <- fstep acc prev
1040 -- XXX code duplicated from the previous equation
1042 res <- step (adaptState gst) stt
1049 else done acc >>= \r -> return $ Yield r (Just s, Just x)
1050 Skip s -> go SPEC s acc
1051 Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1053 stepOuter _ _ (Nothing,_) = return Stop
1055{-# INLINE_NORMAL groupsRollingBy #-}
1056groupsRollingBy :: Monad m
1061groupsRollingBy cmp f (Stream step state) =
1062 Stream (stepOuter f) (Just state, Nothing)
1065 {-# INLINE_LATE stepOuter #-}
1066 stepOuter (Fold fstep initial done) gst (Just st, Nothing) = do
1067 res <- step (adaptState gst) st
1074 Skip s -> return $ Skip $ (Just s, Nothing)
1078 go !_ prev stt !acc = do
1079 res <- step (adaptState gst) stt
1087 done acc >>= \r -> return $ Yield r (Just s, Just x)
1088 Skip s -> go SPEC prev s acc
1089 Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1091 stepOuter (Fold fstep initial done) gst (Just st, Just prev') = do
1093 acc' <- fstep acc prev'
1094 go SPEC prev' st acc'
1097 go !_ prevv stt !acc = do
1098 res <- step (adaptState gst) stt
1105 else done acc >>= \r -> return $ Yield r (Just s, Just x)
1106 Skip s -> go SPEC prevv s acc
1107 Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1109 stepOuter _ _ (Nothing, _) = return Stop
1111{-# INLINE_NORMAL splitBy #-}
1112splitBy :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
1113splitBy predicate f (Stream step state) = Stream (step' f) (Just state)
1117 {-# INLINE_LATE step' #-}
1118 step' (Fold fstep initial done) gst (Just st) = initial >>= go SPEC st
1123 res <- step (adaptState gst) stt
1127 then done acc >>= \r -> return $ Yield r (Just s)
1131 Skip s -> go SPEC s acc
1132 Stop -> done acc >>= \r -> return $ Yield r Nothing
1134 step' _ _ Nothing = return Stop
1136-- XXX requires -funfolding-use-threshold=150 in lines-unlines benchmark
1137{-# INLINE_NORMAL splitSuffixBy #-}
1138splitSuffixBy :: Monad m
1139 => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
1140splitSuffixBy predicate f (Stream step state) = Stream (step' f) (Just state)
1144 {-# INLINE_LATE step' #-}
1145 step' (Fold fstep initial done) gst (Just st) = do
1146 res <- step (adaptState gst) st
1151 then done acc >>= \val -> return $ Yield val (Just s)
1156 Skip s -> return $ Skip $ Just s
1162 res <- step (adaptState gst) stt
1166 then done acc >>= \r -> return $ Yield r (Just s)
1170 Skip s -> go SPEC s acc
1171 Stop -> done acc >>= \r -> return $ Yield r Nothing
1173 step' _ _ Nothing = return Stop
1175{-# INLINE_NORMAL wordsBy #-}
1176wordsBy :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
1177wordsBy predicate f (Stream step state) = Stream (stepOuter f) (Just state)
1181 {-# INLINE_LATE stepOuter #-}
1182 stepOuter (Fold fstep initial done) gst (Just st) = do
1183 res <- step (adaptState gst) st
1187 then return $ Skip (Just s)
1193 Skip s -> return $ Skip $ Just s
1199 res <- step (adaptState gst) stt
1203 then done acc >>= \r -> return $ Yield r (Just s)
1207 Skip s -> go SPEC s acc
1208 Stop -> done acc >>= \r -> return $ Yield r Nothing
1210 stepOuter _ _ Nothing = return Stop
1212-- String search algorithms:
1213-- http://www-igm.univ-mlv.fr/~lecroq/string/index.html
1216-- TODO can we unify the splitting operations using a splitting configuration
1217-- like in the split package.
1219data SplitStyle = Infix | Suffix | Prefix deriving (Eq, Show)
1221data SplitOptions = SplitOptions
1222 { style :: SplitStyle
1223 , withSep :: Bool -- ^ keep the separators in output
1224 -- , compact :: Bool -- ^ treat multiple consecutive separators as one
1225 -- , trimHead :: Bool -- ^ drop blank at head
1226 -- , trimTail :: Bool -- ^ drop blank at tail
1230data SplitOnState s a =
1235 | GO_KARP_RABIN s !(RB.Ring a) !(Ptr a)
1238{-# INLINE_NORMAL splitOn #-}
1240 :: forall m a b. (MonadIO m, Storable a, Enum a, Eq a)
1245splitOn patArr@Array{..} (Fold fstep initial done) (Stream step state) =
1246 Stream stepOuter GO_START
1250 patLen = A.length patArr
1251 maxIndex = patLen - 1
1252 elemBits = sizeOf (undefined :: a) * 8
1254 {-# INLINE_LATE stepOuter #-}
1255 stepOuter _ GO_START =
1257 then return $ Skip $ GO_EMPTY_PAT state
1260 r <- liftIO $ (A.unsafeIndexIO patArr 0)
1261 return $ Skip $ GO_SINGLE_PAT state r
1262 else if sizeOf (undefined :: a) * patLen
1263 <= sizeOf (undefined :: Word)
1264 then return $ Skip $ GO_SHORT_PAT state
1266 (rb, rhead) <- liftIO $ RB.new patLen
1267 return $ Skip $ GO_KARP_RABIN state rb rhead
1269 stepOuter gst (GO_SINGLE_PAT stt pat) = initial >>= go SPEC stt
1274 res <- step (adaptState gst) st
1280 return $ Yield r (GO_SINGLE_PAT s pat)
1281 else fstep acc x >>= go SPEC s
1282 Skip s -> go SPEC s acc
1283 Stop -> done acc >>= \r -> return $ Yield r GO_DONE
1285 stepOuter gst (GO_SHORT_PAT stt) = initial >>= go0 SPEC 0 (0 :: Word) stt
1290 mask = (1 `shiftL` (elemBits * patLen)) - 1
1292 addToWord wrd a = (wrd `shiftL` elemBits) .|. fromIntegral (fromEnum a)
1295 patWord = mask .&. A.foldl' addToWord 0 patArr
1297 go0 !_ !idx wrd st !acc = do
1298 res <- step (adaptState gst) st
1301 let wrd' = addToWord wrd x
1304 if wrd' .&. mask == patWord
1307 return $ Yield r (GO_SHORT_PAT s)
1308 else go1 SPEC wrd' s acc
1309 else go0 SPEC (idx + 1) wrd' s acc
1310 Skip s -> go0 SPEC idx wrd s acc
1313 then go2 wrd idx acc
1315 done acc' >>= \r -> return $ Yield r GO_DONE
1318 go1 !_ wrd st !acc = do
1319 res <- step (adaptState gst) st
1322 let wrd' = addToWord wrd x
1323 old = (mask .&. wrd) `shiftR` (elemBits * (patLen - 1))
1324 acc' <- fstep acc (toEnum $ fromIntegral old)
1325 if wrd' .&. mask == patWord
1326 then done acc' >>= \r -> return $ Yield r (GO_SHORT_PAT s)
1327 else go1 SPEC wrd' s acc'
1328 Skip s -> go1 SPEC wrd s acc
1330 acc' <- go2 wrd patLen acc
1331 done acc' >>= \r -> return $ Yield r GO_DONE
1333 go2 !wrd !n !acc | n > 0 = do
1334 let old = (mask .&. wrd) `shiftR` (elemBits * (n - 1))
1335 fstep acc (toEnum $ fromIntegral old) >>= go2 wrd (n - 1)
1336 go2 _ _ acc = return acc
1338 stepOuter gst (GO_KARP_RABIN stt rb rhead) = do
1339 initial >>= go0 SPEC 0 rhead stt
1343 k = 2891336453 :: Word32
1345 addCksum cksum a = cksum * k + fromIntegral (fromEnum a)
1346 deltaCksum cksum old new =
1347 addCksum cksum new - coeff * fromIntegral (fromEnum old)
1349 -- XXX shall we use a random starting hash or 1 instead of 0?
1350 patHash = A.foldl' addCksum 0 patArr
1353 go0 !_ !idx !rh st !acc = do
1354 res <- step (adaptState gst) st
1357 rh' <- liftIO $ RB.unsafeInsert rb rh x
1360 let fold = RB.unsafeFoldRing (RB.ringBound rb)
1361 let !ringHash = fold addCksum 0 rb
1362 if ringHash == patHash
1363 then go2 SPEC ringHash rh' s acc
1364 else go1 SPEC ringHash rh' s acc
1365 else go0 SPEC (idx + 1) rh' s acc
1366 Skip s -> go0 SPEC idx rh s acc
1368 !acc' <- if idx /= 0
1369 then RB.unsafeFoldRingM rh fstep acc rb
1371 done acc' >>= \r -> return $ Yield r GO_DONE
1373 -- XXX Theoretically this code can do 4 times faster if GHC generates
1374 -- optimal code. If we use just "(cksum' == patHash)" condition it goes
1375 -- 4x faster, as soon as we add the "RB.unsafeEqArray rb v" condition
1376 -- the generated code changes drastically and becomes 4x slower. Need
1377 -- to investigate what is going on with GHC.
1379 go1 !_ !cksum !rh st !acc = do
1380 res <- step (adaptState gst) st
1383 old <- liftIO $ peek rh
1384 let cksum' = deltaCksum cksum old x
1385 acc' <- fstep acc old
1387 if (cksum' == patHash)
1389 rh' <- liftIO (RB.unsafeInsert rb rh x)
1390 go2 SPEC cksum' rh' s acc'
1392 rh' <- liftIO (RB.unsafeInsert rb rh x)
1393 go1 SPEC cksum' rh' s acc'
1394 Skip s -> go1 SPEC cksum rh s acc
1396 acc' <- RB.unsafeFoldRingFullM rh fstep acc rb
1397 done acc' >>= \r -> return $ Yield r GO_DONE
1399 go2 !_ !cksum' !rh' s !acc' = do
1400 if RB.unsafeEqArray rb rh' patArr
1403 return $ Yield r (GO_KARP_RABIN s rb rhead)
1404 else go1 SPEC cksum' rh' s acc'
1406 stepOuter gst (GO_EMPTY_PAT st) = do
1407 res <- step (adaptState gst) st
1412 done acc' >>= \r -> return $ Yield r (GO_EMPTY_PAT s)
1413 Skip s -> return $ Skip (GO_EMPTY_PAT s)
1416 stepOuter _ GO_DONE = return Stop
1418{-# INLINE_NORMAL splitSuffixOn #-}
1420 :: forall m a b. (MonadIO m, Storable a, Enum a, Eq a)
1426splitSuffixOn withSep patArr@Array{..} (Fold fstep initial done)
1427 (Stream step state) =
1428 Stream stepOuter GO_START
1432 patLen = A.length patArr
1433 maxIndex = patLen - 1
1434 elemBits = sizeOf (undefined :: a) * 8
1436 {-# INLINE_LATE stepOuter #-}
1437 stepOuter _ GO_START =
1439 then return $ Skip $ GO_EMPTY_PAT state
1442 r <- liftIO $ (A.unsafeIndexIO patArr 0)
1443 return $ Skip $ GO_SINGLE_PAT state r
1444 else if sizeOf (undefined :: a) * patLen
1445 <= sizeOf (undefined :: Word)
1446 then return $ Skip $ GO_SHORT_PAT state
1448 (rb, rhead) <- liftIO $ RB.new patLen
1449 return $ Skip $ GO_KARP_RABIN state rb rhead
1451 stepOuter gst (GO_SINGLE_PAT stt pat) = do
1452 -- This first part is the only difference between splitOn and
1454 -- If the last element is a separator do not issue a blank segment.
1455 res <- step (adaptState gst) stt
1461 acc' <- if withSep then fstep acc x else return acc
1462 done acc' >>= \r -> return $ Yield r (GO_SINGLE_PAT s pat)
1463 else fstep acc x >>= go SPEC s
1464 Skip s -> return $ Skip $ (GO_SINGLE_PAT s pat)
1469 -- This is identical for splitOn and splitSuffixOn
1471 res <- step (adaptState gst) st
1476 acc' <- if withSep then fstep acc x else return acc
1478 return $ Yield r (GO_SINGLE_PAT s pat)
1479 else fstep acc x >>= go SPEC s
1480 Skip s -> go SPEC s acc
1481 Stop -> done acc >>= \r -> return $ Yield r GO_DONE
1483 stepOuter gst (GO_SHORT_PAT stt) = do
1485 -- Call "initial" only if the stream yields an element, otherwise we
1486 -- may call "initial" but never yield anything. initial may produce a
1487 -- side effect, therefore we will end up doing and discard a side
1492 res <- step (adaptState gst) stt
1496 let wrd' = addToWord wrd x
1497 acc' <- if withSep then fstep acc x else return acc
1500 if wrd' .&. mask == patWord
1501 then done acc' >>= \r -> return $ Yield r (GO_SHORT_PAT s)
1502 else go0 SPEC (idx + 1) wrd' s acc'
1503 else go0 SPEC (idx + 1) wrd' s acc'
1504 Skip s -> return $ Skip (GO_SHORT_PAT s)
1510 mask = (1 `shiftL` (elemBits * patLen)) - 1
1512 addToWord wrd a = (wrd `shiftL` elemBits) .|. fromIntegral (fromEnum a)
1515 patWord = mask .&. A.foldl' addToWord 0 patArr
1517 go0 !_ !idx wrd st !acc = do
1518 res <- step (adaptState gst) st
1521 let wrd' = addToWord wrd x
1522 acc' <- if withSep then fstep acc x else return acc
1525 if wrd' .&. mask == patWord
1528 return $ Yield r (GO_SHORT_PAT s)
1529 else go1 SPEC wrd' s acc'
1530 else go0 SPEC (idx + 1) wrd' s acc'
1531 Skip s -> go0 SPEC idx wrd s acc
1533 if (idx == maxIndex) && (wrd .&. mask == patWord)
1536 acc' <- if idx /= 0 && not withSep
1537 then go2 wrd idx acc
1539 done acc' >>= \r -> return $ Yield r GO_DONE
1542 go1 !_ wrd st !acc = do
1543 res <- step (adaptState gst) st
1546 let wrd' = addToWord wrd x
1547 old = (mask .&. wrd) `shiftR` (elemBits * (patLen - 1))
1550 else fstep acc (toEnum $ fromIntegral old)
1551 if wrd' .&. mask == patWord
1552 then done acc' >>= \r -> return $ Yield r (GO_SHORT_PAT s)
1553 else go1 SPEC wrd' s acc'
1554 Skip s -> go1 SPEC wrd s acc
1556 -- If the last sequence is a separator do not issue a blank
1558 if wrd .&. mask == patWord
1563 else go2 wrd patLen acc
1564 done acc' >>= \r -> return $ Yield r GO_DONE
1566 go2 !wrd !n !acc | n > 0 = do
1567 let old = (mask .&. wrd) `shiftR` (elemBits * (n - 1))
1568 fstep acc (toEnum $ fromIntegral old) >>= go2 wrd (n - 1)
1569 go2 _ _ acc = return acc
1571 stepOuter gst (GO_KARP_RABIN stt rb rhead) = do
1573 res <- step (adaptState gst) stt
1577 acc' <- if withSep then fstep acc x else return acc
1578 rh' <- liftIO (RB.unsafeInsert rb rhead x)
1581 let fold = RB.unsafeFoldRing (RB.ringBound rb)
1582 let !ringHash = fold addCksum 0 rb
1583 if ringHash == patHash
1584 then go2 SPEC ringHash rh' s acc'
1585 else go0 SPEC (idx + 1) rh' s acc'
1586 else go0 SPEC (idx + 1) rh' s acc'
1587 Skip s -> return $ Skip (GO_KARP_RABIN s rb rhead)
1592 k = 2891336453 :: Word32
1594 addCksum cksum a = cksum * k + fromIntegral (fromEnum a)
1595 deltaCksum cksum old new =
1596 addCksum cksum new - coeff * fromIntegral (fromEnum old)
1598 -- XXX shall we use a random starting hash or 1 instead of 0?
1599 patHash = A.foldl' addCksum 0 patArr
1602 go0 !_ !idx !rh st !acc = do
1603 res <- step (adaptState gst) st
1606 acc' <- if withSep then fstep acc x else return acc
1607 rh' <- liftIO (RB.unsafeInsert rb rh x)
1610 let fold = RB.unsafeFoldRing (RB.ringBound rb)
1611 let !ringHash = fold addCksum 0 rb
1612 if ringHash == patHash
1613 then go2 SPEC ringHash rh' s acc'
1614 else go1 SPEC ringHash rh' s acc'
1615 else go0 SPEC (idx + 1) rh' s acc'
1616 Skip s -> go0 SPEC idx rh s acc
1618 -- do not issue a blank segment when we end at pattern
1619 if (idx == maxIndex) && RB.unsafeEqArray rb rh patArr
1622 !acc' <- if idx /= 0 && not withSep
1623 then RB.unsafeFoldRingM rh fstep acc rb
1625 done acc' >>= \r -> return $ Yield r GO_DONE
1627 -- XXX Theoretically this code can do 4 times faster if GHC generates
1628 -- optimal code. If we use just "(cksum' == patHash)" condition it goes
1629 -- 4x faster, as soon as we add the "RB.unsafeEqArray rb v" condition
1630 -- the generated code changes drastically and becomes 4x slower. Need
1631 -- to investigate what is going on with GHC.
1633 go1 !_ !cksum !rh st !acc = do
1634 res <- step (adaptState gst) st
1637 old <- liftIO $ peek rh
1638 let cksum' = deltaCksum cksum old x
1643 if (cksum' == patHash)
1645 rh' <- liftIO (RB.unsafeInsert rb rh x)
1646 go2 SPEC cksum' rh' s acc'
1648 rh' <- liftIO (RB.unsafeInsert rb rh x)
1649 go1 SPEC cksum' rh' s acc'
1650 Skip s -> go1 SPEC cksum rh s acc
1652 if RB.unsafeEqArray rb rh patArr
1657 else RB.unsafeFoldRingFullM rh fstep acc rb
1658 done acc' >>= \r -> return $ Yield r GO_DONE
1660 go2 !_ !cksum' !rh' s !acc' = do
1661 if RB.unsafeEqArray rb rh' patArr
1664 return $ Yield r (GO_KARP_RABIN s rb rhead)
1665 else go1 SPEC cksum' rh' s acc'
1667 stepOuter gst (GO_EMPTY_PAT st) = do
1668 res <- step (adaptState gst) st
1673 done acc' >>= \r -> return $ Yield r (GO_EMPTY_PAT s)
1674 Skip s -> return $ Skip (GO_EMPTY_PAT s)
1677 stepOuter _ GO_DONE = return Stop
1679data SplitState s arr
1681 | SplitBuffering s arr
1682 | SplitSplitting s arr
1683 | SplitYielding arr (SplitState s arr)
1686-- XXX An alternative approach would be to use a partial fold (Fold m a b) to
1687-- split using a splitBy like combinator. The Fold would consume upto the
1688-- separator and return any leftover which can then be fed to the next fold.
1690-- We can revisit this once we have partial folds/parsers.
1692-- | Performs infix separator style splitting.
1693{-# INLINE_NORMAL splitInnerBy #-}
1696 => (f a -> m (f a, Maybe (f a))) -- splitter
1697 -> (f a -> f a -> m (f a)) -- joiner
1700splitInnerBy splitter joiner (Stream step1 state1) =
1701 (Stream step (SplitInitial state1))
1705 {-# INLINE_LATE step #-}
1706 step gst (SplitInitial st) = do
1710 (x1, mx2) <- splitter x
1711 return $ case mx2 of
1712 Nothing -> Skip (SplitBuffering s x1)
1713 Just x2 -> Skip (SplitYielding x1 (SplitSplitting s x2))
1714 Skip s -> return $ Skip (SplitInitial s)
1715 Stop -> return $ Stop
1717 step gst (SplitBuffering st buf) = do
1721 (x1, mx2) <- splitter x
1722 buf' <- joiner buf x1
1723 return $ case mx2 of
1724 Nothing -> Skip (SplitBuffering s buf')
1725 Just x2 -> Skip (SplitYielding buf' (SplitSplitting s x2))
1726 Skip s -> return $ Skip (SplitBuffering s buf)
1727 Stop -> return $ Skip (SplitYielding buf SplitFinishing)
1729 step _ (SplitSplitting st buf) = do
1730 (x1, mx2) <- splitter buf
1731 return $ case mx2 of
1732 Nothing -> Skip $ SplitBuffering st x1
1733 Just x2 -> Skip $ SplitYielding x1 (SplitSplitting st x2)
1735 step _ (SplitYielding x next) = return $ Yield x next
1736 step _ SplitFinishing = return $ Stop
1738-- | Performs infix separator style splitting.
1739{-# INLINE_NORMAL splitInnerBySuffix #-}
1741 :: (Monad m, Eq (f a), Monoid (f a))
1742 => (f a -> m (f a, Maybe (f a))) -- splitter
1743 -> (f a -> f a -> m (f a)) -- joiner
1746splitInnerBySuffix splitter joiner (Stream step1 state1) =
1747 (Stream step (SplitInitial state1))
1751 {-# INLINE_LATE step #-}
1752 step gst (SplitInitial st) = do
1756 (x1, mx2) <- splitter x
1757 return $ case mx2 of
1758 Nothing -> Skip (SplitBuffering s x1)
1759 Just x2 -> Skip (SplitYielding x1 (SplitSplitting s x2))
1760 Skip s -> return $ Skip (SplitInitial s)
1761 Stop -> return $ Stop
1763 step gst (SplitBuffering st buf) = do
1767 (x1, mx2) <- splitter x
1768 buf' <- joiner buf x1
1769 return $ case mx2 of
1770 Nothing -> Skip (SplitBuffering s buf')
1771 Just x2 -> Skip (SplitYielding buf' (SplitSplitting s x2))
1772 Skip s -> return $ Skip (SplitBuffering s buf)
1776 else Skip (SplitYielding buf SplitFinishing)
1778 step _ (SplitSplitting st buf) = do
1779 (x1, mx2) <- splitter buf
1780 return $ case mx2 of
1781 Nothing -> Skip $ SplitBuffering st x1
1782 Just x2 -> Skip $ SplitYielding x1 (SplitSplitting st x2)
1784 step _ (SplitYielding x next) = return $ Yield x next
1785 step _ SplitFinishing = return $ Stop
1787------------------------------------------------------------------------------
1789------------------------------------------------------------------------------
1791{-# INLINE_NORMAL isPrefixOf #-}
1792isPrefixOf :: (Eq a, Monad m) => Stream m a -> Stream m a -> m Bool
1793isPrefixOf (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)
1795 go (sa, sb, Nothing) = do
1796 r <- stepa defState sa
1798 Yield x sa' -> go (sa', sb, Just x)
1799 Skip sa' -> go (sa', sb, Nothing)
1802 go (sa, sb, Just x) = do
1803 r <- stepb defState sb
1807 then go (sa, sb', Nothing)
1809 Skip sb' -> go (sa, sb', Just x)
1810 Stop -> return False
1812{-# INLINE_NORMAL isSubsequenceOf #-}
1813isSubsequenceOf :: (Eq a, Monad m) => Stream m a -> Stream m a -> m Bool
1814isSubsequenceOf (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)
1816 go (sa, sb, Nothing) = do
1817 r <- stepa defState sa
1819 Yield x sa' -> go (sa', sb, Just x)
1820 Skip sa' -> go (sa', sb, Nothing)
1823 go (sa, sb, Just x) = do
1824 r <- stepb defState sb
1828 then go (sa, sb', Nothing)
1829 else go (sa, sb', Just x)
1830 Skip sb' -> go (sa, sb', Just x)
1831 Stop -> return False
1833{-# INLINE_NORMAL stripPrefix #-}
1836 => Stream m a -> Stream m a -> m (Maybe (Stream m a))
1837stripPrefix (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)
1839 go (sa, sb, Nothing) = do
1840 r <- stepa defState sa
1842 Yield x sa' -> go (sa', sb, Just x)
1843 Skip sa' -> go (sa', sb, Nothing)
1844 Stop -> return $ Just (Stream stepb sb)
1846 go (sa, sb, Just x) = do
1847 r <- stepb defState sb
1851 then go (sa, sb', Nothing)
1853 Skip sb' -> go (sa, sb', Just x)
1854 Stop -> return Nothing
1856------------------------------------------------------------------------------
1858------------------------------------------------------------------------------
1860-- | Execute a monadic action for each element of the 'Stream'
1861{-# INLINE_NORMAL mapM_ #-}
1862mapM_ :: Monad m => (a -> m b) -> Stream m a -> m ()
1863mapM_ m = drain . mapM m
1865-------------------------------------------------------------------------------
1866-- Stream transformations using Unfolds
1867-------------------------------------------------------------------------------
1869-- Define a unique structure to use in inspection testing
1870data ConcatMapUState o i =
1872 | ConcatMapUInner o i
1874-- | @concatMapU unfold stream@ uses @unfold@ to map the input stream elements
1875-- to streams and then flattens the generated streams into a single output
1878-- This is like 'concatMap' but uses an unfold with an explicit state to
1879-- generate the stream instead of a 'Stream' type generator. This allows better
1880-- optimization via fusion. This can be many times more efficient than
1883{-# INLINE_NORMAL concatMapU #-}
1884concatMapU :: Monad m => Unfold m a b -> Stream m a -> Stream m b
1885concatMapU (Unfold istep inject) (Stream ostep ost) =
1886 Stream step (ConcatMapUOuter ost)
1888 {-# INLINE_LATE step #-}
1889 step gst (ConcatMapUOuter o) = do
1890 r <- ostep (adaptState gst) o
1894 i `seq` return (Skip (ConcatMapUInner o' i))
1895 Skip o' -> return $ Skip (ConcatMapUOuter o')
1896 Stop -> return $ Stop
1898 step _ (ConcatMapUInner o i) = do
1901 Yield x i' -> Yield x (ConcatMapUInner o i')
1902 Skip i' -> Skip (ConcatMapUInner o i')
1903 Stop -> Skip (ConcatMapUOuter o)
1905data ConcatUnfoldInterleaveState o i =
1906 ConcatUnfoldInterleaveOuter o [i]
1907 | ConcatUnfoldInterleaveInner o [i]
1908 | ConcatUnfoldInterleaveInnerL [i] [i]
1909 | ConcatUnfoldInterleaveInnerR [i] [i]
1911-- XXX use arrays to store state instead of lists.
1912-- XXX In general we can use different scheduling strategies e.g. how to
1913-- schedule the outer vs inner loop or assigning weights to different streams
1914-- or outer and inner loops.
1916-- After a yield, switch to the next stream. Do not switch streams on Skip.
1917-- Yield from outer stream switches to the inner stream.
1919-- There are two choices here, (1) exhaust the outer stream first and then
1920-- start yielding from the inner streams, this is much simpler to implement,
1921-- (2) yield at least one element from an inner stream before going back to
1922-- outer stream and opening the next stream from it.
1924-- Ideally, we need some scheduling bias to inner streams vs outer stream.
1925-- Maybe we can configure the behavior.
1927{-# INLINE_NORMAL concatUnfoldInterleave #-}
1928concatUnfoldInterleave :: Monad m => Unfold m a b -> Stream m a -> Stream m b
1929concatUnfoldInterleave (Unfold istep inject) (Stream ostep ost) =
1930 Stream step (ConcatUnfoldInterleaveOuter ost [])
1932 {-# INLINE_LATE step #-}
1933 step gst (ConcatUnfoldInterleaveOuter o ls) = do
1934 r <- ostep (adaptState gst) o
1938 i `seq` return (Skip (ConcatUnfoldInterleaveInner o' (i : ls)))
1939 Skip o' -> return $ Skip (ConcatUnfoldInterleaveOuter o' ls)
1940 Stop -> return $ Skip (ConcatUnfoldInterleaveInnerL ls [])
1942 step _ (ConcatUnfoldInterleaveInner _ []) = undefined
1943 step _ (ConcatUnfoldInterleaveInner o (st:ls)) = do
1946 Yield x s -> Yield x (ConcatUnfoldInterleaveOuter o (s:ls))
1947 Skip s -> Skip (ConcatUnfoldInterleaveInner o (s:ls))
1948 Stop -> Skip (ConcatUnfoldInterleaveOuter o ls)
1950 step _ (ConcatUnfoldInterleaveInnerL [] []) = return Stop
1951 step _ (ConcatUnfoldInterleaveInnerL [] rs) =
1952 return $ Skip (ConcatUnfoldInterleaveInnerR [] rs)
1954 step _ (ConcatUnfoldInterleaveInnerL (st:ls) rs) = do
1957 Yield x s -> Yield x (ConcatUnfoldInterleaveInnerL ls (s:rs))
1958 Skip s -> Skip (ConcatUnfoldInterleaveInnerL (s:ls) rs)
1959 Stop -> Skip (ConcatUnfoldInterleaveInnerL ls rs)
1961 step _ (ConcatUnfoldInterleaveInnerR [] []) = return Stop
1962 step _ (ConcatUnfoldInterleaveInnerR ls []) =
1963 return $ Skip (ConcatUnfoldInterleaveInnerL ls [])
1965 step _ (ConcatUnfoldInterleaveInnerR ls (st:rs)) = do
1968 Yield x s -> Yield x (ConcatUnfoldInterleaveInnerR (s:ls) rs)
1969 Skip s -> Skip (ConcatUnfoldInterleaveInnerR ls (s:rs))
1970 Stop -> Skip (ConcatUnfoldInterleaveInnerR ls rs)
1972-- XXX In general we can use different scheduling strategies e.g. how to
1973-- schedule the outer vs inner loop or assigning weights to different streams
1974-- or outer and inner loops.
1976-- This could be inefficient if the tasks are too small.
1978-- Compared to concatUnfoldInterleave this one switches streams on Skips.
1980{-# INLINE_NORMAL concatUnfoldRoundrobin #-}
1981concatUnfoldRoundrobin :: Monad m => Unfold m a b -> Stream m a -> Stream m b
1982concatUnfoldRoundrobin (Unfold istep inject) (Stream ostep ost) =
1983 Stream step (ConcatUnfoldInterleaveOuter ost [])
1985 {-# INLINE_LATE step #-}
1986 step gst (ConcatUnfoldInterleaveOuter o ls) = do
1987 r <- ostep (adaptState gst) o
1991 i `seq` return (Skip (ConcatUnfoldInterleaveInner o' (i : ls)))
1992 Skip o' -> return $ Skip (ConcatUnfoldInterleaveInner o' ls)
1993 Stop -> return $ Skip (ConcatUnfoldInterleaveInnerL ls [])
1995 step _ (ConcatUnfoldInterleaveInner o []) =
1996 return $ Skip (ConcatUnfoldInterleaveOuter o [])
1998 step _ (ConcatUnfoldInterleaveInner o (st:ls)) = do
2001 Yield x s -> Yield x (ConcatUnfoldInterleaveOuter o (s:ls))
2002 Skip s -> Skip (ConcatUnfoldInterleaveOuter o (s:ls))
2003 Stop -> Skip (ConcatUnfoldInterleaveOuter o ls)
2005 step _ (ConcatUnfoldInterleaveInnerL [] []) = return Stop
2006 step _ (ConcatUnfoldInterleaveInnerL [] rs) =
2007 return $ Skip (ConcatUnfoldInterleaveInnerR [] rs)
2009 step _ (ConcatUnfoldInterleaveInnerL (st:ls) rs) = do
2012 Yield x s -> Yield x (ConcatUnfoldInterleaveInnerL ls (s:rs))
2013 Skip s -> Skip (ConcatUnfoldInterleaveInnerL ls (s:rs))
2014 Stop -> Skip (ConcatUnfoldInterleaveInnerL ls rs)
2016 step _ (ConcatUnfoldInterleaveInnerR [] []) = return Stop
2017 step _ (ConcatUnfoldInterleaveInnerR ls []) =
2018 return $ Skip (ConcatUnfoldInterleaveInnerL ls [])
2020 step _ (ConcatUnfoldInterleaveInnerR ls (st:rs)) = do
2023 Yield x s -> Yield x (ConcatUnfoldInterleaveInnerR (s:ls) rs)
2024 Skip s -> Skip (ConcatUnfoldInterleaveInnerR (s:ls) rs)
2025 Stop -> Skip (ConcatUnfoldInterleaveInnerR ls rs)
2027data AppendState s1 s2 = AppendFirst s1 | AppendSecond s2
2029-- Note that this could be much faster compared to the CPS stream. However, as
2030-- the number of streams being composed increases this may become expensive.
2031-- Need to see where the breaking point is between the two.
2033{-# INLINE_NORMAL append #-}
2034append :: Monad m => Stream m a -> Stream m a -> Stream m a
2035append (Stream step1 state1) (Stream step2 state2) =
2036 Stream step (AppendFirst state1)
2040 {-# INLINE_LATE step #-}
2041 step gst (AppendFirst st) = do
2044 Yield a s -> Yield a (AppendFirst s)
2045 Skip s -> Skip (AppendFirst s)
2046 Stop -> Skip (AppendSecond state2)
2048 step gst (AppendSecond st) = do
2051 Yield a s -> Yield a (AppendSecond s)
2052 Skip s -> Skip (AppendSecond s)
2055data InterleaveState s1 s2 = InterleaveFirst s1 s2 | InterleaveSecond s1 s2
2056 | InterleaveSecondOnly s2 | InterleaveFirstOnly s1
2058{-# INLINE_NORMAL interleave #-}
2059interleave :: Monad m => Stream m a -> Stream m a -> Stream m a
2060interleave (Stream step1 state1) (Stream step2 state2) =
2061 Stream step (InterleaveFirst state1 state2)
2065 {-# INLINE_LATE step #-}
2066 step gst (InterleaveFirst st1 st2) = do
2069 Yield a s -> Yield a (InterleaveSecond s st2)
2070 Skip s -> Skip (InterleaveFirst s st2)
2071 Stop -> Skip (InterleaveSecondOnly st2)
2073 step gst (InterleaveSecond st1 st2) = do
2076 Yield a s -> Yield a (InterleaveFirst st1 s)
2077 Skip s -> Skip (InterleaveSecond st1 s)
2078 Stop -> Skip (InterleaveFirstOnly st1)
2080 step gst (InterleaveFirstOnly st1) = do
2083 Yield a s -> Yield a (InterleaveFirstOnly s)
2084 Skip s -> Skip (InterleaveFirstOnly s)
2087 step gst (InterleaveSecondOnly st2) = do
2090 Yield a s -> Yield a (InterleaveSecondOnly s)
2091 Skip s -> Skip (InterleaveSecondOnly s)
2094{-# INLINE_NORMAL interleaveMin #-}
2095interleaveMin :: Monad m => Stream m a -> Stream m a -> Stream m a
2096interleaveMin (Stream step1 state1) (Stream step2 state2) =
2097 Stream step (InterleaveFirst state1 state2)
2101 {-# INLINE_LATE step #-}
2102 step gst (InterleaveFirst st1 st2) = do
2105 Yield a s -> Yield a (InterleaveSecond s st2)
2106 Skip s -> Skip (InterleaveFirst s st2)
2109 step gst (InterleaveSecond st1 st2) = do
2112 Yield a s -> Yield a (InterleaveFirst st1 s)
2113 Skip s -> Skip (InterleaveSecond st1 s)
2116 step _ (InterleaveFirstOnly _) = undefined
2117 step _ (InterleaveSecondOnly _) = undefined
2119{-# INLINE_NORMAL interleaveSuffix #-}
2120interleaveSuffix :: Monad m => Stream m a -> Stream m a -> Stream m a
2121interleaveSuffix (Stream step1 state1) (Stream step2 state2) =
2122 Stream step (InterleaveFirst state1 state2)
2126 {-# INLINE_LATE step #-}
2127 step gst (InterleaveFirst st1 st2) = do
2130 Yield a s -> Yield a (InterleaveSecond s st2)
2131 Skip s -> Skip (InterleaveFirst s st2)
2134 step gst (InterleaveSecond st1 st2) = do
2137 Yield a s -> Yield a (InterleaveFirst st1 s)
2138 Skip s -> Skip (InterleaveSecond st1 s)
2139 Stop -> Skip (InterleaveFirstOnly st1)
2141 step gst (InterleaveFirstOnly st1) = do
2144 Yield a s -> Yield a (InterleaveFirstOnly s)
2145 Skip s -> Skip (InterleaveFirstOnly s)
2148 step _ (InterleaveSecondOnly _) = undefined
2150data InterleaveInfixState s1 s2 a
2151 = InterleaveInfixFirst s1 s2
2152 | InterleaveInfixSecondBuf s1 s2
2153 | InterleaveInfixSecondYield s1 s2 a
2154 | InterleaveInfixFirstYield s1 s2 a
2155 | InterleaveInfixFirstOnly s1
2157{-# INLINE_NORMAL interleaveInfix #-}
2158interleaveInfix :: Monad m => Stream m a -> Stream m a -> Stream m a
2159interleaveInfix (Stream step1 state1) (Stream step2 state2) =
2160 Stream step (InterleaveInfixFirst state1 state2)
2164 {-# INLINE_LATE step #-}
2165 step gst (InterleaveInfixFirst st1 st2) = do
2168 Yield a s -> Yield a (InterleaveInfixSecondBuf s st2)
2169 Skip s -> Skip (InterleaveInfixFirst s st2)
2172 step gst (InterleaveInfixSecondBuf st1 st2) = do
2175 Yield a s -> Skip (InterleaveInfixSecondYield st1 s a)
2176 Skip s -> Skip (InterleaveInfixSecondBuf st1 s)
2177 Stop -> Skip (InterleaveInfixFirstOnly st1)
2179 step gst (InterleaveInfixSecondYield st1 st2 x) = do
2182 Yield a s -> Yield x (InterleaveInfixFirstYield s st2 a)
2183 Skip s -> Skip (InterleaveInfixSecondYield s st2 x)
2186 step _ (InterleaveInfixFirstYield st1 st2 x) = do
2187 return $ Yield x (InterleaveInfixSecondBuf st1 st2)
2189 step gst (InterleaveInfixFirstOnly st1) = do
2192 Yield a s -> Yield a (InterleaveInfixFirstOnly s)
2193 Skip s -> Skip (InterleaveInfixFirstOnly s)
2196{-# INLINE_NORMAL roundRobin #-}
2197roundRobin :: Monad m => Stream m a -> Stream m a -> Stream m a
2198roundRobin (Stream step1 state1) (Stream step2 state2) =
2199 Stream step (InterleaveFirst state1 state2)
2203 {-# INLINE_LATE step #-}
2204 step gst (InterleaveFirst st1 st2) = do
2207 Yield a s -> Yield a (InterleaveSecond s st2)
2208 Skip s -> Skip (InterleaveSecond s st2)
2209 Stop -> Skip (InterleaveSecondOnly st2)
2211 step gst (InterleaveSecond st1 st2) = do
2214 Yield a s -> Yield a (InterleaveFirst st1 s)
2215 Skip s -> Skip (InterleaveFirst st1 s)
2216 Stop -> Skip (InterleaveFirstOnly st1)
2218 step gst (InterleaveSecondOnly st2) = do
2221 Yield a s -> Yield a (InterleaveSecondOnly s)
2222 Skip s -> Skip (InterleaveSecondOnly s)
2225 step gst (InterleaveFirstOnly st1) = do
2228 Yield a s -> Yield a (InterleaveFirstOnly s)
2229 Skip s -> Skip (InterleaveFirstOnly s)
2232data ICUState s1 s2 i1 i2 =
2237 | ICUFirstInner s1 s2 i1
2238 | ICUSecondInner s1 s2 i2
2239 | ICUFirstOnlyInner s1 i1
2240 | ICUSecondOnlyInner s2 i2
2242-- | Interleave streams (full streams, not the elements) unfolded from two
2243-- input streams and concat. Stop when the first stream stops. If the second
2244-- stream ends before the first one then first stream still keeps running alone
2245-- without any interleaving with the second stream.
2247-- [a1, a2, ... an] [b1, b2 ...]
2248-- => [streamA1, streamA2, ... streamAn] [streamB1, streamB2, ...]
2249-- => [streamA1, streamB1, streamA2...StreamAn, streamBn]
2250-- => [a11, a12, ...a1j, b11, b12, ...b1k, a21, a22, ...]
2252{-# INLINE_NORMAL gintercalateSuffix #-}
2255 => Unfold m a c -> Stream m a -> Unfold m b c -> Stream m b -> Stream m c
2257 (Unfold istep1 inject1) (Stream step1 state1)
2258 (Unfold istep2 inject2) (Stream step2 state2) =
2259 Stream step (ICUFirst state1 state2)
2263 {-# INLINE_LATE step #-}
2264 step gst (ICUFirst s1 s2) = do
2265 r <- step1 (adaptState gst) s1
2269 i `seq` return (Skip (ICUFirstInner s s2 i))
2270 Skip s -> return $ Skip (ICUFirst s s2)
2273 step gst (ICUFirstOnly s1) = do
2274 r <- step1 (adaptState gst) s1
2278 i `seq` return (Skip (ICUFirstOnlyInner s i))
2279 Skip s -> return $ Skip (ICUFirstOnly s)
2282 step _ (ICUFirstInner s1 s2 i1) = do
2285 Yield x i' -> Yield x (ICUFirstInner s1 s2 i')
2286 Skip i' -> Skip (ICUFirstInner s1 s2 i')
2287 Stop -> Skip (ICUSecond s1 s2)
2289 step _ (ICUFirstOnlyInner s1 i1) = do
2292 Yield x i' -> Yield x (ICUFirstOnlyInner s1 i')
2293 Skip i' -> Skip (ICUFirstOnlyInner s1 i')
2294 Stop -> Skip (ICUFirstOnly s1)
2296 step gst (ICUSecond s1 s2) = do
2297 r <- step2 (adaptState gst) s2
2301 i `seq` return (Skip (ICUSecondInner s1 s i))
2302 Skip s -> return $ Skip (ICUSecond s1 s)
2303 Stop -> return $ Skip (ICUFirstOnly s1)
2305 step _ (ICUSecondInner s1 s2 i2) = do
2308 Yield x i' -> Yield x (ICUSecondInner s1 s2 i')
2309 Skip i' -> Skip (ICUSecondInner s1 s2 i')
2310 Stop -> Skip (ICUFirst s1 s2)
2312 step _ (ICUSecondOnly _s2) = undefined
2313 step _ (ICUSecondOnlyInner _s2 _i2) = undefined
2315data InterposeSuffixState s1 i1 =
2316 InterposeSuffixFirst s1
2317 -- | InterposeSuffixFirstYield s1 i1
2318 | InterposeSuffixFirstInner s1 i1
2319 | InterposeSuffixSecond s1
2321-- Note that if an unfolded layer turns out to be nil we still emit the
2322-- separator effect. An alternate behavior could be to emit the separator
2323-- effect only if at least one element has been yielded by the unfolding.
2324-- However, that becomes a bit complicated, so we have chosen the former
2326{-# INLINE_NORMAL interposeSuffix #-}
2329 => m c -> Unfold m b c -> Stream m b -> Stream m c
2332 (Unfold istep1 inject1) (Stream step1 state1) =
2333 Stream step (InterposeSuffixFirst state1)
2337 {-# INLINE_LATE step #-}
2338 step gst (InterposeSuffixFirst s1) = do
2339 r <- step1 (adaptState gst) s1
2343 i `seq` return (Skip (InterposeSuffixFirstInner s i))
2344 -- i `seq` return (Skip (InterposeSuffixFirstYield s i))
2345 Skip s -> return $ Skip (InterposeSuffixFirst s)
2349 step _ (InterposeSuffixFirstYield s1 i1) = do
2352 Yield x i' -> Yield x (InterposeSuffixFirstInner s1 i')
2353 Skip i' -> Skip (InterposeSuffixFirstYield s1 i')
2354 Stop -> Skip (InterposeSuffixFirst s1)
2357 step _ (InterposeSuffixFirstInner s1 i1) = do
2360 Yield x i' -> Yield x (InterposeSuffixFirstInner s1 i')
2361 Skip i' -> Skip (InterposeSuffixFirstInner s1 i')
2362 Stop -> Skip (InterposeSuffixSecond s1)
2364 step _ (InterposeSuffixSecond s1) = do
2366 return $ Yield r (InterposeSuffixFirst s1)
2368data ICALState s1 s2 i1 i2 a =
2370 -- | ICALFirstYield s1 s2 i1
2371 | ICALFirstInner s1 s2 i1
2373 | ICALFirstOnlyInner s1 i1
2374 | ICALSecondInject s1 s2
2375 | ICALFirstInject s1 s2 i2
2376 -- | ICALFirstBuf s1 s2 i1 i2
2377 | ICALSecondInner s1 s2 i1 i2
2378 -- -- | ICALSecondInner s1 s2 i1 i2 a
2379 -- -- | ICALFirstResume s1 s2 i1 i2 a
2381-- | Interleave streams (full streams, not the elements) unfolded from two
2382-- input streams and concat. Stop when the first stream stops. If the second
2383-- stream ends before the first one then first stream still keeps running alone
2384-- without any interleaving with the second stream.
2386-- [a1, a2, ... an] [b1, b2 ...]
2387-- => [streamA1, streamA2, ... streamAn] [streamB1, streamB2, ...]
2388-- => [streamA1, streamB1, streamA2...StreamAn, streamBn]
2389-- => [a11, a12, ...a1j, b11, b12, ...b1k, a21, a22, ...]
2391{-# INLINE_NORMAL gintercalate #-}
2394 => Unfold m a c -> Stream m a -> Unfold m b c -> Stream m b -> Stream m c
2396 (Unfold istep1 inject1) (Stream step1 state1)
2397 (Unfold istep2 inject2) (Stream step2 state2) =
2398 Stream step (ICALFirst state1 state2)
2402 {-# INLINE_LATE step #-}
2403 step gst (ICALFirst s1 s2) = do
2404 r <- step1 (adaptState gst) s1
2408 i `seq` return (Skip (ICALFirstInner s s2 i))
2409 -- i `seq` return (Skip (ICALFirstYield s s2 i))
2410 Skip s -> return $ Skip (ICALFirst s s2)
2414 step _ (ICALFirstYield s1 s2 i1) = do
2417 Yield x i' -> Yield x (ICALFirstInner s1 s2 i')
2418 Skip i' -> Skip (ICALFirstYield s1 s2 i')
2419 Stop -> Skip (ICALFirst s1 s2)
2422 step _ (ICALFirstInner s1 s2 i1) = do
2425 Yield x i' -> Yield x (ICALFirstInner s1 s2 i')
2426 Skip i' -> Skip (ICALFirstInner s1 s2 i')
2427 Stop -> Skip (ICALSecondInject s1 s2)
2429 step gst (ICALFirstOnly s1) = do
2430 r <- step1 (adaptState gst) s1
2434 i `seq` return (Skip (ICALFirstOnlyInner s i))
2435 Skip s -> return $ Skip (ICALFirstOnly s)
2438 step _ (ICALFirstOnlyInner s1 i1) = do
2441 Yield x i' -> Yield x (ICALFirstOnlyInner s1 i')
2442 Skip i' -> Skip (ICALFirstOnlyInner s1 i')
2443 Stop -> Skip (ICALFirstOnly s1)
2445 -- We inject the second stream even before checking if the first stream
2446 -- would yield any more elements. There is no clear choice whether we
2447 -- should do this before or after that. Doing it after may make the state
2448 -- machine a bit simpler though.
2449 step gst (ICALSecondInject s1 s2) = do
2450 r <- step2 (adaptState gst) s2
2454 i `seq` return (Skip (ICALFirstInject s1 s i))
2455 Skip s -> return $ Skip (ICALSecondInject s1 s)
2456 Stop -> return $ Skip (ICALFirstOnly s1)
2458 step gst (ICALFirstInject s1 s2 i2) = do
2459 r <- step1 (adaptState gst) s1
2463 i `seq` return (Skip (ICALSecondInner s s2 i i2))
2464 -- i `seq` return (Skip (ICALFirstBuf s s2 i i2))
2465 Skip s -> return $ Skip (ICALFirstInject s s2 i2)
2469 step _ (ICALFirstBuf s1 s2 i1 i2) = do
2472 Yield x i' -> Skip (ICALSecondInner s1 s2 i' i2 x)
2473 Skip i' -> Skip (ICALFirstBuf s1 s2 i' i2)
2476 step _ (ICALSecondInner s1 s2 i1 i2 v) = do
2479 Yield x i' -> Yield x (ICALSecondInner s1 s2 i1 i' v)
2480 Skip i' -> Skip (ICALSecondInner s1 s2 i1 i' v)
2481 Stop -> Skip (ICALFirstResume s1 s2 i1 i2 v)
2484 step _ (ICALSecondInner s1 s2 i1 i2) = do
2487 Yield x i' -> Yield x (ICALSecondInner s1 s2 i1 i')
2488 Skip i' -> Skip (ICALSecondInner s1 s2 i1 i')
2489 Stop -> Skip (ICALFirstInner s1 s2 i1)
2490 -- Stop -> Skip (ICALFirstResume s1 s2 i1 i2)
2493 step _ (ICALFirstResume s1 s2 i1 i2 x) = do
2494 return $ Yield x (ICALFirstInner s1 s2 i1 i2)
2497data InterposeState s1 i1 a =
2499 -- | InterposeFirstYield s1 i1
2500 | InterposeFirstInner s1 i1
2501 | InterposeFirstInject s1
2502 -- | InterposeFirstBuf s1 i1
2503 | InterposeSecondYield s1 i1
2504 -- -- | InterposeSecondYield s1 i1 a
2505 -- -- | InterposeFirstResume s1 i1 a
2507-- Note that this only interposes the pure values, we may run many effects to
2508-- generate those values as some effects may not generate anything (Skip).
2509{-# INLINE_NORMAL interpose #-}
2510interpose :: Monad m => m c -> Unfold m b c -> Stream m b -> Stream m c
2513 (Unfold istep1 inject1) (Stream step1 state1) =
2514 Stream step (InterposeFirst state1)
2518 {-# INLINE_LATE step #-}
2519 step gst (InterposeFirst s1) = do
2520 r <- step1 (adaptState gst) s1
2524 i `seq` return (Skip (InterposeFirstInner s i))
2525 -- i `seq` return (Skip (InterposeFirstYield s i))
2526 Skip s -> return $ Skip (InterposeFirst s)
2530 step _ (InterposeFirstYield s1 i1) = do
2533 Yield x i' -> Yield x (InterposeFirstInner s1 i')
2534 Skip i' -> Skip (InterposeFirstYield s1 i')
2535 Stop -> Skip (InterposeFirst s1)
2538 step _ (InterposeFirstInner s1 i1) = do
2541 Yield x i' -> Yield x (InterposeFirstInner s1 i')
2542 Skip i' -> Skip (InterposeFirstInner s1 i')
2543 Stop -> Skip (InterposeFirstInject s1)
2545 step gst (InterposeFirstInject s1) = do
2546 r <- step1 (adaptState gst) s1
2550 -- i `seq` return (Skip (InterposeFirstBuf s i))
2551 i `seq` return (Skip (InterposeSecondYield s i))
2552 Skip s -> return $ Skip (InterposeFirstInject s)
2556 step _ (InterposeFirstBuf s1 i1) = do
2559 Yield x i' -> Skip (InterposeSecondYield s1 i' x)
2560 Skip i' -> Skip (InterposeFirstBuf s1 i')
2565 step _ (InterposeSecondYield s1 i1 v) = do
2567 return $ Yield r (InterposeFirstResume s1 i1 v)
2569 step _ (InterposeSecondYield s1 i1) = do
2571 return $ Yield r (InterposeFirstInner s1 i1)
2574 step _ (InterposeFirstResume s1 i1 v) = do
2575 return $ Yield v (InterposeFirstInner s1 i1)
2578------------------------------------------------------------------------------
2580------------------------------------------------------------------------------
2582data GbracketState s1 s2 v
2584 | GBracketNormal s1 v
2585 | GBracketException s2
2587-- | The most general bracketing and exception combinator. All other
2588-- combinators can be expressed in terms of this combinator. This can also be
2589-- used for cases which are not covered by the standard combinators.
2593{-# INLINE_NORMAL gbracket #-}
2597 -> (forall s. m s -> m (Either e s)) -- ^ try (exception handling)
2598 -> (c -> m d) -- ^ after, on normal stop
2599 -> (c -> e -> Stream m b) -- ^ on exception
2600 -> (c -> Stream m b) -- ^ stream generator
2602gbracket bef exc aft fexc fnormal =
2603 Stream step GBracketInit
2607 {-# INLINE_LATE step #-}
2608 step _ GBracketInit = do
2610 return $ Skip $ GBracketNormal (fnormal r) r
2612 step gst (GBracketNormal (UnStream step1 st) v) = do
2613 res <- exc $ step1 gst st
2615 Right r -> case r of
2617 return $ Yield x (GBracketNormal (Stream step1 s) v)
2618 Skip s -> return $ Skip (GBracketNormal (Stream step1 s) v)
2619 Stop -> aft v >> return Stop
2620 Left e -> return $ Skip (GBracketException (fexc v e))
2621 step gst (GBracketException (UnStream step1 st)) = do
2624 Yield x s -> return $ Yield x (GBracketException (Stream step1 s))
2625 Skip s -> return $ Skip (GBracketException (Stream step1 s))
2628-- | Run a side effect before the stream yields its first element.
2629{-# INLINE_NORMAL before #-}
2630before :: Monad m => m b -> Stream m a -> Stream m a
2631before action (Stream step state) = Stream step' Nothing
2635 {-# INLINE_LATE step' #-}
2636 step' _ Nothing = action >> return (Skip (Just state))
2638 step' gst (Just st) = do
2641 Yield x s -> return $ Yield x (Just s)
2642 Skip s -> return $ Skip (Just s)
2645-- | Run a side effect whenever the stream stops normally.
2646{-# INLINE_NORMAL after #-}
2647after :: Monad m => m b -> Stream m a -> Stream m a
2648after action (Stream step state) = Stream step' state
2652 {-# INLINE_LATE step' #-}
2656 Yield x s -> return $ Yield x s
2657 Skip s -> return $ Skip s
2658 Stop -> action >> return Stop
2660-- XXX These combinators are expensive due to the call to
2661-- onException/handle/try on each step. Therefore, when possible, they should
2662-- be called in an outer loop where we perform less iterations. For example, we
2663-- cannot call them on each iteration in a char stream, instead we can call
2664-- them when doing an IO on an array.
2666-- XXX For high performance error checks in busy streams we may need another
2667-- Error constructor in step.
2669-- | Run a side effect whenever the stream aborts due to an exception. The
2670-- exception is not caught, simply rethrown.
2671{-# INLINE_NORMAL onException #-}
2672onException :: MonadCatch m => m b -> Stream m a -> Stream m a
2673onException action str =
2674 gbracket (return ()) MC.try return
2675 (\_ (_ :: MC.SomeException) -> nilM $ action)
2678{-# INLINE_NORMAL _onException #-}
2679_onException :: MonadCatch m => m b -> Stream m a -> Stream m a
2680_onException action (Stream step state) = Stream step' state
2684 {-# INLINE_LATE step' #-}
2686 res <- step gst st `MC.onException` action
2688 Yield x s -> return $ Yield x s
2689 Skip s -> return $ Skip s
2692-- XXX bracket is like concatMap, it generates a stream and then flattens it.
2693-- Like concatMap it has 10x worse performance compared to linear fused
2696-- | Run the first action before the stream starts and remember its output,
2697-- generate a stream using the output, run the second action providing the
2698-- remembered value as an argument whenever the stream ends normally or due to
2700{-# INLINE_NORMAL bracket #-}
2701bracket :: MonadCatch m => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a
2702bracket bef aft bet =
2703 gbracket bef MC.try aft (\a (_ :: SomeException) -> nilM $ aft a) bet
2705data BracketState s v = BracketInit | BracketRun s v
2707{-# INLINE_NORMAL _bracket #-}
2708_bracket :: MonadCatch m => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a
2709_bracket bef aft bet = Stream step' BracketInit
2713 {-# INLINE_LATE step' #-}
2714 step' _ BracketInit = bef >>= \x -> return (Skip (BracketRun (bet x) x))
2716 -- NOTE: It is important to use UnStream instead of the Stream pattern
2717 -- here, otherwise we get huge perf degradation, see note in concatMap.
2718 step' gst (BracketRun (UnStream step state) v) = do
2719 -- res <- step gst state `MC.onException` aft v
2720 res <- MC.try $ step gst state
2722 Left (_ :: SomeException) -> aft v >> return Stop
2723 Right r -> case r of
2724 Yield x s -> return $ Yield x (BracketRun (Stream step s) v)
2725 Skip s -> return $ Skip (BracketRun (Stream step s) v)
2726 Stop -> aft v >> return Stop
2728-- | Run a side effect whenever the stream stops normally or aborts due to an
2730{-# INLINE finally #-}
2731finally :: MonadCatch m => m b -> Stream m a -> Stream m a
2732-- finally action xs = after action $ onException action xs
2733finally action xs = bracket (return ()) (\_ -> action) (const xs)
2735-- | When evaluating a stream if an exception occurs, stream evaluation aborts
2736-- and the specified exception handler is run with the exception as argument.
2737{-# INLINE_NORMAL handle #-}
2738handle :: (MonadCatch m, Exception e)
2739 => (e -> Stream m a) -> Stream m a -> Stream m a
2741 gbracket (return ()) MC.try return (\_ e -> f e) (\_ -> str)
2743{-# INLINE_NORMAL _handle #-}
2744_handle :: (MonadCatch m, Exception e)
2745 => (e -> Stream m a) -> Stream m a -> Stream m a
2746_handle f (Stream step state) = Stream step' (Left state)
2750 {-# INLINE_LATE step' #-}
2751 step' gst (Left st) = do
2752 res <- MC.try $ step gst st
2754 Left e -> return $ Skip $ Right (f e)
2755 Right r -> case r of
2756 Yield x s -> return $ Yield x (Left s)
2757 Skip s -> return $ Skip (Left s)
2760 step' gst (Right (UnStream step1 st)) = do
2763 Yield x s -> return $ Yield x (Right (Stream step1 s))
2764 Skip s -> return $ Skip (Right (Stream step1 s))
2767-------------------------------------------------------------------------------
2768-- General transformation
2769-------------------------------------------------------------------------------
2771{-# INLINE_NORMAL transform #-}
2772transform :: Monad m => Pipe m a b -> Stream m a -> Stream m b
2773transform (Pipe pstep1 pstep2 pstate) (Stream step state) =
2774 Stream step' (Consume pstate, state)
2778 {-# INLINE_LATE step' #-}
2780 step' gst (Consume pst, st) = pst `seq` do
2781 r <- step (adaptState gst) st
2786 Pipe.Yield b pst' -> return $ Yield b (pst', s)
2787 Pipe.Continue pst' -> return $ Skip (pst', s)
2788 Skip s -> return $ Skip (Consume pst, s)
2791 step' _ (Produce pst, st) = pst `seq` do
2794 Pipe.Yield b pst' -> return $ Yield b (pst', st)
2795 Pipe.Continue pst' -> return $ Skip (pst', st)
2797------------------------------------------------------------------------------
2798-- Transformation by Folding (Scans)
2799------------------------------------------------------------------------------
2801------------------------------------------------------------------------------
2803------------------------------------------------------------------------------
2805-- XXX Is a prescan useful, discarding the last step does not sound useful? I
2806-- am not sure about the utility of this function, so this is implemented but
2807-- not exposed. We can expose it if someone provides good reasons why this is
2810-- XXX We have to execute the stream one step ahead to know that we are at the
2811-- last step. The vector implementation of prescan executes the last fold step
2812-- but does not yield the result. This means we have executed the effect but
2813-- discarded value. This does not sound right. In this implementation we are
2814-- not executing the last fold step.
2815{-# INLINE_NORMAL prescanlM' #-}
2816prescanlM' :: Monad m => (b -> a -> m b) -> m b -> Stream m a -> Stream m b
2817prescanlM' f mz (Stream step state) = Stream step' (state, mz)
2819 {-# INLINE_LATE step' #-}
2820 step' gst (st, prev) = do
2821 r <- step (adaptState gst) st
2825 return $ Yield acc (s, f acc x)
2826 Skip s -> return $ Skip (s, prev)
2829{-# INLINE prescanl' #-}
2830prescanl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b
2831prescanl' f z = prescanlM' (\a b -> return (f a b)) (return z)
2833------------------------------------------------------------------------------
2834-- Monolithic postscans (postscan followed by a map)
2835------------------------------------------------------------------------------
2837-- The performance of a modular postscan followed by a map seems to be
2838-- equivalent to this monolithic scan followed by map therefore we may not need
2839-- this implementation. We just have it for performance comparison and in case
2840-- modular version does not perform well in some situation.
2842{-# INLINE_NORMAL postscanlMx' #-}
2843postscanlMx' :: Monad m
2844 => (x -> a -> m x) -> m x -> (x -> m b) -> Stream m a -> Stream m b
2845postscanlMx' fstep begin done (Stream step state) = do
2846 Stream step' (state, begin)
2848 {-# INLINE_LATE step' #-}
2849 step' gst (st, acc) = do
2850 r <- step (adaptState gst) st
2856 v `seq` y `seq` return (Yield v (s, return y))
2857 Skip s -> return $ Skip (s, acc)
2860{-# INLINE_NORMAL postscanlx' #-}
2861postscanlx' :: Monad m
2862 => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> Stream m b
2863postscanlx' fstep begin done s =
2864 postscanlMx' (\b a -> return (fstep b a)) (return begin) (return . done) s
2866-- XXX do we need consM strict to evaluate the begin value?
2867{-# INLINE scanlMx' #-}
2869 => (x -> a -> m x) -> m x -> (x -> m b) -> Stream m a -> Stream m b
2870scanlMx' fstep begin done s =
2871 (begin >>= \x -> x `seq` done x) `consM` postscanlMx' fstep begin done s
2873{-# INLINE scanlx' #-}
2875 => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> Stream m b
2876scanlx' fstep begin done s =
2877 scanlMx' (\b a -> return (fstep b a)) (return begin) (return . done) s
2879------------------------------------------------------------------------------
2881------------------------------------------------------------------------------
2883{-# INLINE_NORMAL postscanlM' #-}
2884postscanlM' :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
2885postscanlM' fstep begin (Stream step state) =
2886 begin `seq` Stream step' (state, begin)
2888 {-# INLINE_LATE step' #-}
2889 step' gst (st, acc) = acc `seq` do
2890 r <- step (adaptState gst) st
2894 y `seq` return (Yield y (s, y))
2895 Skip s -> return $ Skip (s, acc)
2898{-# INLINE_NORMAL postscanl' #-}
2899postscanl' :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a
2900postscanl' f = postscanlM' (\a b -> return (f a b))
2902{-# INLINE_NORMAL postscanlM #-}
2903postscanlM :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
2904postscanlM fstep begin (Stream step state) = Stream step' (state, begin)
2906 {-# INLINE_LATE step' #-}
2907 step' gst (st, acc) = do
2908 r <- step (adaptState gst) st
2912 return (Yield y (s, y))
2913 Skip s -> return $ Skip (s, acc)
2916{-# INLINE_NORMAL postscanl #-}
2917postscanl :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a
2918postscanl f = postscanlM (\a b -> return (f a b))
2920{-# INLINE_NORMAL scanlM' #-}
2921scanlM' :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
2922scanlM' fstep begin s = begin `seq` (begin `cons` postscanlM' fstep begin s)
2924{-# INLINE scanl' #-}
2925scanl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b
2926scanl' f = scanlM' (\a b -> return (f a b))
2928{-# INLINE_NORMAL scanlM #-}
2929scanlM :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
2930scanlM fstep begin s = begin `cons` postscanlM fstep begin s
2933scanl :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b
2934scanl f = scanlM (\a b -> return (f a b))
2936{-# INLINE_NORMAL scanl1M #-}
2937scanl1M :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a
2938scanl1M fstep (Stream step state) = Stream step' (state, Nothing)
2940 {-# INLINE_LATE step' #-}
2941 step' gst (st, Nothing) = do
2944 Yield x s -> return $ Yield x (s, Just x)
2945 Skip s -> return $ Skip (s, Nothing)
2948 step' gst (st, Just acc) = do
2953 return $ Yield z (s, Just z)
2954 Skip s -> return $ Skip (s, Just acc)
2957{-# INLINE scanl1 #-}
2958scanl1 :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a
2959scanl1 f = scanl1M (\x y -> return (f x y))
2961{-# INLINE_NORMAL scanl1M' #-}
2962scanl1M' :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a
2963scanl1M' fstep (Stream step state) = Stream step' (state, Nothing)
2965 {-# INLINE_LATE step' #-}
2966 step' gst (st, Nothing) = do
2969 Yield x s -> x `seq` return $ Yield x (s, Just x)
2970 Skip s -> return $ Skip (s, Nothing)
2973 step' gst (st, Just acc) = acc `seq` do
2978 z `seq` return $ Yield z (s, Just z)
2979 Skip s -> return $ Skip (s, Just acc)
2982{-# INLINE scanl1' #-}
2983scanl1' :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a
2984scanl1' f = scanl1M' (\x y -> return (f x y))
2987tap :: Monad m => Fold m a b -> Stream m a -> Stream m a
2988tap (Fold fstep initial extract) (Stream step state) = Stream step' Nothing
2992 step' _ Nothing = do
2994 return $ Skip (Just (r, state))
2996 step' gst (Just (acc, st)) = do
3001 return $ Yield x (Just (acc', s))
3002 Skip s -> return $ Skip (Just (acc, s))
3007-------------------------------------------------------------------------------
3009-------------------------------------------------------------------------------
3011{-# INLINE_NORMAL takeWhileM #-}
3012takeWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a
3013takeWhileM f (Stream step state) = Stream step' state
3015 {-# INLINE_LATE step' #-}
3021 return $ if b then Yield x s else Stop
3022 Skip s -> return $ Skip s
3025{-# INLINE takeWhile #-}
3026takeWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
3027takeWhile f = takeWhileM (return . f)
3029{-# INLINE_NORMAL drop #-}
3030drop :: Monad m => Int -> Stream m a -> Stream m a
3031drop n (Stream step state) = Stream step' (state, Just n)
3033 {-# INLINE_LATE step' #-}
3034 step' gst (st, Just i)
3039 Yield _ s -> Skip (s, Just (i - 1))
3040 Skip s -> Skip (s, Just i)
3042 | otherwise = return $ Skip (st, Nothing)
3044 step' gst (st, Nothing) = do
3048 Yield x s -> Yield x (s, Nothing)
3049 Skip s -> Skip (s, Nothing)
3052data DropWhileState s a
3054 | DropWhileYield a s
3057{-# INLINE_NORMAL dropWhileM #-}
3058dropWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a
3059dropWhileM f (Stream step state) = Stream step' (DropWhileDrop state)
3061 {-# INLINE_LATE step' #-}
3062 step' gst (DropWhileDrop st) = do
3068 then return $ Skip (DropWhileDrop s)
3069 else return $ Skip (DropWhileYield x s)
3070 Skip s -> return $ Skip (DropWhileDrop s)
3073 step' gst (DropWhileNext st) = do
3076 Yield x s -> return $ Skip (DropWhileYield x s)
3077 Skip s -> return $ Skip (DropWhileNext s)
3080 step' _ (DropWhileYield x st) = return $ Yield x (DropWhileNext st)
3082{-# INLINE dropWhile #-}
3083dropWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
3084dropWhile f = dropWhileM (return . f)
3086{-# INLINE_NORMAL filterM #-}
3087filterM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a
3088filterM f (Stream step state) = Stream step' state
3090 {-# INLINE_LATE step' #-}
3099 Skip s -> return $ Skip s
3102{-# INLINE filter #-}
3103filter :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
3104filter f = filterM (return . f)
3106{-# INLINE_NORMAL uniq #-}
3107uniq :: (Eq a, Monad m) => Stream m a -> Stream m a
3108uniq (Stream step state) = Stream step' (Nothing, state)
3110 {-# INLINE_LATE step' #-}
3111 step' gst (Nothing, st) = do
3114 Yield x s -> return $ Yield x (Just x, s)
3115 Skip s -> return $ Skip (Nothing, s)
3117 step' gst (Just x, st) = do
3120 Yield y s | x == y -> return $ Skip (Just x, s)
3121 | otherwise -> return $ Yield y (Just y, s)
3122 Skip s -> return $ Skip (Just x, s)
3125------------------------------------------------------------------------------
3126-- Transformation by Mapping
3127------------------------------------------------------------------------------
3129{-# INLINE_NORMAL sequence #-}
3130sequence :: Monad m => Stream m (m a) -> Stream m a
3131sequence (Stream step state) = Stream step' state
3133 {-# INLINE_LATE step' #-}
3135 r <- step (adaptState gst) st
3137 Yield x s -> x >>= \a -> return (Yield a s)
3138 Skip s -> return $ Skip s
3141------------------------------------------------------------------------------
3143------------------------------------------------------------------------------
3145data LoopState x s = FirstYield s
3146 | InterspersingYield s
3149{-# INLINE_NORMAL intersperseM #-}
3150intersperseM :: Monad m => m a -> Stream m a -> Stream m a
3151intersperseM m (Stream step state) = Stream step' (FirstYield state)
3153 {-# INLINE_LATE step' #-}
3154 step' gst (FirstYield st) = do
3158 Yield x s -> Skip (YieldAndCarry x s)
3159 Skip s -> Skip (FirstYield s)
3162 step' gst (InterspersingYield st) = do
3167 return $ Yield a (YieldAndCarry x s)
3168 Skip s -> return $ Skip $ InterspersingYield s
3171 step' _ (YieldAndCarry x st) = return $ Yield x (InterspersingYield st)
3176 | SuffixYield a (SuffixState s a)
3178{-# INLINE_NORMAL intersperseSuffix #-}
3179intersperseSuffix :: forall m a. Monad m => m a -> Stream m a -> Stream m a
3180intersperseSuffix action (Stream step state) = Stream step' (SuffixElem state)
3182 {-# INLINE_LATE step' #-}
3183 step' gst (SuffixElem st) = do
3186 Yield x s -> Skip (SuffixYield x (SuffixSuffix s))
3187 Skip s -> Skip (SuffixElem s)
3190 step' _ (SuffixSuffix st) = do
3191 action >>= \r -> return $ Skip (SuffixYield r (SuffixElem st))
3193 step' _ (SuffixYield x next) = return $ Yield x next
3195{-# INLINE intersperse #-}
3196intersperse :: Monad m => a -> Stream m a -> Stream m a
3197intersperse a = intersperseM (return a)
3199{-# INLINE_NORMAL insertBy #-}
3200insertBy :: Monad m => (a -> a -> Ordering) -> a -> Stream m a -> Stream m a
3201insertBy cmp a (Stream step state) = Stream step' (state, False, Nothing)
3203 {-# INLINE_LATE step' #-}
3204 step' gst (st, False, _) = do
3207 Yield x s -> case cmp a x of
3208 GT -> return $ Yield x (s, False, Nothing)
3209 _ -> return $ Yield a (s, True, Just x)
3210 Skip s -> return $ Skip (s, False, Nothing)
3211 Stop -> return $ Yield a (st, True, Nothing)
3213 step' _ (_, True, Nothing) = return Stop
3215 step' gst (st, True, Just prev) = do
3218 Yield x s -> return $ Yield prev (s, True, Just x)
3219 Skip s -> return $ Skip (s, True, Just prev)
3220 Stop -> return $ Yield prev (st, True, Nothing)
3222------------------------------------------------------------------------------
3224------------------------------------------------------------------------------
3226{-# INLINE_NORMAL deleteBy #-}
3227deleteBy :: Monad m => (a -> a -> Bool) -> a -> Stream m a -> Stream m a
3228deleteBy eq x (Stream step state) = Stream step' (state, False)
3230 {-# INLINE_LATE step' #-}
3231 step' gst (st, False) = do
3234 Yield y s -> return $
3235 if eq x y then Skip (s, True) else Yield y (s, False)
3236 Skip s -> return $ Skip (s, False)
3239 step' gst (st, True) = do
3242 Yield y s -> return $ Yield y (s, True)
3243 Skip s -> return $ Skip (s, True)
3246------------------------------------------------------------------------------
3247-- Transformation by Map and Filter
3248------------------------------------------------------------------------------
3250-- XXX Will this always fuse properly?
3251{-# INLINE_NORMAL mapMaybe #-}
3252mapMaybe :: Monad m => (a -> Maybe b) -> Stream m a -> Stream m b
3253mapMaybe f = fmap fromJust . filter isJust . map f
3255{-# INLINE_NORMAL mapMaybeM #-}
3256mapMaybeM :: Monad m => (a -> m (Maybe b)) -> Stream m a -> Stream m b
3257mapMaybeM f = fmap fromJust . filter isJust . mapM f
3259------------------------------------------------------------------------------
3261------------------------------------------------------------------------------
3263{-# INLINE_NORMAL indexed #-}
3264indexed :: Monad m => Stream m a -> Stream m (Int, a)
3265indexed (Stream step state) = Stream step' (state, 0)
3267 {-# INLINE_LATE step' #-}
3268 step' gst (st, i) = i `seq` do
3269 r <- step (adaptState gst) st
3271 Yield x s -> return $ Yield (i, x) (s, i+1)
3272 Skip s -> return $ Skip (s, i)
3275{-# INLINE_NORMAL indexedR #-}
3276indexedR :: Monad m => Int -> Stream m a -> Stream m (Int, a)
3277indexedR m (Stream step state) = Stream step' (state, m)
3279 {-# INLINE_LATE step' #-}
3280 step' gst (st, i) = i `seq` do
3281 r <- step (adaptState gst) st
3283 Yield x s -> let i' = i - 1
3284 in return $ Yield (i, x) (s, i')
3285 Skip s -> return $ Skip (s, i)
3288{-# INLINE_NORMAL zipWithM #-}
3290 => (a -> b -> m c) -> Stream m a -> Stream m b -> Stream m c
3291zipWithM f (Stream stepa ta) (Stream stepb tb) = Stream step (ta, tb, Nothing)
3293 {-# INLINE_LATE step #-}
3294 step gst (sa, sb, Nothing) = do
3295 r <- stepa (adaptState gst) sa
3298 Yield x sa' -> Skip (sa', sb, Just x)
3299 Skip sa' -> Skip (sa', sb, Nothing)
3302 step gst (sa, sb, Just x) = do
3303 r <- stepb (adaptState gst) sb
3307 return $ Yield z (sa, sb', Nothing)
3308 Skip sb' -> return $ Skip (sa, sb', Just x)
3311#if __GLASGOW_HASKELL__ >= 801
3312{-# RULES "zipWithM xs xs"
3313 forall f xs. zipWithM @Identity f xs xs = mapM (\x -> f x x) xs #-}
3316{-# INLINE zipWith #-}
3317zipWith :: Monad m => (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c
3318zipWith f = zipWithM (\a b -> return (f a b))
3320------------------------------------------------------------------------------
3322------------------------------------------------------------------------------
3324{-# INLINE_NORMAL mergeByM #-}
3327 => (a -> a -> m Ordering) -> Stream m a -> Stream m a -> Stream m a
3328mergeByM cmp (Stream stepa ta) (Stream stepb tb) =
3329 Stream step (Just ta, Just tb, Nothing, Nothing)
3331 {-# INLINE_LATE step #-}
3333 -- one of the values is missing, and the corresponding stream is running
3334 step gst (Just sa, sb, Nothing, b) = do
3337 Yield a sa' -> Skip (Just sa', sb, Just a, b)
3338 Skip sa' -> Skip (Just sa', sb, Nothing, b)
3339 Stop -> Skip (Nothing, sb, Nothing, b)
3341 step gst (sa, Just sb, a, Nothing) = do
3344 Yield b sb' -> Skip (sa, Just sb', a, Just b)
3345 Skip sb' -> Skip (sa, Just sb', a, Nothing)
3346 Stop -> Skip (sa, Nothing, a, Nothing)
3348 -- both the values are available
3349 step _ (sa, sb, Just a, Just b) = do
3351 return $ case res of
3352 GT -> Yield b (sa, sb, Just a, Nothing)
3353 _ -> Yield a (sa, sb, Nothing, Just b)
3355 -- one of the values is missing, corresponding stream is done
3356 step _ (Nothing, sb, Nothing, Just b) =
3357 return $ Yield b (Nothing, sb, Nothing, Nothing)
3359 step _ (sa, Nothing, Just a, Nothing) =
3360 return $ Yield a (sa, Nothing, Nothing, Nothing)
3362 step _ (Nothing, Nothing, Nothing, Nothing) = return Stop
3364{-# INLINE mergeBy #-}
3367 => (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a
3368mergeBy cmp = mergeByM (\a b -> return $ cmp a b)
3370------------------------------------------------------------------------------
3371-- Transformation comprehensions
3372------------------------------------------------------------------------------
3374{-# INLINE_NORMAL the #-}
3375the :: (Eq a, Monad m) => Stream m a -> m (Maybe a)
3376the (Stream step state) = go state
3379 r <- step defState st
3381 Yield x s -> go' x s
3383 Stop -> return Nothing
3385 r <- step defState st
3387 Yield x s | x == n -> go' n s
3388 | otherwise -> return Nothing
3390 Stop -> return (Just n)
3392--------------------------------------------------------------------------------
3393-- UTF8 Encoding / Decoding
3394--------------------------------------------------------------------------------
3396-- UTF-8 primitives, Lifted from GHC.IO.Encoding.UTF8.
3399ord2 :: Char -> WList
3400ord2 c = assert (n >= 0x80 && n <= 0x07ff) (WCons x1 (WCons x2 WNil))
3403 x1 = fromIntegral $ (n `shiftR` 6) + 0xC0
3404 x2 = fromIntegral $ (n .&. 0x3F) + 0x80
3407ord3 :: Char -> WList
3408ord3 c = assert (n >= 0x0800 && n <= 0xffff) (WCons x1 (WCons x2 (WCons x3 WNil)))
3411 x1 = fromIntegral $ (n `shiftR` 12) + 0xE0
3412 x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
3413 x3 = fromIntegral $ (n .&. 0x3F) + 0x80
3416ord4 :: Char -> WList
3417ord4 c = assert (n >= 0x10000) (WCons x1 (WCons x2 (WCons x3 (WCons x4 WNil))))
3420 x1 = fromIntegral $ (n `shiftR` 18) + 0xF0
3421 x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80
3422 x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
3423 x4 = fromIntegral $ (n .&. 0x3F) + 0x80
3425data CodingFailureMode
3426 = TransliterateCodingFailure
3427 | ErrorOnCodingFailure
3430{-# INLINE replacementChar #-}
3431replacementChar :: Char
3432replacementChar = '\xFFFD'
3434-- Int helps in cheaper conversion from Int to Char
3436type DecodeState = Word8
3438-- See http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ for details.
3440{-# INLINE runFold #-}
3441runFold :: (Monad m) => Fold m a b -> Stream m a -> m b
3442runFold (Fold step begin done) = foldlMx' step begin done
3444-- XXX Use names decodeSuccess = 0, decodeFailure = 12
3446-- Aligning to cacheline makes a barely noticeable difference
3447utf8d :: A.Array Word8
3448utf8d = unsafePerformIO $ runFold (A.writeAligned 64) $ fromList [
3449 -- The first part of the table maps bytes to character classes that
3450 -- to reduce the size of the transition table and create bitmasks.
3451 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
3452 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
3453 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
3454 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
3455 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,
3456 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,
3457 8,8,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,
3458 10,3,3,3,3,3,3,3,3,3,3,3,3,4,3,3, 11,6,6,6,5,8,8,8,8,8,8,8,8,8,8,8,
3460 -- The second part is a transition table that maps a combination
3461 -- of a state of the automaton and a character class to a state.
3462 0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12,
3463 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,
3464 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,
3465 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,
3466 12,36,12,12,12,12,12,12,12,12,12,12
3469-- | Return element at the specified index without checking the bounds.
3470-- and without touching the foreign ptr.
3471{-# INLINE_NORMAL unsafePeekElemOff #-}
3472unsafePeekElemOff :: forall a. Storable a => Ptr a -> Int -> a
3473unsafePeekElemOff p i = let !x = A.unsafeInlineIO $ peekElemOff p i in x
3475-- decode is split into two separate cases to avoid branching instructions.
3476-- From the higher level flow we already know which case we are in so we can
3477-- call the appropriate decode function.
3479-- When the state is 0
3480{-# INLINE decode0 #-}
3481decode0 :: Ptr Word8 -> Word8 -> Tuple' DecodeState CodePoint
3483 let !t = table `unsafePeekElemOff` fromIntegral byte
3484 !codep' = (0xff `shiftR` (fromIntegral t)) .&. fromIntegral byte
3485 !state' = table `unsafePeekElemOff` (256 + fromIntegral t)
3486 in (Tuple' state' codep')
3488-- When the state is not 0
3489{-# INLINE decode1 #-}
3495 -> Tuple' DecodeState CodePoint
3496decode1 table state codep byte =
3497 -- Remember codep is Int type!
3498 -- Can it be unsafe to convert the resulting to Char?
3499 let !t = table `unsafePeekElemOff` fromIntegral byte
3500 !codep' = (fromIntegral byte .&. 0x3f) .|. (codep `shiftL` 6)
3501 !state' = table `unsafePeekElemOff`
3502 (256 + fromIntegral state + fromIntegral t)
3503 in (Tuple' state' codep')
3505-- We can divide the errors in three general categories:
3506-- * A non-starter was encountered in a begin state
3507-- * A starter was encountered without completing a codepoint
3508-- * The last codepoint was not complete (input underflow)
3510data DecodeError = DecodeError !DecodeState !CodePoint deriving Show
3513 = FreshPointDecodeInit s
3514 | FreshPointDecodeInit1 s Word8
3515 | FreshPointDecodeFirst s Word8
3516 | FreshPointDecoding s !DecodeState !CodePoint
3517 | YieldAndContinue a (FreshPoint s a)
3520-- XXX Add proper error messages
3521-- XXX Implement this in terms of decodeUtf8Either
3522{-# INLINE_NORMAL decodeUtf8With #-}
3523decodeUtf8With :: Monad m => CodingFailureMode -> Stream m Word8 -> Stream m Char
3524decodeUtf8With cfm (Stream step state) =
3525 let Array p _ _ = utf8d
3526 !ptr = (unsafeForeignPtrToPtr p)
3527 in Stream (step' ptr) (FreshPointDecodeInit state)
3529 {-# INLINE transliterateOrError #-}
3530 transliterateOrError e s =
3532 ErrorOnCodingFailure -> error e
3533 TransliterateCodingFailure -> YieldAndContinue replacementChar s
3534 {-# INLINE inputUnderflow #-}
3537 ErrorOnCodingFailure ->
3538 error "Streamly.Streams.StreamD.decodeUtf8With: Input Underflow"
3539 TransliterateCodingFailure -> YieldAndContinue replacementChar Done
3540 {-# INLINE_LATE step' #-}
3541 step' _ gst (FreshPointDecodeInit st) = do
3542 r <- step (adaptState gst) st
3544 Yield x s -> Skip (FreshPointDecodeInit1 s x)
3545 Skip s -> Skip (FreshPointDecodeInit s)
3548 step' _ _ (FreshPointDecodeInit1 st x) = do
3549 -- Note: It is important to use a ">" instead of a "<=" test
3550 -- here for GHC to generate code layout for default branch
3551 -- prediction for the common case. This is fragile and might
3552 -- change with the compiler versions, we need a more reliable
3553 -- "likely" primitive to control branch predication.
3556 return $ Skip $ YieldAndContinue
3557 (unsafeChr (fromIntegral x))
3558 (FreshPointDecodeInit st)
3559 -- Using a separate state here generates a jump to a
3560 -- separate code block in the core which seems to perform
3561 -- slightly better for the non-ascii case.
3562 True -> return $ Skip $ FreshPointDecodeFirst st x
3564 -- XXX should we merge it with FreshPointDecodeInit1?
3565 step' table _ (FreshPointDecodeFirst st x) = do
3566 let (Tuple' sv cp) = decode0 table x
3571 transliterateOrError
3572 "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered"
3573 (FreshPointDecodeInit st)
3574 0 -> error "unreachable state"
3575 _ -> Skip (FreshPointDecoding st sv cp)
3577 -- We recover by trying the new byte x a starter of a new codepoint.
3578 -- XXX need to use the same recovery in array decoding routine as well
3579 step' table gst (FreshPointDecoding st statePtr codepointPtr) = do
3580 r <- step (adaptState gst) st
3583 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
3586 0 -> Skip $ YieldAndContinue (unsafeChr cp)
3587 (FreshPointDecodeInit s)
3590 transliterateOrError
3591 "Streamly.Streams.StreamD.decodeUtf8With: Invalid UTF8 codepoint encountered"
3592 (FreshPointDecodeInit1 s x)
3593 _ -> Skip (FreshPointDecoding s sv cp)
3594 Skip s -> return $ Skip (FreshPointDecoding s statePtr codepointPtr)
3595 Stop -> return $ Skip inputUnderflow
3597 step' _ _ (YieldAndContinue c s) = return $ Yield c s
3598 step' _ _ Done = return Stop
3600{-# INLINE decodeUtf8 #-}
3601decodeUtf8 :: Monad m => Stream m Word8 -> Stream m Char
3602decodeUtf8 = decodeUtf8With ErrorOnCodingFailure
3604{-# INLINE decodeUtf8Lenient #-}
3605decodeUtf8Lenient :: Monad m => Stream m Word8 -> Stream m Char
3606decodeUtf8Lenient = decodeUtf8With TransliterateCodingFailure
3608{-# INLINE_NORMAL resumeDecodeUtf8Either #-}
3609resumeDecodeUtf8Either
3614 -> Stream m (Either DecodeError Char)
3615resumeDecodeUtf8Either dst codep (Stream step state) =
3616 let Array p _ _ = utf8d
3617 !ptr = (unsafeForeignPtrToPtr p)
3620 then FreshPointDecodeInit state
3621 else FreshPointDecoding state dst codep
3622 in Stream (step' ptr) stt
3624 {-# INLINE_LATE step' #-}
3625 step' _ gst (FreshPointDecodeInit st) = do
3626 r <- step (adaptState gst) st
3628 Yield x s -> Skip (FreshPointDecodeInit1 s x)
3629 Skip s -> Skip (FreshPointDecodeInit s)
3632 step' _ _ (FreshPointDecodeInit1 st x) = do
3633 -- Note: It is important to use a ">" instead of a "<=" test
3634 -- here for GHC to generate code layout for default branch
3635 -- prediction for the common case. This is fragile and might
3636 -- change with the compiler versions, we need a more reliable
3637 -- "likely" primitive to control branch predication.
3640 return $ Skip $ YieldAndContinue
3641 (Right $ unsafeChr (fromIntegral x))
3642 (FreshPointDecodeInit st)
3643 -- Using a separate state here generates a jump to a
3644 -- separate code block in the core which seems to perform
3645 -- slightly better for the non-ascii case.
3646 True -> return $ Skip $ FreshPointDecodeFirst st x
3648 -- XXX should we merge it with FreshPointDecodeInit1?
3649 step' table _ (FreshPointDecodeFirst st x) = do
3650 let (Tuple' sv cp) = decode0 table x
3654 Skip $ YieldAndContinue (Left $ DecodeError 0 (fromIntegral x))
3655 (FreshPointDecodeInit st)
3656 0 -> error "unreachable state"
3657 _ -> Skip (FreshPointDecoding st sv cp)
3659 -- We recover by trying the new byte x a starter of a new codepoint.
3660 -- XXX need to use the same recovery in array decoding routine as well
3661 step' table gst (FreshPointDecoding st statePtr codepointPtr) = do
3662 r <- step (adaptState gst) st
3665 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
3668 0 -> Skip $ YieldAndContinue (Right $ unsafeChr cp)
3669 (FreshPointDecodeInit s)
3671 Skip $ YieldAndContinue (Left $ DecodeError statePtr codepointPtr)
3672 (FreshPointDecodeInit1 s x)
3673 _ -> Skip (FreshPointDecoding s sv cp)
3674 Skip s -> return $ Skip (FreshPointDecoding s statePtr codepointPtr)
3675 Stop -> return $ Skip $ YieldAndContinue (Left $ DecodeError statePtr codepointPtr) Done
3677 step' _ _ (YieldAndContinue c s) = return $ Yield c s
3678 step' _ _ Done = return Stop
3680{-# INLINE_NORMAL decodeUtf8Either #-}
3681decodeUtf8Either :: Monad m
3682 => Stream m Word8 -> Stream m (Either DecodeError Char)
3683decodeUtf8Either = resumeDecodeUtf8Either 0 0
3685data FlattenState s a
3686 = OuterLoop s !(Maybe (DecodeState, CodePoint))
3687 | InnerLoopDecodeInit s (ForeignPtr a) !(Ptr a) !(Ptr a)
3688 | InnerLoopDecodeFirst s (ForeignPtr a) !(Ptr a) !(Ptr a) Word8
3689 | InnerLoopDecoding s (ForeignPtr a) !(Ptr a) !(Ptr a)
3690 !DecodeState !CodePoint
3691 | YAndC !Char (FlattenState s a) -- These constructors can be
3692 -- encoded in the FreshPoint
3693 -- type, I prefer to keep these
3694 -- flat even though that means
3695 -- coming up with new names
3698-- The normal decodeUtf8 above should fuse with flattenArrays
3699-- to create this exact code but it doesn't for some reason, as of now this
3700-- remains the fastest way I could figure out to decodeUtf8.
3702-- XXX Add Proper error messages
3703{-# INLINE_NORMAL decodeUtf8ArraysWith #-}
3704decodeUtf8ArraysWith ::
3706 => CodingFailureMode
3707 -> Stream m (A.Array Word8)
3709decodeUtf8ArraysWith cfm (Stream step state) =
3710 let Array p _ _ = utf8d
3711 !ptr = (unsafeForeignPtrToPtr p)
3712 in Stream (step' ptr) (OuterLoop state Nothing)
3714 {-# INLINE transliterateOrError #-}
3715 transliterateOrError e s =
3717 ErrorOnCodingFailure -> error e
3718 TransliterateCodingFailure -> YAndC replacementChar s
3719 {-# INLINE inputUnderflow #-}
3722 ErrorOnCodingFailure ->
3724 "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Input Underflow"
3725 TransliterateCodingFailure -> YAndC replacementChar D
3726 {-# INLINE_LATE step' #-}
3727 step' _ gst (OuterLoop st Nothing) = do
3728 r <- step (adaptState gst) st
3731 Yield A.Array {..} s ->
3732 let p = unsafeForeignPtrToPtr aStart
3733 in Skip (InnerLoopDecodeInit s aStart p aEnd)
3734 Skip s -> Skip (OuterLoop s Nothing)
3736 step' _ gst (OuterLoop st dst@(Just (ds, cp))) = do
3737 r <- step (adaptState gst) st
3740 Yield A.Array {..} s ->
3741 let p = unsafeForeignPtrToPtr aStart
3742 in Skip (InnerLoopDecoding s aStart p aEnd ds cp)
3743 Skip s -> Skip (OuterLoop s dst)
3744 Stop -> Skip inputUnderflow
3745 step' _ _ (InnerLoopDecodeInit st startf p end)
3747 liftIO $ touchForeignPtr startf
3748 return $ Skip $ OuterLoop st Nothing
3749 step' _ _ (InnerLoopDecodeInit st startf p end) = do
3750 x <- liftIO $ peek p
3751 -- Note: It is important to use a ">" instead of a "<=" test here for
3752 -- GHC to generate code layout for default branch prediction for the
3753 -- common case. This is fragile and might change with the compiler
3754 -- versions, we need a more reliable "likely" primitive to control
3755 -- branch predication.
3758 return $ Skip $ YAndC
3759 (unsafeChr (fromIntegral x))
3760 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
3761 -- Using a separate state here generates a jump to a separate code
3762 -- block in the core which seems to perform slightly better for the
3764 True -> return $ Skip $ InnerLoopDecodeFirst st startf p end x
3766 step' table _ (InnerLoopDecodeFirst st startf p end x) = do
3767 let (Tuple' sv cp) = decode0 table x
3772 transliterateOrError
3773 "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered"
3774 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
3775 0 -> error "unreachable state"
3776 _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)
3777 step' _ _ (InnerLoopDecoding st startf p end sv cp)
3779 liftIO $ touchForeignPtr startf
3780 return $ Skip $ OuterLoop st (Just (sv, cp))
3781 step' table _ (InnerLoopDecoding st startf p end statePtr codepointPtr) = do
3782 x <- liftIO $ peek p
3783 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
3790 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
3793 transliterateOrError
3794 "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered"
3795 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
3796 _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)
3797 step' _ _ (YAndC c s) = return $ Yield c s
3798 step' _ _ D = return Stop
3800{-# INLINE decodeUtf8Arrays #-}
3803 => Stream m (A.Array Word8)
3805decodeUtf8Arrays = decodeUtf8ArraysWith ErrorOnCodingFailure
3807{-# INLINE decodeUtf8ArraysLenient #-}
3808decodeUtf8ArraysLenient ::
3810 => Stream m (A.Array Word8)
3812decodeUtf8ArraysLenient = decodeUtf8ArraysWith TransliterateCodingFailure
3814data WList = WCons !Word8 !WList | WNil
3816data EncodeState s = EncodeState s !WList
3818-- More yield points improve performance, but I am not sure if they can cause
3819-- too much code bloat or some trouble with fusion. So keeping only two yield
3820-- points for now, one for the ascii chars (fast path) and one for all other
3821-- paths (slow path).
3822{-# INLINE_NORMAL encodeUtf8 #-}
3823encodeUtf8 :: Monad m => Stream m Char -> Stream m Word8
3824encodeUtf8 (Stream step state) = Stream step' (EncodeState state WNil)
3826 {-# INLINE_LATE step' #-}
3827 step' gst (EncodeState st WNil) = do
3828 r <- step (adaptState gst) st
3835 Yield (fromIntegral x) (EncodeState s WNil)
3836 | x <= 0x7FF -> Skip (EncodeState s (ord2 c))
3840 "Streamly.Streams.StreamD.encodeUtf8: Encountered a surrogate"
3841 else Skip (EncodeState s (ord3 c))
3842 | otherwise -> Skip (EncodeState s (ord4 c))
3843 Skip s -> Skip (EncodeState s WNil)
3845 step' _ (EncodeState s (WCons x xs)) = return $ Yield x (EncodeState s xs)
keysesc to close
- j k
- move down, up
- enter
- open
- esc
- back, or up a level
- 1 2 3 4
- readme, files, commits, refs
- /
- filter
- y
- copy the clone command
- c
- compare the chosen commit with another (or shift-click both)
- ?
- show or hide this list