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
63 -- ** Specialized Generation
64 -- | Generate a monadic stream from a seed.
74 , enumerateFromStepIntegral
75 , enumerateFromIntegral
76 , enumerateFromThenIntegral
77 , enumerateFromToIntegral
78 , enumerateFromThenToIntegral
80 , enumerateFromStepNum
83 , enumerateFromToFractional
84 , enumerateFromThenToFractional
87 -- | Transform an input structure into a stream.
88 -- | Direct style stream does not support @fromFoldable@.
115 -- ** Specialized Folds
136 -- ** Flattening nested streams
139 , ConcatMapUState (..)
141 , ConcatUnfoldInterleaveState (..)
142 , concatUnfoldInterleave
143 , concatUnfoldRoundrobin
146 , InterleaveState(..)
150 , roundRobin -- interleaveFair?/ParallelFair
151 , interleaveFstThenConcat
179 -- | Transform a stream into another type.
188 -- ** By folding (scans)
254 -- * Transformation comprehensions
265 -- * UTF8 Encoding / Decoding transformations.
270 , decodeUtf8ArraysLenient
274import Control.Exception (Exception)
275import Control.Monad (void)
276import Control.Monad.Catch (MonadCatch)
277import Control.Monad.IO.Class (MonadIO(..))
278import Control.Monad.Trans (MonadTrans(lift))
279import Data.Bits (shiftR, shiftL, (.|.), (.&.))
280#if __GLASGOW_HASKELL__ >= 801
281import Data.Functor.Identity (Identity)
283import Data.Maybe (fromJust, isJust)
284import Data.Word (Word32)
285import Foreign.Ptr (Ptr)
286import Foreign.Storable (Storable(..))
287import GHC.Base (assert, Char(..), unsafeChr, ord)
288import GHC.IO.Encoding.Failure (isSurrogate)
289import GHC.Types (SPEC(..))
290import GHC.Word (Word8(..))
292 hiding (map, mapM, mapM_, repeat, foldr, last, take, filter,
293 takeWhile, drop, dropWhile, all, any, maximum, minimum, elem,
294 notElem, null, head, tail, zipWith, lookup, foldr1, sequence,
295 (!!), scanl, scanl1, concatMap, replicate, enumFromTo, concat,
298import qualified Control.Monad.Catch as MC
300import Streamly.Memory.Array.Types (Array(..))
301import Streamly.Fold.Types (Fold(..))
302import Streamly.Pipe.Types (Pipe(..), PipeState(..))
303import Streamly.SVar (MonadAsync, defState, adaptState)
304import Streamly.Unfold.Types (Unfold(..))
305import Streamly.Strict (Tuple'(..))
307import Streamly.Streams.StreamD.Type
309import qualified Streamly.Pipe.Types as Pipe
310import qualified Streamly.Memory.Array.Types as A
311import qualified Streamly.Memory.Ring as RB
312import qualified Streamly.Streams.StreamK as K
314import Foreign.Ptr (plusPtr)
315import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
316import Foreign.ForeignPtr (ForeignPtr, touchForeignPtr)
318------------------------------------------------------------------------------
320------------------------------------------------------------------------------
322-- | An empty 'Stream'.
323{-# INLINE_NORMAL nil #-}
324nil :: Monad m => Stream m a
325nil = Stream (\_ _ -> return Stop) ()
327{-# INLINE_NORMAL consM #-}
328consM :: Monad m => m a -> Stream m a -> Stream m a
329consM m (Stream step state) = Stream step1 Nothing
331 {-# INLINE_LATE step1 #-}
332 step1 _ Nothing = m >>= \x -> return $ Yield x (Just state)
333 step1 gst (Just st) = do
337 Yield a s -> Yield a (Just s)
338 Skip s -> Skip (Just s)
341-- XXX implement in terms of consM?
342-- cons x = consM (return x)
344-- | Can fuse but has O(n^2) complexity.
345{-# INLINE_NORMAL cons #-}
346cons :: Monad m => a -> Stream m a -> Stream m a
347cons x (Stream step state) = Stream step1 Nothing
349 {-# INLINE_LATE step1 #-}
350 step1 _ Nothing = return $ Yield x (Just state)
351 step1 gst (Just st) = do
355 Yield a s -> Yield a (Just s)
356 Skip s -> Skip (Just s)
359-------------------------------------------------------------------------------
361-------------------------------------------------------------------------------
363-- Does not fuse, has the same performance as the StreamK version.
364{-# INLINE_NORMAL uncons #-}
365uncons :: Monad m => Stream m a -> m (Maybe (a, Stream m a))
366uncons (UnStream step state) = go state
369 r <- step defState st
371 Yield x s -> return $ Just (x, Stream step s)
373 Stop -> return Nothing
375------------------------------------------------------------------------------
376-- Generation by unfold
377------------------------------------------------------------------------------
379{-# INLINE_NORMAL unfoldrM #-}
380unfoldrM :: Monad m => (s -> m (Maybe (a, s))) -> s -> Stream m a
381unfoldrM next state = Stream step state
383 {-# INLINE_LATE step #-}
387 Just (x, s) -> Yield x s
390{-# INLINE_LATE unfoldr #-}
391unfoldr :: Monad m => (s -> Maybe (a, s)) -> s -> Stream m a
392unfoldr f = unfoldrM (return . f)
394------------------------------------------------------------------------------
395-- Specialized Generation
396------------------------------------------------------------------------------
398repeat :: Monad m => a -> Stream m a
399repeat x = Stream (\_ _ -> return $ Yield x ()) ()
401{-# INLINE_NORMAL replicateM #-}
402replicateM :: forall m a. Monad m => Int -> m a -> Stream m a
403replicateM n p = Stream step n
405 {-# INLINE_LATE step #-}
407 | i <= 0 = return Stop
410 return $ Yield x (i - 1)
412{-# INLINE_NORMAL replicate #-}
413replicate :: Monad m => Int -> a -> Stream m a
414replicate n x = replicateM n (return x)
416-- This would not work properly for floats, therefore we put an Integral
418-- | Can be used to enumerate unbounded integrals. This does not check for
419-- overflow or underflow for bounded integrals.
420{-# INLINE_NORMAL enumerateFromStepIntegral #-}
421enumerateFromStepIntegral :: (Integral a, Monad m) => a -> a -> Stream m a
422enumerateFromStepIntegral from stride =
423 from `seq` stride `seq` Stream step from
425 {-# INLINE_LATE step #-}
426 step _ !x = return $ Yield x $! (x + stride)
428-- We are assuming that "to" is constrained by the type to be within
430{-# INLINE enumerateFromToIntegral #-}
431enumerateFromToIntegral :: (Monad m, Integral a) => a -> a -> Stream m a
432enumerateFromToIntegral from to =
433 takeWhile (<= to) $ enumerateFromStepIntegral from 1
435{-# INLINE enumerateFromIntegral #-}
436enumerateFromIntegral :: (Monad m, Integral a, Bounded a) => a -> Stream m a
437enumerateFromIntegral from = enumerateFromToIntegral from maxBound
439data EnumState a = EnumInit | EnumYield a a a | EnumStop
441{-# INLINE_NORMAL enumerateFromThenToIntegralUp #-}
442enumerateFromThenToIntegralUp
443 :: (Monad m, Integral a)
444 => a -> a -> a -> Stream m a
445enumerateFromThenToIntegralUp from next to = Stream step EnumInit
447 {-# INLINE_LATE step #-}
453 else Yield from EnumStop
454 else -- from <= next <= to
455 let stride = next - from
456 in Skip $ EnumYield from stride (to - stride)
458 step _ (EnumYield x stride toMinus) =
461 then Yield x EnumStop
462 else Yield x $ EnumYield (x + stride) stride toMinus
464 step _ EnumStop = return Stop
466{-# INLINE_NORMAL enumerateFromThenToIntegralDn #-}
467enumerateFromThenToIntegralDn
468 :: (Monad m, Integral a)
469 => a -> a -> a -> Stream m a
470enumerateFromThenToIntegralDn from next to = Stream step EnumInit
472 {-# INLINE_LATE step #-}
474 return $ if to > next
477 else Yield from EnumStop
478 else -- from >= next >= to
479 let stride = next - from
480 in Skip $ EnumYield from stride (to - stride)
482 step _ (EnumYield x stride toMinus) =
485 then Yield x EnumStop
486 else Yield x $ EnumYield (x + stride) stride toMinus
488 step _ EnumStop = return Stop
490{-# INLINE_NORMAL enumerateFromThenToIntegral #-}
491enumerateFromThenToIntegral
492 :: (Monad m, Integral a)
493 => a -> a -> a -> Stream m a
494enumerateFromThenToIntegral from next to
495 | next >= from = enumerateFromThenToIntegralUp from next to
496 | otherwise = enumerateFromThenToIntegralDn from next to
498{-# INLINE_NORMAL enumerateFromThenIntegral #-}
499enumerateFromThenIntegral
500 :: (Monad m, Integral a, Bounded a)
501 => a -> a -> Stream m a
502enumerateFromThenIntegral from next =
504 then enumerateFromThenToIntegralUp from next maxBound
505 else enumerateFromThenToIntegralDn from next minBound
507-- For floating point numbers if the increment is less than the precision then
508-- it just gets lost. Therefore we cannot always increment it correctly by just
510-- 9007199254740992 + 1 + 1 :: Double => 9.007199254740992e15
511-- 9007199254740992 + 2 :: Double => 9.007199254740994e15
513-- Instead we accumulate the increment counter and compute the increment
514-- everytime before adding it to the starting number.
516-- This works for Integrals as well as floating point numbers, but
517-- enumerateFromStepIntegral is faster for integrals.
518{-# INLINE_NORMAL enumerateFromStepNum #-}
519enumerateFromStepNum :: (Monad m, Num a) => a -> a -> Stream m a
520enumerateFromStepNum from stride = Stream step 0
522 {-# INLINE_LATE step #-}
523 step _ !i = return $ (Yield $! (from + i * stride)) $! (i + 1)
525{-# INLINE_NORMAL numFrom #-}
526numFrom :: (Monad m, Num a) => a -> Stream m a
527numFrom from = enumerateFromStepNum from 1
529{-# INLINE_NORMAL numFromThen #-}
530numFromThen :: (Monad m, Num a) => a -> a -> Stream m a
531numFromThen from next = enumerateFromStepNum from (next - from)
533-- We cannot write a general function for Num. The only way to write code
534-- portable between the two is to use a 'Real' constraint and convert between
535-- Fractional and Integral using fromRational which is horribly slow.
536{-# INLINE_NORMAL enumerateFromToFractional #-}
537enumerateFromToFractional
538 :: (Monad m, Fractional a, Ord a)
539 => a -> a -> Stream m a
540enumerateFromToFractional from to =
541 takeWhile (<= to + 1 / 2) $ enumerateFromStepNum from 1
543{-# INLINE_NORMAL enumerateFromThenToFractional #-}
544enumerateFromThenToFractional
545 :: (Monad m, Fractional a, Ord a)
546 => a -> a -> a -> Stream m a
547enumerateFromThenToFractional from next to =
548 takeWhile predicate $ numFromThen from next
550 mid = (next - from) / 2
551 predicate | next >= from = (<= to + mid)
552 | otherwise = (>= to + mid)
554-------------------------------------------------------------------------------
555-- Generation by Conversion
556-------------------------------------------------------------------------------
558{-# INLINE_NORMAL fromIndicesM #-}
559fromIndicesM :: Monad m => (Int -> m a) -> Stream m a
560fromIndicesM gen = Stream step 0
562 {-# INLINE_LATE step #-}
565 return $ Yield x (i + 1)
567{-# INLINE fromIndices #-}
568fromIndices :: Monad m => (Int -> a) -> Stream m a
569fromIndices gen = fromIndicesM (return . gen)
571{-# INLINE_NORMAL generateM #-}
572generateM :: Monad m => Int -> (Int -> m a) -> Stream m a
573generateM n gen = n `seq` Stream step 0
575 {-# INLINE_LATE step #-}
576 step _ i | i < n = do
578 return $ Yield x (i + 1)
579 | otherwise = return Stop
581{-# INLINE generate #-}
582generate :: Monad m => Int -> (Int -> a) -> Stream m a
583generate n gen = generateM n (return . gen)
585-- XXX we need the MonadAsync constraint because of a rewrite rule.
586-- | Convert a list of monadic actions to a 'Stream'
587{-# INLINE_LATE fromListM #-}
588fromListM :: MonadAsync m => [m a] -> Stream m a
589fromListM = Stream step
591 {-# INLINE_LATE step #-}
592 step _ (m:ms) = m >>= \x -> return $ Yield x ms
593 step _ [] = return Stop
595{-# INLINE toStreamD #-}
596toStreamD :: (K.IsStream t, Monad m) => t m a -> Stream m a
597toStreamD = fromStreamK . K.toStream
599------------------------------------------------------------------------------
600-- Elimination by Folds
601------------------------------------------------------------------------------
603------------------------------------------------------------------------------
605------------------------------------------------------------------------------
607{-# INLINE_NORMAL foldr1 #-}
608foldr1 :: Monad m => (a -> a -> a) -> Stream m a -> m (Maybe a)
612 Nothing -> return Nothing
613 Just (h, t) -> fmap Just (foldr f h t)
615------------------------------------------------------------------------------
617------------------------------------------------------------------------------
619{-# INLINE_NORMAL foldlT #-}
620foldlT :: (Monad m, Monad (s m), MonadTrans s)
621 => (s m b -> a -> s m b) -> s m b -> Stream m a -> s m b
622foldlT fstep begin (Stream step state) = go SPEC begin state
625 r <- lift $ step defState st
627 Yield x s -> go SPEC (fstep acc x) s
628 Skip s -> go SPEC acc s
631-- Note, this is going to have horrible performance, because of the nature of
632-- the stream type (i.e. direct stream vs CPS). Its only for reference, it is
633-- likely be practically unusable.
634{-# INLINE_NORMAL foldlS #-}
636 => (Stream m b -> a -> Stream m b) -> Stream m b -> Stream m a -> Stream m b
637foldlS fstep begin (Stream step state) = Stream step' (Left (state, begin))
639 step' gst (Left (st, acc)) = do
640 r <- step (adaptState gst) st
642 Yield x s -> Skip (Left (s, fstep acc x))
643 Skip s -> Skip (Left (s, acc))
644 Stop -> Skip (Right acc)
646 step' gst (Right (Stream stp stt)) = do
647 r <- stp (adaptState gst) stt
649 Yield x s -> Yield x (Right (Stream stp s))
650 Skip s -> Skip (Right (Stream stp s))
653------------------------------------------------------------------------------
655------------------------------------------------------------------------------
657-- | Run a streaming composition, discard the results.
658{-# INLINE_LATE drain #-}
659drain :: Monad m => Stream m a -> m ()
660-- drain = foldrM (\_ xs -> xs) (return ())
661drain (Stream step state) = go SPEC state
664 r <- step defState st
666 Yield _ s -> go SPEC s
670{-# INLINE_NORMAL null #-}
671null :: Monad m => Stream m a -> m Bool
672null m = foldrM (\_ _ -> return False) (return True) m
674{-# INLINE_NORMAL head #-}
675head :: Monad m => Stream m a -> m (Maybe a)
676head m = foldrM (\x _ -> return (Just x)) (return Nothing) m
678-- Does not fuse, has the same performance as the StreamK version.
679{-# INLINE_NORMAL tail #-}
680tail :: Monad m => Stream m a -> m (Maybe (Stream m a))
681tail (UnStream step state) = go state
684 r <- step defState st
686 Yield _ s -> return (Just $ Stream step s)
688 Stop -> return Nothing
690-- XXX will it fuse? need custom impl?
691{-# INLINE_NORMAL last #-}
692last :: Monad m => Stream m a -> m (Maybe a)
693last = foldl' (\_ y -> Just y) Nothing
695{-# INLINE_NORMAL elem #-}
696elem :: (Monad m, Eq a) => a -> Stream m a -> m Bool
697-- elem e m = foldrM (\x xs -> if x == e then return True else xs) (return False) m
698elem e (Stream step state) = go state
701 r <- step defState st
704 | x == e -> return True
709{-# INLINE_NORMAL notElem #-}
710notElem :: (Monad m, Eq a) => a -> Stream m a -> m Bool
711notElem e s = fmap not (elem e s)
713{-# INLINE_NORMAL all #-}
714all :: Monad m => (a -> Bool) -> Stream m a -> m Bool
715-- all p m = foldrM (\x xs -> if p x then xs else return False) (return True) m
716all p (Stream step state) = go state
719 r <- step defState st
723 | otherwise -> return False
727{-# INLINE_NORMAL any #-}
728any :: Monad m => (a -> Bool) -> Stream m a -> m Bool
729-- any p m = foldrM (\x xs -> if p x then return True else xs) (return False) m
730any p (Stream step state) = go state
733 r <- step defState st
741{-# INLINE_NORMAL maximum #-}
742maximum :: (Monad m, Ord a) => Stream m a -> m (Maybe a)
743maximum (Stream step state) = go Nothing state
746 r <- step defState st
748 Yield x s -> go (Just x) s
749 Skip s -> go Nothing s
750 Stop -> return Nothing
751 go (Just acc) st = do
752 r <- step defState st
755 | acc <= x -> go (Just x) s
756 | otherwise -> go (Just acc) s
757 Skip s -> go (Just acc) s
758 Stop -> return (Just acc)
760{-# INLINE_NORMAL maximumBy #-}
761maximumBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> m (Maybe a)
762maximumBy cmp (Stream step state) = go Nothing state
765 r <- step defState st
767 Yield x s -> go (Just x) s
768 Skip s -> go Nothing s
769 Stop -> return Nothing
770 go (Just acc) st = do
771 r <- step defState st
773 Yield x s -> case cmp acc x of
774 GT -> go (Just acc) s
776 Skip s -> go (Just acc) s
777 Stop -> return (Just acc)
779{-# INLINE_NORMAL minimum #-}
780minimum :: (Monad m, Ord a) => Stream m a -> m (Maybe a)
781minimum (Stream step state) = go Nothing state
784 r <- step defState st
786 Yield x s -> go (Just x) s
787 Skip s -> go Nothing s
788 Stop -> return Nothing
789 go (Just acc) st = do
790 r <- step defState st
793 | acc <= x -> go (Just acc) s
794 | otherwise -> go (Just x) s
795 Skip s -> go (Just acc) s
796 Stop -> return (Just acc)
798{-# INLINE_NORMAL minimumBy #-}
799minimumBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> m (Maybe a)
800minimumBy cmp (Stream step state) = go Nothing state
803 r <- step defState st
805 Yield x s -> go (Just x) s
806 Skip s -> go Nothing s
807 Stop -> return Nothing
808 go (Just acc) st = do
809 r <- step defState st
811 Yield x s -> case cmp acc x of
814 Skip s -> go (Just acc) s
815 Stop -> return (Just acc)
817{-# INLINE_NORMAL (!!) #-}
818(!!) :: (Monad m) => Stream m a -> Int -> m (Maybe a)
819(Stream step state) !! i = go i state
822 r <- step defState st
824 Yield x s | n < 0 -> return Nothing
825 | n == 0 -> return $ Just x
826 | otherwise -> go (n - 1) s
828 Stop -> return Nothing
830{-# INLINE_NORMAL lookup #-}
831lookup :: (Monad m, Eq a) => a -> Stream m (a, b) -> m (Maybe b)
832lookup e m = foldrM (\(a, b) xs -> if e == a then return (Just b) else xs)
835{-# INLINE_NORMAL findM #-}
836findM :: Monad m => (a -> m Bool) -> Stream m a -> m (Maybe a)
837findM p m = foldrM (\x xs -> p x >>= \r -> if r then return (Just x) else xs)
841find :: Monad m => (a -> Bool) -> Stream m a -> m (Maybe a)
842find p = findM (return . p)
844{-# INLINE_NORMAL findIndices #-}
845findIndices :: Monad m => (a -> Bool) -> Stream m a -> Stream m Int
846findIndices p (Stream step state) = Stream step' (state, 0)
848 {-# INLINE_LATE step' #-}
849 step' gst (st, i) = do
850 r <- step (adaptState gst) st
852 Yield x s -> if p x then Yield i (s, i+1) else Skip (s, i+1)
853 Skip s -> Skip (s, i+1)
856{-# INLINE toListRev #-}
857toListRev :: Monad m => Stream m a -> m [a]
858toListRev = foldl' (flip (:)) []
860-- We can implement reverse as:
862-- > reverse = foldlS (flip cons) nil
864-- However, this implementation is unusable because of the horrible performance
865-- of cons. So we just convert it to a list first and then stream from the
868-- XXX Maybe we can use an Array instead of a list here?
869{-# INLINE_NORMAL reverse #-}
870reverse :: Monad m => Stream m a -> Stream m a
871reverse m = Stream step Nothing
873 {-# INLINE_LATE step #-}
876 return $ Skip (Just xs)
877 step _ (Just (x:xs)) = return $ Yield x (Just xs)
878 step _ (Just []) = return Stop
880-- Much faster reverse for Storables
881{-# INLINE_NORMAL reverse' #-}
882reverse' :: forall m a. (MonadIO m, Storable a) => Stream m a -> Stream m a
884-- This commented implementation copies the whole stream into one single array
885-- and then streams from that array, this is 3-4x faster than the chunked code
886-- that follows. Though this could be problematic due to unbounded large
887-- allocations. We need to figure out why the chunked code is slower and if we
888-- can optimize the chunked code to work as fast as this one. It may be a
890import Foreign.ForeignPtr (touchForeignPtr)
891import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
892import Foreign.Ptr (Ptr, plusPtr)
893reverse' m = Stream step Nothing
895 {-# INLINE_LATE step #-}
897 arr <- A.fromStreamD m
898 let p = aEnd arr `plusPtr` negate (sizeOf (undefined :: a))
899 return $ Skip $ Just (aStart arr, p)
901 step _ (Just (start, p)) | p < unsafeForeignPtrToPtr start = return Stop
903 step _ (Just (start, p)) = do
904 let !x = A.unsafeInlineIO $ do
906 touchForeignPtr start
908 next = p `plusPtr` negate (sizeOf (undefined :: a))
909 return $ Yield x (Just (start, next))
916 $ A.fromStreamDArraysOf A.defaultChunkSize m
919------------------------------------------------------------------------------
921------------------------------------------------------------------------------
923{-# INLINE_NORMAL splitSuffixBy' #-}
924splitSuffixBy' :: Monad m
925 => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
926splitSuffixBy' predicate f (Stream step state) =
927 Stream (stepOuter f) (Just state)
931 {-# INLINE_LATE stepOuter #-}
932 stepOuter (Fold fstep initial done) gst (Just st) = do
933 res <- step (adaptState gst) st
939 then done acc' >>= \val -> return $ Yield val (Just s)
942 Skip s -> return $ Skip $ Just s
948 res <- step (adaptState gst) stt
953 then done acc' >>= \val -> return $ Yield val (Just s)
955 Skip s -> go SPEC s acc
956 Stop -> done acc >>= \val -> return $ Yield val Nothing
958 stepOuter _ _ Nothing = return Stop
960{-# INLINE_NORMAL groupsBy #-}
966groupsBy cmp f (Stream step state) = Stream (stepOuter f) (Just state, Nothing)
970 {-# INLINE_LATE stepOuter #-}
971 stepOuter (Fold fstep initial done) gst (Just st, Nothing) = do
972 res <- step (adaptState gst) st
979 Skip s -> return $ Skip $ (Just s, Nothing)
984 go !_ prev stt !acc = do
985 res <- step (adaptState gst) stt
992 else done acc >>= \r -> return $ Yield r (Just s, Just x)
993 Skip s -> go SPEC prev s acc
994 Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
996 stepOuter (Fold fstep initial done) gst (Just st, Just prev) = do
998 acc' <- fstep acc prev
1003 -- XXX code duplicated from the previous equation
1005 res <- step (adaptState gst) stt
1012 else done acc >>= \r -> return $ Yield r (Just s, Just x)
1013 Skip s -> go SPEC s acc
1014 Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1016 stepOuter _ _ (Nothing,_) = return Stop
1018{-# INLINE_NORMAL groupsRollingBy #-}
1019groupsRollingBy :: Monad m
1024groupsRollingBy cmp f (Stream step state) =
1025 Stream (stepOuter f) (Just state, Nothing)
1028 {-# INLINE_LATE stepOuter #-}
1029 stepOuter (Fold fstep initial done) gst (Just st, Nothing) = do
1030 res <- step (adaptState gst) st
1037 Skip s -> return $ Skip $ (Just s, Nothing)
1041 go !_ prev stt !acc = do
1042 res <- step (adaptState gst) stt
1050 done acc >>= \r -> return $ Yield r (Just s, Just x)
1051 Skip s -> go SPEC prev s acc
1052 Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1054 stepOuter (Fold fstep initial done) gst (Just st, Just prev') = do
1056 acc' <- fstep acc prev'
1057 go SPEC prev' st acc'
1060 go !_ prevv stt !acc = do
1061 res <- step (adaptState gst) stt
1068 else done acc >>= \r -> return $ Yield r (Just s, Just x)
1069 Skip s -> go SPEC prevv s acc
1070 Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1072 stepOuter _ _ (Nothing, _) = return Stop
1074{-# INLINE_NORMAL splitBy #-}
1075splitBy :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
1076splitBy predicate f (Stream step state) = Stream (step' f) (Just state)
1080 {-# INLINE_LATE step' #-}
1081 step' (Fold fstep initial done) gst (Just st) = initial >>= go SPEC st
1086 res <- step (adaptState gst) stt
1090 then done acc >>= \r -> return $ Yield r (Just s)
1094 Skip s -> go SPEC s acc
1095 Stop -> done acc >>= \r -> return $ Yield r Nothing
1097 step' _ _ Nothing = return Stop
1099-- XXX requires -funfolding-use-threshold=150 in lines-unlines benchmark
1100{-# INLINE_NORMAL splitSuffixBy #-}
1101splitSuffixBy :: Monad m
1102 => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
1103splitSuffixBy predicate f (Stream step state) = Stream (step' f) (Just state)
1107 {-# INLINE_LATE step' #-}
1108 step' (Fold fstep initial done) gst (Just st) = do
1109 res <- step (adaptState gst) st
1114 then done acc >>= \val -> return $ Yield val (Just s)
1119 Skip s -> return $ Skip $ Just s
1125 res <- step (adaptState gst) stt
1129 then done acc >>= \r -> return $ Yield r (Just s)
1133 Skip s -> go SPEC s acc
1134 Stop -> done acc >>= \r -> return $ Yield r Nothing
1136 step' _ _ Nothing = return Stop
1138{-# INLINE_NORMAL wordsBy #-}
1139wordsBy :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
1140wordsBy predicate f (Stream step state) = Stream (stepOuter f) (Just state)
1144 {-# INLINE_LATE stepOuter #-}
1145 stepOuter (Fold fstep initial done) gst (Just st) = do
1146 res <- step (adaptState gst) st
1150 then return $ Skip (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 stepOuter _ _ Nothing = return Stop
1175-- String search algorithms:
1176-- http://www-igm.univ-mlv.fr/~lecroq/string/index.html
1179-- TODO can we unify the splitting operations using a splitting configuration
1180-- like in the split package.
1182data SplitStyle = Infix | Suffix | Prefix deriving (Eq, Show)
1184data SplitOptions = SplitOptions
1185 { style :: SplitStyle
1186 , withSep :: Bool -- ^ keep the separators in output
1187 -- , compact :: Bool -- ^ treat multiple consecutive separators as one
1188 -- , trimHead :: Bool -- ^ drop blank at head
1189 -- , trimTail :: Bool -- ^ drop blank at tail
1193data SplitOnState s a =
1198 | GO_KARP_RABIN s !(RB.Ring a) !(Ptr a)
1201{-# INLINE_NORMAL splitOn #-}
1203 :: forall m a b. (MonadIO m, Storable a, Enum a, Eq a)
1208splitOn patArr@Array{..} (Fold fstep initial done) (Stream step state) =
1209 Stream stepOuter GO_START
1213 patLen = A.length patArr
1214 maxIndex = patLen - 1
1215 elemBits = sizeOf (undefined :: a) * 8
1217 {-# INLINE_LATE stepOuter #-}
1218 stepOuter _ GO_START =
1220 then return $ Skip $ GO_EMPTY_PAT state
1223 r <- liftIO $ (A.unsafeIndexIO patArr 0)
1224 return $ Skip $ GO_SINGLE_PAT state r
1225 else if sizeOf (undefined :: a) * patLen
1226 <= sizeOf (undefined :: Word)
1227 then return $ Skip $ GO_SHORT_PAT state
1229 (rb, rhead) <- liftIO $ RB.new patLen
1230 return $ Skip $ GO_KARP_RABIN state rb rhead
1232 stepOuter gst (GO_SINGLE_PAT stt pat) = initial >>= go SPEC stt
1237 res <- step (adaptState gst) st
1243 return $ Yield r (GO_SINGLE_PAT s pat)
1244 else fstep acc x >>= go SPEC s
1245 Skip s -> go SPEC s acc
1246 Stop -> done acc >>= \r -> return $ Yield r GO_DONE
1248 stepOuter gst (GO_SHORT_PAT stt) = initial >>= go0 SPEC 0 (0 :: Word) stt
1253 mask = (1 `shiftL` (elemBits * patLen)) - 1
1255 addToWord wrd a = (wrd `shiftL` elemBits) .|. fromIntegral (fromEnum a)
1258 patWord = mask .&. A.foldl' addToWord 0 patArr
1260 go0 !_ !idx wrd st !acc = do
1261 res <- step (adaptState gst) st
1264 let wrd' = addToWord wrd x
1267 if wrd' .&. mask == patWord
1270 return $ Yield r (GO_SHORT_PAT s)
1271 else go1 SPEC wrd' s acc
1272 else go0 SPEC (idx + 1) wrd' s acc
1273 Skip s -> go0 SPEC idx wrd s acc
1276 then go2 wrd idx acc
1278 done acc' >>= \r -> return $ Yield r GO_DONE
1281 go1 !_ wrd st !acc = do
1282 res <- step (adaptState gst) st
1285 let wrd' = addToWord wrd x
1286 old = (mask .&. wrd) `shiftR` (elemBits * (patLen - 1))
1287 acc' <- fstep acc (toEnum $ fromIntegral old)
1288 if wrd' .&. mask == patWord
1289 then done acc' >>= \r -> return $ Yield r (GO_SHORT_PAT s)
1290 else go1 SPEC wrd' s acc'
1291 Skip s -> go1 SPEC wrd s acc
1293 acc' <- go2 wrd patLen acc
1294 done acc' >>= \r -> return $ Yield r GO_DONE
1296 go2 !wrd !n !acc | n > 0 = do
1297 let old = (mask .&. wrd) `shiftR` (elemBits * (n - 1))
1298 fstep acc (toEnum $ fromIntegral old) >>= go2 wrd (n - 1)
1299 go2 _ _ acc = return acc
1301 stepOuter gst (GO_KARP_RABIN stt rb rhead) = do
1302 initial >>= go0 SPEC 0 rhead stt
1306 k = 2891336453 :: Word32
1308 addCksum cksum a = cksum * k + fromIntegral (fromEnum a)
1309 deltaCksum cksum old new =
1310 addCksum cksum new - coeff * fromIntegral (fromEnum old)
1312 -- XXX shall we use a random starting hash or 1 instead of 0?
1313 patHash = A.foldl' addCksum 0 patArr
1316 go0 !_ !idx !rh st !acc = do
1317 res <- step (adaptState gst) st
1320 rh' <- liftIO $ RB.unsafeInsert rb rh x
1323 let fold = RB.unsafeFoldRing (RB.ringBound rb)
1324 let !ringHash = fold addCksum 0 rb
1325 if ringHash == patHash
1326 then go2 SPEC ringHash rh' s acc
1327 else go1 SPEC ringHash rh' s acc
1328 else go0 SPEC (idx + 1) rh' s acc
1329 Skip s -> go0 SPEC idx rh s acc
1331 !acc' <- if idx /= 0
1332 then RB.unsafeFoldRingM rh fstep acc rb
1334 done acc' >>= \r -> return $ Yield r GO_DONE
1336 -- XXX Theoretically this code can do 4 times faster if GHC generates
1337 -- optimal code. If we use just "(cksum' == patHash)" condition it goes
1338 -- 4x faster, as soon as we add the "RB.unsafeEqArray rb v" condition
1339 -- the generated code changes drastically and becomes 4x slower. Need
1340 -- to investigate what is going on with GHC.
1342 go1 !_ !cksum !rh st !acc = do
1343 res <- step (adaptState gst) st
1346 old <- liftIO $ peek rh
1347 let cksum' = deltaCksum cksum old x
1348 acc' <- fstep acc old
1350 if (cksum' == patHash)
1352 rh' <- liftIO (RB.unsafeInsert rb rh x)
1353 go2 SPEC cksum' rh' s acc'
1355 rh' <- liftIO (RB.unsafeInsert rb rh x)
1356 go1 SPEC cksum' rh' s acc'
1357 Skip s -> go1 SPEC cksum rh s acc
1359 acc' <- RB.unsafeFoldRingFullM rh fstep acc rb
1360 done acc' >>= \r -> return $ Yield r GO_DONE
1362 go2 !_ !cksum' !rh' s !acc' = do
1363 if RB.unsafeEqArray rb rh' patArr
1366 return $ Yield r (GO_KARP_RABIN s rb rhead)
1367 else go1 SPEC cksum' rh' s acc'
1369 stepOuter gst (GO_EMPTY_PAT st) = do
1370 res <- step (adaptState gst) st
1375 done acc' >>= \r -> return $ Yield r (GO_EMPTY_PAT s)
1376 Skip s -> return $ Skip (GO_EMPTY_PAT s)
1379 stepOuter _ GO_DONE = return Stop
1381{-# INLINE_NORMAL splitSuffixOn #-}
1383 :: forall m a b. (MonadIO m, Storable a, Enum a, Eq a)
1389splitSuffixOn withSep patArr@Array{..} (Fold fstep initial done)
1390 (Stream step state) =
1391 Stream stepOuter GO_START
1395 patLen = A.length patArr
1396 maxIndex = patLen - 1
1397 elemBits = sizeOf (undefined :: a) * 8
1399 {-# INLINE_LATE stepOuter #-}
1400 stepOuter _ GO_START =
1402 then return $ Skip $ GO_EMPTY_PAT state
1405 r <- liftIO $ (A.unsafeIndexIO patArr 0)
1406 return $ Skip $ GO_SINGLE_PAT state r
1407 else if sizeOf (undefined :: a) * patLen
1408 <= sizeOf (undefined :: Word)
1409 then return $ Skip $ GO_SHORT_PAT state
1411 (rb, rhead) <- liftIO $ RB.new patLen
1412 return $ Skip $ GO_KARP_RABIN state rb rhead
1414 stepOuter gst (GO_SINGLE_PAT stt pat) = do
1415 -- This first part is the only difference between splitOn and
1417 -- If the last element is a separator do not issue a blank segment.
1418 res <- step (adaptState gst) stt
1424 acc' <- if withSep then fstep acc x else return acc
1425 done acc' >>= \r -> return $ Yield r (GO_SINGLE_PAT s pat)
1426 else fstep acc x >>= go SPEC s
1427 Skip s -> return $ Skip $ (GO_SINGLE_PAT s pat)
1432 -- This is identical for splitOn and splitSuffixOn
1434 res <- step (adaptState gst) st
1439 acc' <- if withSep then fstep acc x else return acc
1441 return $ Yield r (GO_SINGLE_PAT s pat)
1442 else fstep acc x >>= go SPEC s
1443 Skip s -> go SPEC s acc
1444 Stop -> done acc >>= \r -> return $ Yield r GO_DONE
1446 stepOuter gst (GO_SHORT_PAT stt) = do
1448 -- Call "initial" only if the stream yields an element, otherwise we
1449 -- may call "initial" but never yield anything. initial may produce a
1450 -- side effect, therefore we will end up doing and discard a side
1455 res <- step (adaptState gst) stt
1459 let wrd' = addToWord wrd x
1460 acc' <- if withSep then fstep acc x else return acc
1463 if wrd' .&. mask == patWord
1464 then done acc' >>= \r -> return $ Yield r (GO_SHORT_PAT s)
1465 else go0 SPEC (idx + 1) wrd' s acc'
1466 else go0 SPEC (idx + 1) wrd' s acc'
1467 Skip s -> return $ Skip (GO_SHORT_PAT s)
1473 mask = (1 `shiftL` (elemBits * patLen)) - 1
1475 addToWord wrd a = (wrd `shiftL` elemBits) .|. fromIntegral (fromEnum a)
1478 patWord = mask .&. A.foldl' addToWord 0 patArr
1480 go0 !_ !idx wrd st !acc = do
1481 res <- step (adaptState gst) st
1484 let wrd' = addToWord wrd x
1485 acc' <- if withSep then fstep acc x else return acc
1488 if wrd' .&. mask == patWord
1491 return $ Yield r (GO_SHORT_PAT s)
1492 else go1 SPEC wrd' s acc'
1493 else go0 SPEC (idx + 1) wrd' s acc'
1494 Skip s -> go0 SPEC idx wrd s acc
1496 if (idx == maxIndex) && (wrd .&. mask == patWord)
1499 acc' <- if idx /= 0 && not withSep
1500 then go2 wrd idx acc
1502 done acc' >>= \r -> return $ Yield r GO_DONE
1505 go1 !_ wrd st !acc = do
1506 res <- step (adaptState gst) st
1509 let wrd' = addToWord wrd x
1510 old = (mask .&. wrd) `shiftR` (elemBits * (patLen - 1))
1513 else fstep acc (toEnum $ fromIntegral old)
1514 if wrd' .&. mask == patWord
1515 then done acc' >>= \r -> return $ Yield r (GO_SHORT_PAT s)
1516 else go1 SPEC wrd' s acc'
1517 Skip s -> go1 SPEC wrd s acc
1519 -- If the last sequence is a separator do not issue a blank
1521 if wrd .&. mask == patWord
1526 else go2 wrd patLen acc
1527 done acc' >>= \r -> return $ Yield r GO_DONE
1529 go2 !wrd !n !acc | n > 0 = do
1530 let old = (mask .&. wrd) `shiftR` (elemBits * (n - 1))
1531 fstep acc (toEnum $ fromIntegral old) >>= go2 wrd (n - 1)
1532 go2 _ _ acc = return acc
1534 stepOuter gst (GO_KARP_RABIN stt rb rhead) = do
1536 res <- step (adaptState gst) stt
1540 acc' <- if withSep then fstep acc x else return acc
1541 rh' <- liftIO (RB.unsafeInsert rb rhead x)
1544 let fold = RB.unsafeFoldRing (RB.ringBound rb)
1545 let !ringHash = fold addCksum 0 rb
1546 if ringHash == patHash
1547 then go2 SPEC ringHash rh' s acc'
1548 else go0 SPEC (idx + 1) rh' s acc'
1549 else go0 SPEC (idx + 1) rh' s acc'
1550 Skip s -> return $ Skip (GO_KARP_RABIN s rb rhead)
1555 k = 2891336453 :: Word32
1557 addCksum cksum a = cksum * k + fromIntegral (fromEnum a)
1558 deltaCksum cksum old new =
1559 addCksum cksum new - coeff * fromIntegral (fromEnum old)
1561 -- XXX shall we use a random starting hash or 1 instead of 0?
1562 patHash = A.foldl' addCksum 0 patArr
1565 go0 !_ !idx !rh st !acc = do
1566 res <- step (adaptState gst) st
1569 acc' <- if withSep then fstep acc x else return acc
1570 rh' <- liftIO (RB.unsafeInsert rb rh x)
1573 let fold = RB.unsafeFoldRing (RB.ringBound rb)
1574 let !ringHash = fold addCksum 0 rb
1575 if ringHash == patHash
1576 then go2 SPEC ringHash rh' s acc'
1577 else go1 SPEC ringHash rh' s acc'
1578 else go0 SPEC (idx + 1) rh' s acc'
1579 Skip s -> go0 SPEC idx rh s acc
1581 -- do not issue a blank segment when we end at pattern
1582 if (idx == maxIndex) && RB.unsafeEqArray rb rh patArr
1585 !acc' <- if idx /= 0 && not withSep
1586 then RB.unsafeFoldRingM rh fstep acc rb
1588 done acc' >>= \r -> return $ Yield r GO_DONE
1590 -- XXX Theoretically this code can do 4 times faster if GHC generates
1591 -- optimal code. If we use just "(cksum' == patHash)" condition it goes
1592 -- 4x faster, as soon as we add the "RB.unsafeEqArray rb v" condition
1593 -- the generated code changes drastically and becomes 4x slower. Need
1594 -- to investigate what is going on with GHC.
1596 go1 !_ !cksum !rh st !acc = do
1597 res <- step (adaptState gst) st
1600 old <- liftIO $ peek rh
1601 let cksum' = deltaCksum cksum old x
1606 if (cksum' == patHash)
1608 rh' <- liftIO (RB.unsafeInsert rb rh x)
1609 go2 SPEC cksum' rh' s acc'
1611 rh' <- liftIO (RB.unsafeInsert rb rh x)
1612 go1 SPEC cksum' rh' s acc'
1613 Skip s -> go1 SPEC cksum rh s acc
1615 if RB.unsafeEqArray rb rh patArr
1620 else RB.unsafeFoldRingFullM rh fstep acc rb
1621 done acc' >>= \r -> return $ Yield r GO_DONE
1623 go2 !_ !cksum' !rh' s !acc' = do
1624 if RB.unsafeEqArray rb rh' patArr
1627 return $ Yield r (GO_KARP_RABIN s rb rhead)
1628 else go1 SPEC cksum' rh' s acc'
1630 stepOuter gst (GO_EMPTY_PAT st) = do
1631 res <- step (adaptState gst) st
1636 done acc' >>= \r -> return $ Yield r (GO_EMPTY_PAT s)
1637 Skip s -> return $ Skip (GO_EMPTY_PAT s)
1640 stepOuter _ GO_DONE = return Stop
1642data SplitState s arr
1644 | SplitBuffering s arr
1645 | SplitSplitting s arr
1646 | SplitYielding arr (SplitState s arr)
1649-- XXX An alternative approach would be to use a partial fold (Fold m a b) to
1650-- split using a splitBy like combinator. The Fold would consume upto the
1651-- separator and return any leftover which can then be fed to the next fold.
1653-- We can revisit this once we have partial folds/parsers.
1655-- | Performs infix separator style splitting.
1656{-# INLINE_NORMAL splitInnerBy #-}
1659 => (f a -> m (f a, Maybe (f a))) -- splitter
1660 -> (f a -> f a -> m (f a)) -- joiner
1663splitInnerBy splitter joiner (Stream step1 state1) =
1664 (Stream step (SplitInitial state1))
1668 {-# INLINE_LATE step #-}
1669 step gst (SplitInitial st) = do
1673 (x1, mx2) <- splitter x
1674 return $ case mx2 of
1675 Nothing -> Skip (SplitBuffering s x1)
1676 Just x2 -> Skip (SplitYielding x1 (SplitSplitting s x2))
1677 Skip s -> return $ Skip (SplitInitial s)
1678 Stop -> return $ Stop
1680 step gst (SplitBuffering st buf) = do
1684 (x1, mx2) <- splitter x
1685 buf' <- joiner buf x1
1686 return $ case mx2 of
1687 Nothing -> Skip (SplitBuffering s buf')
1688 Just x2 -> Skip (SplitYielding buf' (SplitSplitting s x2))
1689 Skip s -> return $ Skip (SplitBuffering s buf)
1690 Stop -> return $ Skip (SplitYielding buf SplitFinishing)
1692 step _ (SplitSplitting st buf) = do
1693 (x1, mx2) <- splitter buf
1694 return $ case mx2 of
1695 Nothing -> Skip $ SplitBuffering st x1
1696 Just x2 -> Skip $ SplitYielding x1 (SplitSplitting st x2)
1698 step _ (SplitYielding x next) = return $ Yield x next
1699 step _ SplitFinishing = return $ Stop
1701-- | Performs infix separator style splitting.
1702{-# INLINE_NORMAL splitInnerBySuffix #-}
1704 :: (Monad m, Eq (f a), Monoid (f a))
1705 => (f a -> m (f a, Maybe (f a))) -- splitter
1706 -> (f a -> f a -> m (f a)) -- joiner
1709splitInnerBySuffix splitter joiner (Stream step1 state1) =
1710 (Stream step (SplitInitial state1))
1714 {-# INLINE_LATE step #-}
1715 step gst (SplitInitial st) = do
1719 (x1, mx2) <- splitter x
1720 return $ case mx2 of
1721 Nothing -> Skip (SplitBuffering s x1)
1722 Just x2 -> Skip (SplitYielding x1 (SplitSplitting s x2))
1723 Skip s -> return $ Skip (SplitInitial s)
1724 Stop -> return $ Stop
1726 step gst (SplitBuffering st buf) = do
1730 (x1, mx2) <- splitter x
1731 buf' <- joiner buf x1
1732 return $ case mx2 of
1733 Nothing -> Skip (SplitBuffering s buf')
1734 Just x2 -> Skip (SplitYielding buf' (SplitSplitting s x2))
1735 Skip s -> return $ Skip (SplitBuffering s buf)
1739 else Skip (SplitYielding buf SplitFinishing)
1741 step _ (SplitSplitting st buf) = do
1742 (x1, mx2) <- splitter buf
1743 return $ case mx2 of
1744 Nothing -> Skip $ SplitBuffering st x1
1745 Just x2 -> Skip $ SplitYielding x1 (SplitSplitting st x2)
1747 step _ (SplitYielding x next) = return $ Yield x next
1748 step _ SplitFinishing = return $ Stop
1750------------------------------------------------------------------------------
1752------------------------------------------------------------------------------
1754{-# INLINE_NORMAL isPrefixOf #-}
1755isPrefixOf :: (Eq a, Monad m) => Stream m a -> Stream m a -> m Bool
1756isPrefixOf (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)
1758 go (sa, sb, Nothing) = do
1759 r <- stepa defState sa
1761 Yield x sa' -> go (sa', sb, Just x)
1762 Skip sa' -> go (sa', sb, Nothing)
1765 go (sa, sb, Just x) = do
1766 r <- stepb defState sb
1770 then go (sa, sb', Nothing)
1772 Skip sb' -> go (sa, sb', Just x)
1773 Stop -> return False
1775{-# INLINE_NORMAL isSubsequenceOf #-}
1776isSubsequenceOf :: (Eq a, Monad m) => Stream m a -> Stream m a -> m Bool
1777isSubsequenceOf (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)
1779 go (sa, sb, Nothing) = do
1780 r <- stepa defState sa
1782 Yield x sa' -> go (sa', sb, Just x)
1783 Skip sa' -> go (sa', sb, Nothing)
1786 go (sa, sb, Just x) = do
1787 r <- stepb defState sb
1791 then go (sa, sb', Nothing)
1792 else go (sa, sb', Just x)
1793 Skip sb' -> go (sa, sb', Just x)
1794 Stop -> return False
1796{-# INLINE_NORMAL stripPrefix #-}
1799 => Stream m a -> Stream m a -> m (Maybe (Stream m a))
1800stripPrefix (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)
1802 go (sa, sb, Nothing) = do
1803 r <- stepa defState sa
1805 Yield x sa' -> go (sa', sb, Just x)
1806 Skip sa' -> go (sa', sb, Nothing)
1807 Stop -> return $ Just (Stream stepb sb)
1809 go (sa, sb, Just x) = do
1810 r <- stepb defState sb
1814 then go (sa, sb', Nothing)
1816 Skip sb' -> go (sa, sb', Just x)
1817 Stop -> return Nothing
1819------------------------------------------------------------------------------
1821------------------------------------------------------------------------------
1823-- | Execute a monadic action for each element of the 'Stream'
1824{-# INLINE_NORMAL mapM_ #-}
1825mapM_ :: Monad m => (a -> m b) -> Stream m a -> m ()
1826mapM_ m = drain . mapM m
1828-------------------------------------------------------------------------------
1829-- Stream transformations using Unfolds
1830-------------------------------------------------------------------------------
1832-- Define a unique structure to use in inspection testing
1833data ConcatMapUState o i =
1835 | ConcatMapUInner o i
1837-- | @concatMapU unfold stream@ uses @unfold@ to map the input stream elements
1838-- to streams and then flattens the generated streams into a single output
1841-- This is like 'concatMap' but uses an unfold with an explicit state to
1842-- generate the stream instead of a 'Stream' type generator. This allows better
1843-- optimization via fusion. This can be many times more efficient than
1846{-# INLINE_NORMAL concatMapU #-}
1847concatMapU :: Monad m => Unfold m a b -> Stream m a -> Stream m b
1848concatMapU (Unfold istep inject) (Stream ostep ost) =
1849 Stream step (ConcatMapUOuter ost)
1851 {-# INLINE_LATE step #-}
1852 step gst (ConcatMapUOuter o) = do
1853 r <- ostep (adaptState gst) o
1857 i `seq` return (Skip (ConcatMapUInner o' i))
1858 Skip o' -> return $ Skip (ConcatMapUOuter o')
1859 Stop -> return $ Stop
1861 step _ (ConcatMapUInner o i) = do
1864 Yield x i' -> Yield x (ConcatMapUInner o i')
1865 Skip i' -> Skip (ConcatMapUInner o i')
1866 Stop -> Skip (ConcatMapUOuter o)
1868data ConcatUnfoldInterleaveState o i =
1869 ConcatUnfoldInterleaveOuter o [i]
1870 | ConcatUnfoldInterleaveInner o [i]
1871 | ConcatUnfoldInterleaveInnerL [i] [i]
1872 | ConcatUnfoldInterleaveInnerR [i] [i]
1874-- XXX use arrays to store state instead of lists.
1875-- XXX In general we can use different scheduling strategies e.g. how to
1876-- schedule the outer vs inner loop or assigning weights to different streams
1877-- or outer and inner loops.
1879-- After a yield, switch to the next stream. Do not switch streams on Skip.
1880-- Yield from outer stream switches to the inner stream.
1882-- There are two choices here, (1) exhaust the outer stream first and then
1883-- start yielding from the inner streams, this is much simpler to implement,
1884-- (2) yield at least one element from an inner stream before going back to
1885-- outer stream and opening the next stream from it.
1887-- Ideally, we need some scheduling bias to inner streams vs outer stream.
1888-- Maybe we can configure the behavior.
1890{-# INLINE_NORMAL concatUnfoldInterleave #-}
1891concatUnfoldInterleave :: Monad m => Unfold m a b -> Stream m a -> Stream m b
1892concatUnfoldInterleave (Unfold istep inject) (Stream ostep ost) =
1893 Stream step (ConcatUnfoldInterleaveOuter ost [])
1895 {-# INLINE_LATE step #-}
1896 step gst (ConcatUnfoldInterleaveOuter o ls) = do
1897 r <- ostep (adaptState gst) o
1901 i `seq` return (Skip (ConcatUnfoldInterleaveInner o' (i : ls)))
1902 Skip o' -> return $ Skip (ConcatUnfoldInterleaveOuter o' ls)
1903 Stop -> return $ Skip (ConcatUnfoldInterleaveInnerL ls [])
1905 step _ (ConcatUnfoldInterleaveInner _ []) = undefined
1906 step _ (ConcatUnfoldInterleaveInner o (st:ls)) = do
1909 Yield x s -> Yield x (ConcatUnfoldInterleaveOuter o (s:ls))
1910 Skip s -> Skip (ConcatUnfoldInterleaveInner o (s:ls))
1911 Stop -> Skip (ConcatUnfoldInterleaveOuter o ls)
1913 step _ (ConcatUnfoldInterleaveInnerL [] []) = return Stop
1914 step _ (ConcatUnfoldInterleaveInnerL [] rs) =
1915 return $ Skip (ConcatUnfoldInterleaveInnerR [] rs)
1917 step _ (ConcatUnfoldInterleaveInnerL (st:ls) rs) = do
1920 Yield x s -> Yield x (ConcatUnfoldInterleaveInnerL ls (s:rs))
1921 Skip s -> Skip (ConcatUnfoldInterleaveInnerL (s:ls) rs)
1922 Stop -> Skip (ConcatUnfoldInterleaveInnerL ls rs)
1924 step _ (ConcatUnfoldInterleaveInnerR [] []) = return Stop
1925 step _ (ConcatUnfoldInterleaveInnerR ls []) =
1926 return $ Skip (ConcatUnfoldInterleaveInnerL ls [])
1928 step _ (ConcatUnfoldInterleaveInnerR ls (st:rs)) = do
1931 Yield x s -> Yield x (ConcatUnfoldInterleaveInnerR (s:ls) rs)
1932 Skip s -> Skip (ConcatUnfoldInterleaveInnerR ls (s:rs))
1933 Stop -> Skip (ConcatUnfoldInterleaveInnerR ls rs)
1935-- XXX In general we can use different scheduling strategies e.g. how to
1936-- schedule the outer vs inner loop or assigning weights to different streams
1937-- or outer and inner loops.
1939-- This could be inefficient if the tasks are too small.
1941-- Compared to concatUnfoldInterleave this one switches streams on Skips.
1943{-# INLINE_NORMAL concatUnfoldRoundrobin #-}
1944concatUnfoldRoundrobin :: Monad m => Unfold m a b -> Stream m a -> Stream m b
1945concatUnfoldRoundrobin (Unfold istep inject) (Stream ostep ost) =
1946 Stream step (ConcatUnfoldInterleaveOuter ost [])
1948 {-# INLINE_LATE step #-}
1949 step gst (ConcatUnfoldInterleaveOuter o ls) = do
1950 r <- ostep (adaptState gst) o
1954 i `seq` return (Skip (ConcatUnfoldInterleaveInner o' (i : ls)))
1955 Skip o' -> return $ Skip (ConcatUnfoldInterleaveInner o' ls)
1956 Stop -> return $ Skip (ConcatUnfoldInterleaveInnerL ls [])
1958 step _ (ConcatUnfoldInterleaveInner o []) =
1959 return $ Skip (ConcatUnfoldInterleaveOuter o [])
1961 step _ (ConcatUnfoldInterleaveInner o (st:ls)) = do
1964 Yield x s -> Yield x (ConcatUnfoldInterleaveOuter o (s:ls))
1965 Skip s -> Skip (ConcatUnfoldInterleaveOuter o (s:ls))
1966 Stop -> Skip (ConcatUnfoldInterleaveOuter o ls)
1968 step _ (ConcatUnfoldInterleaveInnerL [] []) = return Stop
1969 step _ (ConcatUnfoldInterleaveInnerL [] rs) =
1970 return $ Skip (ConcatUnfoldInterleaveInnerR [] rs)
1972 step _ (ConcatUnfoldInterleaveInnerL (st:ls) rs) = do
1975 Yield x s -> Yield x (ConcatUnfoldInterleaveInnerL ls (s:rs))
1976 Skip s -> Skip (ConcatUnfoldInterleaveInnerL ls (s:rs))
1977 Stop -> Skip (ConcatUnfoldInterleaveInnerL ls rs)
1979 step _ (ConcatUnfoldInterleaveInnerR [] []) = return Stop
1980 step _ (ConcatUnfoldInterleaveInnerR ls []) =
1981 return $ Skip (ConcatUnfoldInterleaveInnerL ls [])
1983 step _ (ConcatUnfoldInterleaveInnerR ls (st:rs)) = do
1986 Yield x s -> Yield x (ConcatUnfoldInterleaveInnerR (s:ls) rs)
1987 Skip s -> Skip (ConcatUnfoldInterleaveInnerR (s:ls) rs)
1988 Stop -> Skip (ConcatUnfoldInterleaveInnerR ls rs)
1990data AppendState s1 s2 = AppendFirst s1 | AppendSecond s2
1992-- Note that this could be much faster compared to the CPS stream. However, as
1993-- the number of streams being composed increases this may become expensive.
1994-- Need to see where the breaking point is between the two.
1996{-# INLINE_NORMAL append #-}
1997append :: Monad m => Stream m a -> Stream m a -> Stream m a
1998append (Stream step1 state1) (Stream step2 state2) =
1999 Stream step (AppendFirst state1)
2003 {-# INLINE_LATE step #-}
2004 step gst (AppendFirst st) = do
2007 Yield a s -> Yield a (AppendFirst s)
2008 Skip s -> Skip (AppendFirst s)
2009 Stop -> Skip (AppendSecond state2)
2011 step gst (AppendSecond st) = do
2014 Yield a s -> Yield a (AppendSecond s)
2015 Skip s -> Skip (AppendSecond s)
2018data InterleaveState s1 s2 = InterleaveFirst s1 s2 | InterleaveSecond s1 s2
2019 | InterleaveSecondOnly s2 | InterleaveFirstOnly s1
2021{-# INLINE_NORMAL interleave #-}
2022interleave :: Monad m => Stream m a -> Stream m a -> Stream m a
2023interleave (Stream step1 state1) (Stream step2 state2) =
2024 Stream step (InterleaveFirst state1 state2)
2028 {-# INLINE_LATE step #-}
2029 step gst (InterleaveFirst st1 st2) = do
2032 Yield a s -> Yield a (InterleaveSecond s st2)
2033 Skip s -> Skip (InterleaveFirst s st2)
2034 Stop -> Skip (InterleaveSecondOnly st2)
2036 step gst (InterleaveSecond st1 st2) = do
2039 Yield a s -> Yield a (InterleaveFirst st1 s)
2040 Skip s -> Skip (InterleaveSecond st1 s)
2041 Stop -> Skip (InterleaveFirstOnly st1)
2043 step gst (InterleaveFirstOnly st1) = do
2046 Yield a s -> Yield a (InterleaveFirstOnly s)
2047 Skip s -> Skip (InterleaveFirstOnly s)
2050 step gst (InterleaveSecondOnly st2) = do
2053 Yield a s -> Yield a (InterleaveSecondOnly s)
2054 Skip s -> Skip (InterleaveSecondOnly s)
2057{-# INLINE_NORMAL interleaveMin #-}
2058interleaveMin :: Monad m => Stream m a -> Stream m a -> Stream m a
2059interleaveMin (Stream step1 state1) (Stream step2 state2) =
2060 Stream step (InterleaveFirst state1 state2)
2064 {-# INLINE_LATE step #-}
2065 step gst (InterleaveFirst st1 st2) = do
2068 Yield a s -> Yield a (InterleaveSecond s st2)
2069 Skip s -> Skip (InterleaveFirst s st2)
2072 step gst (InterleaveSecond st1 st2) = do
2075 Yield a s -> Yield a (InterleaveFirst st1 s)
2076 Skip s -> Skip (InterleaveSecond st1 s)
2079 step _ (InterleaveFirstOnly _) = undefined
2080 step _ (InterleaveSecondOnly _) = undefined
2082{-# INLINE_NORMAL interleaveFst #-}
2083interleaveFst :: Monad m => Stream m a -> Stream m a -> Stream m a
2084interleaveFst (Stream step1 state1) (Stream step2 state2) =
2085 Stream step (InterleaveFirst state1 state2)
2089 {-# INLINE_LATE step #-}
2090 step gst (InterleaveFirst st1 st2) = do
2093 Yield a s -> Yield a (InterleaveSecond s st2)
2094 Skip s -> Skip (InterleaveFirst s st2)
2097 step gst (InterleaveSecond st1 st2) = do
2100 Yield a s -> Yield a (InterleaveFirst st1 s)
2101 Skip s -> Skip (InterleaveSecond st1 s)
2102 Stop -> Skip (InterleaveFirstOnly st1)
2104 step gst (InterleaveFirstOnly st1) = do
2107 Yield a s -> Yield a (InterleaveFirstOnly s)
2108 Skip s -> Skip (InterleaveFirstOnly s)
2111 step _ (InterleaveSecondOnly _) = undefined
2113{-# INLINE_NORMAL roundRobin #-}
2114roundRobin :: Monad m => Stream m a -> Stream m a -> Stream m a
2115roundRobin (Stream step1 state1) (Stream step2 state2) =
2116 Stream step (InterleaveFirst state1 state2)
2120 {-# INLINE_LATE step #-}
2121 step gst (InterleaveFirst st1 st2) = do
2124 Yield a s -> Yield a (InterleaveSecond s st2)
2125 Skip s -> Skip (InterleaveSecond s st2)
2126 Stop -> Skip (InterleaveSecondOnly st2)
2128 step gst (InterleaveSecond st1 st2) = do
2131 Yield a s -> Yield a (InterleaveFirst st1 s)
2132 Skip s -> Skip (InterleaveFirst st1 s)
2133 Stop -> Skip (InterleaveFirstOnly st1)
2135 step gst (InterleaveSecondOnly st2) = do
2138 Yield a s -> Yield a (InterleaveSecondOnly s)
2139 Skip s -> Skip (InterleaveSecondOnly s)
2142 step gst (InterleaveFirstOnly st1) = do
2145 Yield a s -> Yield a (InterleaveFirstOnly s)
2146 Skip s -> Skip (InterleaveFirstOnly s)
2149data ICUState s1 s2 i1 i2 =
2154 | ICUFirstInner s1 s2 i1
2155 | ICUSecondInner s1 s2 i2
2156 | ICUFirstOnlyInner s1 i1
2157 | ICUSecondOnlyInner s2 i2
2159-- | Interleave streams (full streams, not the elements) unfolded from two
2160-- input streams and concat. Stop when the first stream stops. If the second
2161-- stream ends before the first one then first stream still keeps running alone
2162-- without any interleaving with the second stream.
2164-- [a1, a2, ... an] [b1, b2 ...]
2165-- => [streamA1, streamA2, ... streamAn] [streamB1, streamB2, ...]
2166-- => [streamA1, streamB1, streamA2...StreamAn, streamBn]
2167-- => [a11, a12, ...a1j, b11, b12, ...b1k, a21, a22, ...]
2169{-# INLINE_NORMAL interleaveFstThenConcat #-}
2170interleaveFstThenConcat
2172 => Unfold m a c -> Stream m a -> Unfold m b c -> Stream m b -> Stream m c
2173interleaveFstThenConcat
2174 (Unfold istep1 inject1) (Stream step1 state1)
2175 (Unfold istep2 inject2) (Stream step2 state2) =
2176 Stream step (ICUFirst state1 state2)
2180 {-# INLINE_LATE step #-}
2181 step gst (ICUFirst s1 s2) = do
2182 r <- step1 (adaptState gst) s1
2186 i `seq` return (Skip (ICUFirstInner s s2 i))
2187 Skip s -> return $ Skip (ICUFirst s s2)
2190 step gst (ICUFirstOnly s1) = do
2191 r <- step1 (adaptState gst) s1
2195 i `seq` return (Skip (ICUFirstOnlyInner s i))
2196 Skip s -> return $ Skip (ICUFirstOnly s)
2199 step _ (ICUFirstInner s1 s2 i1) = do
2202 Yield x i' -> Yield x (ICUFirstInner s1 s2 i')
2203 Skip i' -> Skip (ICUFirstInner s1 s2 i')
2204 Stop -> Skip (ICUSecond s1 s2)
2206 step _ (ICUFirstOnlyInner s1 i1) = do
2209 Yield x i' -> Yield x (ICUFirstOnlyInner s1 i')
2210 Skip i' -> Skip (ICUFirstOnlyInner s1 i')
2211 Stop -> Skip (ICUFirstOnly s1)
2213 step gst (ICUSecond s1 s2) = do
2214 r <- step2 (adaptState gst) s2
2218 i `seq` return (Skip (ICUSecondInner s1 s i))
2219 Skip s -> return $ Skip (ICUSecond s1 s)
2220 Stop -> return $ Skip (ICUFirstOnly s1)
2222 step _ (ICUSecondInner s1 s2 i2) = do
2225 Yield x i' -> Yield x (ICUSecondInner s1 s2 i')
2226 Skip i' -> Skip (ICUSecondInner s1 s2 i')
2227 Stop -> Skip (ICUFirst s1 s2)
2229 step _ (ICUSecondOnly _s2) = undefined
2230 step _ (ICUSecondOnlyInner _s2 _i2) = undefined
2232------------------------------------------------------------------------------
2234------------------------------------------------------------------------------
2236-- | Run a side effect before the stream yields its first element.
2237{-# INLINE_NORMAL before #-}
2238before :: Monad m => m b -> Stream m a -> Stream m a
2239before action (Stream step state) = Stream step' Nothing
2243 {-# INLINE_LATE step' #-}
2244 step' _ Nothing = action >> return (Skip (Just state))
2246 step' gst (Just st) = do
2249 Yield x s -> return $ Yield x (Just s)
2250 Skip s -> return $ Skip (Just s)
2253-- | Run a side effect whenever the stream stops normally.
2254{-# INLINE_NORMAL after #-}
2255after :: Monad m => m b -> Stream m a -> Stream m a
2256after action (Stream step state) = Stream step' state
2260 {-# INLINE_LATE step' #-}
2264 Yield x s -> return $ Yield x s
2265 Skip s -> return $ Skip s
2266 Stop -> action >> return Stop
2268-- XXX These combinators are expensive due to the call to
2269-- onException/handle/try on each step. Therefore, when possible, they should
2270-- be called in an outer loop where we perform less iterations. For example, we
2271-- cannot call them on each iteration in a char stream, instead we can call
2272-- them when doing an IO on an array.
2274-- XXX For high performance error checks in busy streams we may need another
2275-- Error constructor in step.
2277-- | Run a side effect whenever the stream aborts due to an exception. The
2278-- exception is not caught simply rethrown.
2279{-# INLINE_NORMAL onException #-}
2280onException :: MonadCatch m => m b -> Stream m a -> Stream m a
2281onException action (Stream step state) = Stream step' state
2285 {-# INLINE_LATE step' #-}
2287 res <- step gst st `MC.onException` action
2289 Yield x s -> return $ Yield x s
2290 Skip s -> return $ Skip s
2293-- | Run a side effect whenever the stream stops normally or aborts due to an
2295{-# INLINE finally #-}
2296finally :: MonadCatch m => m b -> Stream m a -> Stream m a
2297finally action xs = after action $ onException action xs
2299-- XXX bracket is like concatMap, it generates a stream and then flattens it.
2300-- Like concatMap it has 10x worse performance compared to linear fused
2303-- | Run the first action before the stream starts and remember its output,
2304-- generate a stream using the output, run the second action using the
2305-- remembered value as an argument whenever the stream ends normally or due to
2307{-# INLINE_NORMAL bracket #-}
2308bracket :: MonadCatch m => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a
2309bracket bef aft bet = Stream step' Nothing
2313 {-# INLINE_LATE step' #-}
2314 step' _ Nothing = bef >>= \x -> return (Skip (Just (bet x, x)))
2316 -- NOTE: It is important to use UnStream instead of the Stream pattern
2317 -- here, otherwise we get huge perf degradation, see note in concatMap.
2318 step' gst (Just (UnStream step state, v)) = do
2319 res <- step gst state `MC.onException` aft v
2321 Yield x s -> return $ Yield x (Just (Stream step s, v))
2322 Skip s -> return $ Skip (Just (Stream step s, v))
2323 Stop -> aft v >> return Stop
2325-- | When evaluating a stream if an exception occurs, stream evaluation aborts
2326-- and the specified exception handler is run with the exception as argument.
2327{-# INLINE_NORMAL handle #-}
2328handle :: (MonadCatch m, Exception e) => (e -> m a) -> Stream m a -> Stream m a
2329handle f (Stream step state) = Stream step' (Just state)
2333 {-# INLINE_LATE step' #-}
2334 step' gst (Just st) = do
2335 res <- MC.try $ step gst st
2337 Left e -> f e >>= \x -> return (Yield x Nothing)
2338 Right r -> case r of
2339 Yield x s -> return $ Yield x (Just s)
2340 Skip s -> return $ Skip (Just s)
2343 step' _ Nothing = return Stop
2345-------------------------------------------------------------------------------
2346-- General transformation
2347-------------------------------------------------------------------------------
2349{-# INLINE_NORMAL transform #-}
2350transform :: Monad m => Pipe m a b -> Stream m a -> Stream m b
2351transform (Pipe pstep1 pstep2 pstate) (Stream step state) =
2352 Stream step' (Consume pstate, state)
2356 {-# INLINE_LATE step' #-}
2358 step' gst (Consume pst, st) = pst `seq` do
2359 r <- step (adaptState gst) st
2364 Pipe.Yield b pst' -> return $ Yield b (pst', s)
2365 Pipe.Continue pst' -> return $ Skip (pst', s)
2366 Skip s -> return $ Skip (Consume pst, s)
2369 step' _ (Produce pst, st) = pst `seq` do
2372 Pipe.Yield b pst' -> return $ Yield b (pst', st)
2373 Pipe.Continue pst' -> return $ Skip (pst', st)
2375------------------------------------------------------------------------------
2376-- Transformation by Folding (Scans)
2377------------------------------------------------------------------------------
2379------------------------------------------------------------------------------
2381------------------------------------------------------------------------------
2383-- XXX Is a prescan useful, discarding the last step does not sound useful? I
2384-- am not sure about the utility of this function, so this is implemented but
2385-- not exposed. We can expose it if someone provides good reasons why this is
2388-- XXX We have to execute the stream one step ahead to know that we are at the
2389-- last step. The vector implementation of prescan executes the last fold step
2390-- but does not yield the result. This means we have executed the effect but
2391-- discarded value. This does not sound right. In this implementation we are
2392-- not executing the last fold step.
2393{-# INLINE_NORMAL prescanlM' #-}
2394prescanlM' :: Monad m => (b -> a -> m b) -> m b -> Stream m a -> Stream m b
2395prescanlM' f mz (Stream step state) = Stream step' (state, mz)
2397 {-# INLINE_LATE step' #-}
2398 step' gst (st, prev) = do
2399 r <- step (adaptState gst) st
2403 return $ Yield acc (s, f acc x)
2404 Skip s -> return $ Skip (s, prev)
2407{-# INLINE prescanl' #-}
2408prescanl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b
2409prescanl' f z = prescanlM' (\a b -> return (f a b)) (return z)
2411------------------------------------------------------------------------------
2412-- Monolithic postscans (postscan followed by a map)
2413------------------------------------------------------------------------------
2415-- The performance of a modular postscan followed by a map seems to be
2416-- equivalent to this monolithic scan followed by map therefore we may not need
2417-- this implementation. We just have it for performance comparison and in case
2418-- modular version does not perform well in some situation.
2420{-# INLINE_NORMAL postscanlMx' #-}
2421postscanlMx' :: Monad m
2422 => (x -> a -> m x) -> m x -> (x -> m b) -> Stream m a -> Stream m b
2423postscanlMx' fstep begin done (Stream step state) = do
2424 Stream step' (state, begin)
2426 {-# INLINE_LATE step' #-}
2427 step' gst (st, acc) = do
2428 r <- step (adaptState gst) st
2434 v `seq` y `seq` return (Yield v (s, return y))
2435 Skip s -> return $ Skip (s, acc)
2438{-# INLINE_NORMAL postscanlx' #-}
2439postscanlx' :: Monad m
2440 => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> Stream m b
2441postscanlx' fstep begin done s =
2442 postscanlMx' (\b a -> return (fstep b a)) (return begin) (return . done) s
2444-- XXX do we need consM strict to evaluate the begin value?
2445{-# INLINE scanlMx' #-}
2447 => (x -> a -> m x) -> m x -> (x -> m b) -> Stream m a -> Stream m b
2448scanlMx' fstep begin done s =
2449 (begin >>= \x -> x `seq` done x) `consM` postscanlMx' fstep begin done s
2451{-# INLINE scanlx' #-}
2453 => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> Stream m b
2454scanlx' fstep begin done s =
2455 scanlMx' (\b a -> return (fstep b a)) (return begin) (return . done) s
2457------------------------------------------------------------------------------
2459------------------------------------------------------------------------------
2461{-# INLINE_NORMAL postscanlM' #-}
2462postscanlM' :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
2463postscanlM' fstep begin (Stream step state) =
2464 begin `seq` Stream step' (state, begin)
2466 {-# INLINE_LATE step' #-}
2467 step' gst (st, acc) = acc `seq` do
2468 r <- step (adaptState gst) st
2472 y `seq` return (Yield y (s, y))
2473 Skip s -> return $ Skip (s, acc)
2476{-# INLINE_NORMAL postscanl' #-}
2477postscanl' :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a
2478postscanl' f = postscanlM' (\a b -> return (f a b))
2480{-# INLINE_NORMAL postscanlM #-}
2481postscanlM :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
2482postscanlM fstep begin (Stream step state) = Stream step' (state, begin)
2484 {-# INLINE_LATE step' #-}
2485 step' gst (st, acc) = do
2486 r <- step (adaptState gst) st
2490 return (Yield y (s, y))
2491 Skip s -> return $ Skip (s, acc)
2494{-# INLINE_NORMAL postscanl #-}
2495postscanl :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a
2496postscanl f = postscanlM (\a b -> return (f a b))
2498{-# INLINE_NORMAL scanlM' #-}
2499scanlM' :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
2500scanlM' fstep begin s = begin `seq` (begin `cons` postscanlM' fstep begin s)
2502{-# INLINE scanl' #-}
2503scanl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b
2504scanl' f = scanlM' (\a b -> return (f a b))
2506{-# INLINE_NORMAL scanlM #-}
2507scanlM :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
2508scanlM fstep begin s = begin `cons` postscanlM fstep begin s
2511scanl :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b
2512scanl f = scanlM (\a b -> return (f a b))
2514{-# INLINE_NORMAL scanl1M #-}
2515scanl1M :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a
2516scanl1M fstep (Stream step state) = Stream step' (state, Nothing)
2518 {-# INLINE_LATE step' #-}
2519 step' gst (st, Nothing) = do
2522 Yield x s -> return $ Yield x (s, Just x)
2523 Skip s -> return $ Skip (s, Nothing)
2526 step' gst (st, Just acc) = do
2531 return $ Yield z (s, Just z)
2532 Skip s -> return $ Skip (s, Just acc)
2535{-# INLINE scanl1 #-}
2536scanl1 :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a
2537scanl1 f = scanl1M (\x y -> return (f x y))
2539{-# INLINE_NORMAL scanl1M' #-}
2540scanl1M' :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a
2541scanl1M' fstep (Stream step state) = Stream step' (state, Nothing)
2543 {-# INLINE_LATE step' #-}
2544 step' gst (st, Nothing) = do
2547 Yield x s -> x `seq` return $ Yield x (s, Just x)
2548 Skip s -> return $ Skip (s, Nothing)
2551 step' gst (st, Just acc) = acc `seq` do
2556 z `seq` return $ Yield z (s, Just z)
2557 Skip s -> return $ Skip (s, Just acc)
2560{-# INLINE scanl1' #-}
2561scanl1' :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a
2562scanl1' f = scanl1M' (\x y -> return (f x y))
2565tap :: Monad m => Fold m a b -> Stream m a -> Stream m a
2566tap (Fold fstep initial extract) (Stream step state) = Stream step' Nothing
2570 step' _ Nothing = do
2572 return $ Skip (Just (r, state))
2574 step' gst (Just (acc, st)) = do
2579 return $ Yield x (Just (acc', s))
2580 Skip s -> return $ Skip (Just (acc, s))
2585-------------------------------------------------------------------------------
2587-------------------------------------------------------------------------------
2589{-# INLINE_NORMAL takeWhileM #-}
2590takeWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a
2591takeWhileM f (Stream step state) = Stream step' state
2593 {-# INLINE_LATE step' #-}
2599 return $ if b then Yield x s else Stop
2600 Skip s -> return $ Skip s
2603{-# INLINE takeWhile #-}
2604takeWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
2605takeWhile f = takeWhileM (return . f)
2607{-# INLINE_NORMAL drop #-}
2608drop :: Monad m => Int -> Stream m a -> Stream m a
2609drop n (Stream step state) = Stream step' (state, Just n)
2611 {-# INLINE_LATE step' #-}
2612 step' gst (st, Just i)
2617 Yield _ s -> Skip (s, Just (i - 1))
2618 Skip s -> Skip (s, Just i)
2620 | otherwise = return $ Skip (st, Nothing)
2622 step' gst (st, Nothing) = do
2626 Yield x s -> Yield x (s, Nothing)
2627 Skip s -> Skip (s, Nothing)
2630data DropWhileState s a
2632 | DropWhileYield a s
2635{-# INLINE_NORMAL dropWhileM #-}
2636dropWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a
2637dropWhileM f (Stream step state) = Stream step' (DropWhileDrop state)
2639 {-# INLINE_LATE step' #-}
2640 step' gst (DropWhileDrop st) = do
2646 then return $ Skip (DropWhileDrop s)
2647 else return $ Skip (DropWhileYield x s)
2648 Skip s -> return $ Skip (DropWhileDrop s)
2651 step' gst (DropWhileNext st) = do
2654 Yield x s -> return $ Skip (DropWhileYield x s)
2655 Skip s -> return $ Skip (DropWhileNext s)
2658 step' _ (DropWhileYield x st) = return $ Yield x (DropWhileNext st)
2660{-# INLINE dropWhile #-}
2661dropWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
2662dropWhile f = dropWhileM (return . f)
2664{-# INLINE_NORMAL filterM #-}
2665filterM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a
2666filterM f (Stream step state) = Stream step' state
2668 {-# INLINE_LATE step' #-}
2677 Skip s -> return $ Skip s
2680{-# INLINE filter #-}
2681filter :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
2682filter f = filterM (return . f)
2684{-# INLINE_NORMAL uniq #-}
2685uniq :: (Eq a, Monad m) => Stream m a -> Stream m a
2686uniq (Stream step state) = Stream step' (Nothing, state)
2688 {-# INLINE_LATE step' #-}
2689 step' gst (Nothing, st) = do
2692 Yield x s -> return $ Yield x (Just x, s)
2693 Skip s -> return $ Skip (Nothing, s)
2695 step' gst (Just x, st) = do
2698 Yield y s | x == y -> return $ Skip (Just x, s)
2699 | otherwise -> return $ Yield y (Just y, s)
2700 Skip s -> return $ Skip (Just x, s)
2703------------------------------------------------------------------------------
2704-- Transformation by Mapping
2705------------------------------------------------------------------------------
2707{-# INLINE_NORMAL sequence #-}
2708sequence :: Monad m => Stream m (m a) -> Stream m a
2709sequence (Stream step state) = Stream step' state
2711 {-# INLINE_LATE step' #-}
2713 r <- step (adaptState gst) st
2715 Yield x s -> x >>= \a -> return (Yield a s)
2716 Skip s -> return $ Skip s
2719------------------------------------------------------------------------------
2721------------------------------------------------------------------------------
2723data LoopState x s = FirstYield s
2724 | InterspersingYield s
2727{-# INLINE_NORMAL intersperseM #-}
2728intersperseM :: Monad m => m a -> Stream m a -> Stream m a
2729intersperseM m (Stream step state) = Stream step' (FirstYield state)
2731 {-# INLINE_LATE step' #-}
2732 step' gst (FirstYield st) = do
2736 Yield x s -> Skip (YieldAndCarry x s)
2737 Skip s -> Skip (FirstYield s)
2740 step' gst (InterspersingYield st) = do
2745 return $ Yield a (YieldAndCarry x s)
2746 Skip s -> return $ Skip $ InterspersingYield s
2749 step' _ (YieldAndCarry x st) = return $ Yield x (InterspersingYield st)
2754 | SuffixYield a (SuffixState s a)
2756{-# INLINE_NORMAL insertAfterEach #-}
2757insertAfterEach :: forall m a. Monad m => m a -> Stream m a -> Stream m a
2758insertAfterEach action (Stream step state) = Stream step' (SuffixElem state)
2760 {-# INLINE_LATE step' #-}
2761 step' gst (SuffixElem st) = do
2764 Yield x s -> Skip (SuffixYield x (SuffixSuffix s))
2765 Skip s -> Skip (SuffixElem s)
2768 step' _ (SuffixSuffix st) = do
2769 action >>= \r -> return $ Skip (SuffixYield r (SuffixElem st))
2771 step' _ (SuffixYield x next) = return $ Yield x next
2773{-# INLINE intersperse #-}
2774intersperse :: Monad m => a -> Stream m a -> Stream m a
2775intersperse a = intersperseM (return a)
2777{-# INLINE_NORMAL insertBy #-}
2778insertBy :: Monad m => (a -> a -> Ordering) -> a -> Stream m a -> Stream m a
2779insertBy cmp a (Stream step state) = Stream step' (state, False, Nothing)
2781 {-# INLINE_LATE step' #-}
2782 step' gst (st, False, _) = do
2785 Yield x s -> case cmp a x of
2786 GT -> return $ Yield x (s, False, Nothing)
2787 _ -> return $ Yield a (s, True, Just x)
2788 Skip s -> return $ Skip (s, False, Nothing)
2789 Stop -> return $ Yield a (st, True, Nothing)
2791 step' _ (_, True, Nothing) = return Stop
2793 step' gst (st, True, Just prev) = do
2796 Yield x s -> return $ Yield prev (s, True, Just x)
2797 Skip s -> return $ Skip (s, True, Just prev)
2798 Stop -> return $ Yield prev (st, True, Nothing)
2800------------------------------------------------------------------------------
2802------------------------------------------------------------------------------
2804{-# INLINE_NORMAL deleteBy #-}
2805deleteBy :: Monad m => (a -> a -> Bool) -> a -> Stream m a -> Stream m a
2806deleteBy eq x (Stream step state) = Stream step' (state, False)
2808 {-# INLINE_LATE step' #-}
2809 step' gst (st, False) = do
2812 Yield y s -> return $
2813 if eq x y then Skip (s, True) else Yield y (s, False)
2814 Skip s -> return $ Skip (s, False)
2817 step' gst (st, True) = do
2820 Yield y s -> return $ Yield y (s, True)
2821 Skip s -> return $ Skip (s, True)
2824------------------------------------------------------------------------------
2825-- Transformation by Map and Filter
2826------------------------------------------------------------------------------
2828-- XXX Will this always fuse properly?
2829{-# INLINE_NORMAL mapMaybe #-}
2830mapMaybe :: Monad m => (a -> Maybe b) -> Stream m a -> Stream m b
2831mapMaybe f = fmap fromJust . filter isJust . map f
2833{-# INLINE_NORMAL mapMaybeM #-}
2834mapMaybeM :: Monad m => (a -> m (Maybe b)) -> Stream m a -> Stream m b
2835mapMaybeM f = fmap fromJust . filter isJust . mapM f
2837------------------------------------------------------------------------------
2839------------------------------------------------------------------------------
2841{-# INLINE_NORMAL indexed #-}
2842indexed :: Monad m => Stream m a -> Stream m (Int, a)
2843indexed (Stream step state) = Stream step' (state, 0)
2845 {-# INLINE_LATE step' #-}
2846 step' gst (st, i) = i `seq` do
2847 r <- step (adaptState gst) st
2849 Yield x s -> return $ Yield (i, x) (s, i+1)
2850 Skip s -> return $ Skip (s, i)
2853{-# INLINE_NORMAL indexedR #-}
2854indexedR :: Monad m => Int -> Stream m a -> Stream m (Int, a)
2855indexedR m (Stream step state) = Stream step' (state, m)
2857 {-# INLINE_LATE step' #-}
2858 step' gst (st, i) = i `seq` do
2859 r <- step (adaptState gst) st
2861 Yield x s -> let i' = i - 1
2862 in return $ Yield (i, x) (s, i')
2863 Skip s -> return $ Skip (s, i)
2866{-# INLINE_NORMAL zipWithM #-}
2868 => (a -> b -> m c) -> Stream m a -> Stream m b -> Stream m c
2869zipWithM f (Stream stepa ta) (Stream stepb tb) = Stream step (ta, tb, Nothing)
2871 {-# INLINE_LATE step #-}
2872 step gst (sa, sb, Nothing) = do
2873 r <- stepa (adaptState gst) sa
2876 Yield x sa' -> Skip (sa', sb, Just x)
2877 Skip sa' -> Skip (sa', sb, Nothing)
2880 step gst (sa, sb, Just x) = do
2881 r <- stepb (adaptState gst) sb
2885 return $ Yield z (sa, sb', Nothing)
2886 Skip sb' -> return $ Skip (sa, sb', Just x)
2889#if __GLASGOW_HASKELL__ >= 801
2890{-# RULES "zipWithM xs xs"
2891 forall f xs. zipWithM @Identity f xs xs = mapM (\x -> f x x) xs #-}
2894{-# INLINE zipWith #-}
2895zipWith :: Monad m => (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c
2896zipWith f = zipWithM (\a b -> return (f a b))
2898------------------------------------------------------------------------------
2900------------------------------------------------------------------------------
2902{-# INLINE_NORMAL mergeByM #-}
2905 => (a -> a -> m Ordering) -> Stream m a -> Stream m a -> Stream m a
2906mergeByM cmp (Stream stepa ta) (Stream stepb tb) =
2907 Stream step (Just ta, Just tb, Nothing, Nothing)
2909 {-# INLINE_LATE step #-}
2911 -- one of the values is missing, and the corresponding stream is running
2912 step gst (Just sa, sb, Nothing, b) = do
2915 Yield a sa' -> Skip (Just sa', sb, Just a, b)
2916 Skip sa' -> Skip (Just sa', sb, Nothing, b)
2917 Stop -> Skip (Nothing, sb, Nothing, b)
2919 step gst (sa, Just sb, a, Nothing) = do
2922 Yield b sb' -> Skip (sa, Just sb', a, Just b)
2923 Skip sb' -> Skip (sa, Just sb', a, Nothing)
2924 Stop -> Skip (sa, Nothing, a, Nothing)
2926 -- both the values are available
2927 step _ (sa, sb, Just a, Just b) = do
2929 return $ case res of
2930 GT -> Yield b (sa, sb, Just a, Nothing)
2931 _ -> Yield a (sa, sb, Nothing, Just b)
2933 -- one of the values is missing, corresponding stream is done
2934 step _ (Nothing, sb, Nothing, Just b) =
2935 return $ Yield b (Nothing, sb, Nothing, Nothing)
2937 step _ (sa, Nothing, Just a, Nothing) =
2938 return $ Yield a (sa, Nothing, Nothing, Nothing)
2940 step _ (Nothing, Nothing, Nothing, Nothing) = return Stop
2942{-# INLINE mergeBy #-}
2945 => (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a
2946mergeBy cmp = mergeByM (\a b -> return $ cmp a b)
2948------------------------------------------------------------------------------
2949-- Transformation comprehensions
2950------------------------------------------------------------------------------
2952{-# INLINE_NORMAL the #-}
2953the :: (Eq a, Monad m) => Stream m a -> m (Maybe a)
2954the (Stream step state) = go state
2957 r <- step defState st
2959 Yield x s -> go' x s
2961 Stop -> return Nothing
2963 r <- step defState st
2965 Yield x s | x == n -> go' n s
2966 | otherwise -> return Nothing
2968 Stop -> return (Just n)
2970--------------------------------------------------------------------------------
2971-- UTF8 Encoding / Decoding
2972--------------------------------------------------------------------------------
2974-- UTF-8 primitives, Lifted from GHC.IO.Encoding.UTF8.
2977ord2 :: Char -> WList
2978ord2 c = assert (n >= 0x80 && n <= 0x07ff) (WCons x1 (WCons x2 WNil))
2981 x1 = fromIntegral $ (n `shiftR` 6) + 0xC0
2982 x2 = fromIntegral $ (n .&. 0x3F) + 0x80
2985ord3 :: Char -> WList
2986ord3 c = assert (n >= 0x0800 && n <= 0xffff) (WCons x1 (WCons x2 (WCons x3 WNil)))
2989 x1 = fromIntegral $ (n `shiftR` 12) + 0xE0
2990 x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
2991 x3 = fromIntegral $ (n .&. 0x3F) + 0x80
2994ord4 :: Char -> WList
2995ord4 c = assert (n >= 0x10000) (WCons x1 (WCons x2 (WCons x3 (WCons x4 WNil))))
2998 x1 = fromIntegral $ (n `shiftR` 18) + 0xF0
2999 x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80
3000 x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
3001 x4 = fromIntegral $ (n .&. 0x3F) + 0x80
3003data CodingFailureMode
3004 = TransliterateCodingFailure
3005 | ErrorOnCodingFailure
3008{-# INLINE replacementChar #-}
3009replacementChar :: Char
3010replacementChar = '\xFFFD'
3012type CodePoint = Word32
3013type DecoderState = Word8
3015-- See http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ for details.
3017utf8d :: A.Array Word8
3019 -- The first part of the table maps bytes to character classes that
3020 -- to reduce the size of the transition table and create bitmasks.
3021 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,
3022 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,
3023 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,
3024 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,
3025 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,
3026 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,
3027 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,
3028 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,
3030 -- The second part is a transition table that maps a combination
3031 -- of a state of the automaton and a character class to a state.
3032 0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12,
3033 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,
3034 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,
3035 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,
3036 12,36,12,12,12,12,12,12,12,12,12,12
3039{-# INLINE decode #-}
3040decode :: DecoderState -> CodePoint -> Word8 -> Tuple' DecoderState CodePoint
3041decode state codep byte =
3042 let t = utf8d `A.unsafeIndex` fromIntegral byte
3045 then (fromIntegral byte .&. 0x3f) .|. (codep `shiftL` 6)
3046 else (0xff `shiftR` (fromIntegral t)) .&. fromIntegral byte
3047 state' = utf8d `A.unsafeIndex`
3048 (256 + fromIntegral state + fromIntegral t)
3049 in (Tuple' state' codep')
3052 = FreshPoint !CodePoint !DecoderState s
3053 | YieldAndContinue !Char (FreshPoint s)
3056-- XXX Add proper error messages
3057{-# INLINE_NORMAL decodeUtf8With #-}
3058decodeUtf8With :: Monad m => CodingFailureMode -> Stream m Word8 -> Stream m Char
3059decodeUtf8With cfm (Stream step state) = Stream step' (FreshPoint 0 0 state)
3061 {-# INLINE transliterateOrError #-}
3062 transliterateOrError e s =
3064 ErrorOnCodingFailure -> error e
3065 TransliterateCodingFailure -> YieldAndContinue replacementChar s
3066 {-# INLINE inputUnderflow #-}
3069 ErrorOnCodingFailure ->
3070 error "Streamly.Streams.StreamD.decodeUtf8With: Input Underflow"
3071 TransliterateCodingFailure -> YieldAndContinue replacementChar Done
3072 {-# INLINE_LATE step' #-}
3073 step' gst (FreshPoint codepointPtr statePtr st) = do
3074 r <- step (adaptState gst) st
3078 if statePtr == 0 && x <= 0x7f
3082 (unsafeChr (fromIntegral x))
3085 let (Tuple' sv cp) =
3086 decode statePtr codepointPtr x
3090 transliterateOrError
3091 "Streamly.Streams.StreamD.decodeUtf8With: Invalid UTF8 codepoint encountered"
3096 (unsafeChr (fromIntegral cp))
3097 (FreshPoint cp sv s)
3098 _ -> Skip (FreshPoint cp sv s)
3099 Skip s -> Skip (FreshPoint codepointPtr statePtr s)
3102 then Skip inputUnderflow
3104 step' _ (YieldAndContinue c s) = return $ Yield c s
3105 step' _ Done = return Stop
3107{-# INLINE decodeUtf8 #-}
3108decodeUtf8 :: Monad m => Stream m Word8 -> Stream m Char
3109decodeUtf8 = decodeUtf8With ErrorOnCodingFailure
3111{-# INLINE decodeUtf8Lenient #-}
3112decodeUtf8Lenient :: Monad m => Stream m Word8 -> Stream m Char
3113decodeUtf8Lenient = decodeUtf8With TransliterateCodingFailure
3115data FlattenState s a
3116 = OuterLoop !CodePoint !DecoderState s
3117 | InnerLoop !CodePoint !DecoderState s (ForeignPtr a) (Ptr a) (Ptr a)
3118 | YAndC !Char (FlattenState s a) -- These constructors can be
3119 -- encoded in the FreshPoint
3120 -- type, I prefer to keep these
3121 -- flat even though that means
3122 -- coming up with new names
3125-- The normal decodeUtf8 above should fuse with flattenArrays
3126-- to create this exact code but it doesn't for some reason, as of now this
3127-- remains the fastest way I could figure out to decodeUtf8.
3129-- XXX Add Proper error messages
3130{-# INLINE_NORMAL decodeUtf8ArraysWith #-}
3131decodeUtf8ArraysWith ::
3133 => CodingFailureMode
3134 -> Stream m (A.Array Word8)
3136decodeUtf8ArraysWith cfm (Stream step state) =
3137 Stream step' (OuterLoop 0 0 state)
3139 {-# INLINE transliterateOrError #-}
3140 transliterateOrError e s =
3142 ErrorOnCodingFailure -> error e
3143 TransliterateCodingFailure -> YAndC replacementChar s
3144 {-# INLINE inputUnderflow #-}
3147 ErrorOnCodingFailure ->
3149 "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Input Underflow"
3150 TransliterateCodingFailure -> YAndC replacementChar D
3151 {-# INLINE_LATE step' #-}
3152 step' gst (OuterLoop cp ds st) = do
3153 r <- step (adaptState gst) st
3156 Yield A.Array {..} s ->
3157 let p = unsafeForeignPtrToPtr aStart
3158 in Skip (InnerLoop cp ds s aStart p aEnd)
3159 Skip s -> Skip (OuterLoop cp ds s)
3162 then Skip inputUnderflow
3164 step' _ (InnerLoop cp ds st _ p end)
3165 | p == end = return $ Skip $ OuterLoop cp ds st
3166 step' _ (InnerLoop codepointPtr statePtr st startf p end) = do
3170 touchForeignPtr startf
3172 if statePtr == 0 && x <= 0x7f
3174 return $ Skip $ YAndC
3175 (unsafeChr (fromIntegral x))
3176 (InnerLoop 0 0 st startf (p `plusPtr` 1) end)
3178 let (Tuple' sv cp) = decode statePtr codepointPtr x
3183 transliterateOrError
3184 "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered"
3185 (InnerLoop 0 0 st startf (p `plusPtr` 1) end)
3189 (unsafeChr (fromIntegral cp))
3190 (InnerLoop cp sv st startf (p `plusPtr` 1) end)
3191 _ -> Skip (InnerLoop cp sv st startf (p `plusPtr` 1) end)
3192 step' _ (YAndC c s) = return $ Yield c s
3193 step' _ D = return Stop
3195{-# INLINE decodeUtf8Arrays #-}
3198 => Stream m (A.Array Word8)
3200decodeUtf8Arrays = decodeUtf8ArraysWith ErrorOnCodingFailure
3202{-# INLINE decodeUtf8ArraysLenient #-}
3203decodeUtf8ArraysLenient ::
3205 => Stream m (A.Array Word8)
3207decodeUtf8ArraysLenient = decodeUtf8ArraysWith TransliterateCodingFailure
3209data WList = WCons !Word8 !WList | WNil
3211data EncodeState s = EncodeState s !WList
3213{-# INLINE_NORMAL encodeUtf8 #-}
3214encodeUtf8 :: Monad m => Stream m Char -> Stream m Word8
3215encodeUtf8 (Stream step state) = Stream step' (EncodeState state WNil)
3217 {-# INLINE_LATE step' #-}
3218 step' gst (EncodeState st WNil) = do
3219 r <- step (adaptState gst) st
3227 (EncodeState s (WCons (fromIntegral x) WNil))
3228 | x <= 0x7FF -> Skip (EncodeState s (ord2 c))
3232 "Streamly.Streams.StreamD.encodeUtf8: Encountered a surrogate"
3233 else Skip (EncodeState s (ord3 c))
3234 | otherwise -> Skip (EncodeState s (ord4 c))
3235 Skip s -> Skip (EncodeState s WNil)
3237 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