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 : streamly@composewell.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
187 -- | Transform a stream into another type.
204 -- ** By folding (scans)
270 -- * Transformation comprehensions
282 -- * UTF8 Encoding / Decoding transformations.
290 , resumeDecodeUtf8Either
292 , decodeUtf8ArraysLenient
296import Control.Exception (Exception, SomeException)
297import Control.Monad (void)
298import Control.Monad.Catch (MonadCatch)
299import Control.Monad.IO.Class (MonadIO(..))
300import Control.Monad.Reader (ReaderT)
301import Control.Monad.State.Strict (StateT)
302import Control.Monad.Trans (MonadTrans(lift))
303import Data.Bits (shiftR, shiftL, (.|.), (.&.))
304import Data.Functor.Identity (Identity(..))
305import Data.Maybe (fromJust, isJust)
306import Data.Word (Word32)
307import Foreign.Ptr (Ptr)
308import Foreign.Storable (Storable(..))
309import GHC.Base (assert, unsafeChr, ord)
310import GHC.IO.Encoding.Failure (isSurrogate)
311import GHC.ForeignPtr (ForeignPtr (..))
312import GHC.Ptr (Ptr (..))
313import GHC.Types (SPEC(..))
314import GHC.Word (Word8(..))
315import System.IO.Unsafe (unsafePerformIO)
317 hiding (map, mapM, mapM_, repeat, foldr, last, take, filter,
318 takeWhile, drop, dropWhile, all, any, maximum, minimum, elem,
319 notElem, null, head, tail, zipWith, lookup, foldr1, sequence,
320 (!!), scanl, scanl1, concatMap, replicate, enumFromTo, concat,
323import qualified Control.Monad.Catch as MC
324import qualified Control.Monad.Reader as Reader
325import qualified Control.Monad.State.Strict as State
327import Streamly.Internal.Memory.Array.Types (Array(..))
328import Streamly.Internal.Data.Fold.Types (Fold(..))
329import Streamly.Internal.Data.Pipe.Types (Pipe(..), PipeState(..))
330import Streamly.Internal.Data.SVar (MonadAsync, defState, adaptState)
331import Streamly.Internal.Data.Unfold.Types (Unfold(..))
332import Streamly.Internal.Data.Strict (Tuple'(..))
334import Streamly.Internal.Data.Stream.StreamD.Type
336import qualified Streamly.Internal.Data.Pipe.Types as Pipe
337import qualified Streamly.Internal.Memory.Array.Types as A
338import qualified Streamly.Memory.Ring as RB
339import qualified Streamly.Streams.StreamK as K
341import Foreign.Ptr (plusPtr)
342import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
343import Foreign.ForeignPtr (touchForeignPtr)
345------------------------------------------------------------------------------
347------------------------------------------------------------------------------
349-- | An empty 'Stream'.
350{-# INLINE_NORMAL nil #-}
351nil :: Monad m => Stream m a
352nil = Stream (\_ _ -> return Stop) ()
354-- | An empty 'Stream' with a side effect.
355{-# INLINE_NORMAL nilM #-}
356nilM :: Monad m => m b -> Stream m a
357nilM m = Stream (\_ _ -> m >> return Stop) ()
359{-# INLINE_NORMAL consM #-}
360consM :: Monad m => m a -> Stream m a -> Stream m a
361consM m (Stream step state) = Stream step1 Nothing
363 {-# INLINE_LATE step1 #-}
364 step1 _ Nothing = m >>= \x -> return $ Yield x (Just state)
365 step1 gst (Just st) = do
369 Yield a s -> Yield a (Just s)
370 Skip s -> Skip (Just s)
373-- XXX implement in terms of consM?
374-- cons x = consM (return x)
376-- | Can fuse but has O(n^2) complexity.
377{-# INLINE_NORMAL cons #-}
378cons :: Monad m => a -> Stream m a -> Stream m a
379cons x (Stream step state) = Stream step1 Nothing
381 {-# INLINE_LATE step1 #-}
382 step1 _ Nothing = return $ Yield x (Just state)
383 step1 gst (Just st) = do
387 Yield a s -> Yield a (Just s)
388 Skip s -> Skip (Just s)
391-------------------------------------------------------------------------------
393-------------------------------------------------------------------------------
395-- Does not fuse, has the same performance as the StreamK version.
396{-# INLINE_NORMAL uncons #-}
397uncons :: Monad m => Stream m a -> m (Maybe (a, Stream m a))
398uncons (UnStream step state) = go state
401 r <- step defState st
403 Yield x s -> return $ Just (x, Stream step s)
405 Stop -> return Nothing
407------------------------------------------------------------------------------
408-- Generation by unfold
409------------------------------------------------------------------------------
411{-# INLINE_NORMAL unfoldrM #-}
412unfoldrM :: Monad m => (s -> m (Maybe (a, s))) -> s -> Stream m a
413unfoldrM next state = Stream step state
415 {-# INLINE_LATE step #-}
419 Just (x, s) -> Yield x s
422{-# INLINE_LATE unfoldr #-}
423unfoldr :: Monad m => (s -> Maybe (a, s)) -> s -> Stream m a
424unfoldr f = unfoldrM (return . f)
426-- | Convert an 'Unfold' into a 'Stream' by supplying it a seed.
428{-# INLINE_NORMAL unfold #-}
429unfold :: Monad m => Unfold m a b -> a -> Stream m b
430unfold (Unfold ustep inject) seed = Stream step Nothing
432 {-# INLINE_LATE step #-}
433 step _ Nothing = inject seed >>= return . Skip . Just
434 step _ (Just st) = do
437 Yield x s -> Yield x (Just s)
438 Skip s -> Skip (Just s)
441------------------------------------------------------------------------------
442-- Specialized Generation
443------------------------------------------------------------------------------
445repeatM :: Monad m => m a -> Stream m a
446repeatM x = Stream (\_ _ -> x >>= \r -> return $ Yield r ()) ()
448repeat :: Monad m => a -> Stream m a
449repeat x = Stream (\_ _ -> return $ Yield x ()) ()
451{-# INLINE_NORMAL replicateM #-}
452replicateM :: forall m a. Monad m => Int -> m a -> Stream m a
453replicateM n p = Stream step n
455 {-# INLINE_LATE step #-}
457 | i <= 0 = return Stop
460 return $ Yield x (i - 1)
462{-# INLINE_NORMAL replicate #-}
463replicate :: Monad m => Int -> a -> Stream m a
464replicate n x = replicateM n (return x)
466-- This would not work properly for floats, therefore we put an Integral
468-- | Can be used to enumerate unbounded integrals. This does not check for
469-- overflow or underflow for bounded integrals.
470{-# INLINE_NORMAL enumerateFromStepIntegral #-}
471enumerateFromStepIntegral :: (Integral a, Monad m) => a -> a -> Stream m a
472enumerateFromStepIntegral from stride =
473 from `seq` stride `seq` Stream step from
475 {-# INLINE_LATE step #-}
476 step _ !x = return $ Yield x $! (x + stride)
478-- We are assuming that "to" is constrained by the type to be within
480{-# INLINE enumerateFromToIntegral #-}
481enumerateFromToIntegral :: (Monad m, Integral a) => a -> a -> Stream m a
482enumerateFromToIntegral from to =
483 takeWhile (<= to) $ enumerateFromStepIntegral from 1
485{-# INLINE enumerateFromIntegral #-}
486enumerateFromIntegral :: (Monad m, Integral a, Bounded a) => a -> Stream m a
487enumerateFromIntegral from = enumerateFromToIntegral from maxBound
489data EnumState a = EnumInit | EnumYield a a a | EnumStop
491{-# INLINE_NORMAL enumerateFromThenToIntegralUp #-}
492enumerateFromThenToIntegralUp
493 :: (Monad m, Integral a)
494 => a -> a -> a -> Stream m a
495enumerateFromThenToIntegralUp from next to = Stream step EnumInit
497 {-# INLINE_LATE step #-}
503 else Yield from EnumStop
504 else -- from <= next <= to
505 let stride = next - from
506 in Skip $ EnumYield from stride (to - stride)
508 step _ (EnumYield x stride toMinus) =
511 then Yield x EnumStop
512 else Yield x $ EnumYield (x + stride) stride toMinus
514 step _ EnumStop = return Stop
516{-# INLINE_NORMAL enumerateFromThenToIntegralDn #-}
517enumerateFromThenToIntegralDn
518 :: (Monad m, Integral a)
519 => a -> a -> a -> Stream m a
520enumerateFromThenToIntegralDn from next to = Stream step EnumInit
522 {-# INLINE_LATE step #-}
524 return $ if to > next
527 else Yield from EnumStop
528 else -- from >= next >= to
529 let stride = next - from
530 in Skip $ EnumYield from stride (to - stride)
532 step _ (EnumYield x stride toMinus) =
535 then Yield x EnumStop
536 else Yield x $ EnumYield (x + stride) stride toMinus
538 step _ EnumStop = return Stop
540{-# INLINE_NORMAL enumerateFromThenToIntegral #-}
541enumerateFromThenToIntegral
542 :: (Monad m, Integral a)
543 => a -> a -> a -> Stream m a
544enumerateFromThenToIntegral from next to
545 | next >= from = enumerateFromThenToIntegralUp from next to
546 | otherwise = enumerateFromThenToIntegralDn from next to
548{-# INLINE_NORMAL enumerateFromThenIntegral #-}
549enumerateFromThenIntegral
550 :: (Monad m, Integral a, Bounded a)
551 => a -> a -> Stream m a
552enumerateFromThenIntegral from next =
554 then enumerateFromThenToIntegralUp from next maxBound
555 else enumerateFromThenToIntegralDn from next minBound
557-- For floating point numbers if the increment is less than the precision then
558-- it just gets lost. Therefore we cannot always increment it correctly by just
560-- 9007199254740992 + 1 + 1 :: Double => 9.007199254740992e15
561-- 9007199254740992 + 2 :: Double => 9.007199254740994e15
563-- Instead we accumulate the increment counter and compute the increment
564-- everytime before adding it to the starting number.
566-- This works for Integrals as well as floating point numbers, but
567-- enumerateFromStepIntegral is faster for integrals.
568{-# INLINE_NORMAL enumerateFromStepNum #-}
569enumerateFromStepNum :: (Monad m, Num a) => a -> a -> Stream m a
570enumerateFromStepNum from stride = Stream step 0
572 {-# INLINE_LATE step #-}
573 step _ !i = return $ (Yield $! (from + i * stride)) $! (i + 1)
575{-# INLINE_NORMAL numFrom #-}
576numFrom :: (Monad m, Num a) => a -> Stream m a
577numFrom from = enumerateFromStepNum from 1
579{-# INLINE_NORMAL numFromThen #-}
580numFromThen :: (Monad m, Num a) => a -> a -> Stream m a
581numFromThen from next = enumerateFromStepNum from (next - from)
583-- We cannot write a general function for Num. The only way to write code
584-- portable between the two is to use a 'Real' constraint and convert between
585-- Fractional and Integral using fromRational which is horribly slow.
586{-# INLINE_NORMAL enumerateFromToFractional #-}
587enumerateFromToFractional
588 :: (Monad m, Fractional a, Ord a)
589 => a -> a -> Stream m a
590enumerateFromToFractional from to =
591 takeWhile (<= to + 1 / 2) $ enumerateFromStepNum from 1
593{-# INLINE_NORMAL enumerateFromThenToFractional #-}
594enumerateFromThenToFractional
595 :: (Monad m, Fractional a, Ord a)
596 => a -> a -> a -> Stream m a
597enumerateFromThenToFractional from next to =
598 takeWhile predicate $ numFromThen from next
600 mid = (next - from) / 2
601 predicate | next >= from = (<= to + mid)
602 | otherwise = (>= to + mid)
604-------------------------------------------------------------------------------
605-- Generation by Conversion
606-------------------------------------------------------------------------------
608{-# INLINE_NORMAL fromIndicesM #-}
609fromIndicesM :: Monad m => (Int -> m a) -> Stream m a
610fromIndicesM gen = Stream step 0
612 {-# INLINE_LATE step #-}
615 return $ Yield x (i + 1)
617{-# INLINE fromIndices #-}
618fromIndices :: Monad m => (Int -> a) -> Stream m a
619fromIndices gen = fromIndicesM (return . gen)
621{-# INLINE_NORMAL generateM #-}
622generateM :: Monad m => Int -> (Int -> m a) -> Stream m a
623generateM n gen = n `seq` Stream step 0
625 {-# INLINE_LATE step #-}
626 step _ i | i < n = do
628 return $ Yield x (i + 1)
629 | otherwise = return Stop
631{-# INLINE generate #-}
632generate :: Monad m => Int -> (Int -> a) -> Stream m a
633generate n gen = generateM n (return . gen)
635-- XXX we need the MonadAsync constraint because of a rewrite rule.
636-- | Convert a list of monadic actions to a 'Stream'
637{-# INLINE_LATE fromListM #-}
638fromListM :: MonadAsync m => [m a] -> Stream m a
639fromListM = Stream step
641 {-# INLINE_LATE step #-}
642 step _ (m:ms) = m >>= \x -> return $ Yield x ms
643 step _ [] = return Stop
645{-# INLINE toStreamD #-}
646toStreamD :: (K.IsStream t, Monad m) => t m a -> Stream m a
647toStreamD = fromStreamK . K.toStream
649{-# INLINE_NORMAL hoist #-}
650hoist :: Monad n => (forall x. m x -> n x) -> Stream m a -> Stream n a
651hoist f (Stream step state) = (Stream step' state)
654 r <- f $ step (adaptState gst) st
656 Yield x s -> Yield x s
660{-# INLINE_NORMAL generally #-}
661generally :: Monad m => Stream Identity a -> Stream m a
662generally = hoist (return . runIdentity)
664{-# INLINE_NORMAL liftInner #-}
665liftInner :: (Monad m, MonadTrans t, Monad (t m))
666 => Stream m a -> Stream (t m) a
667liftInner (Stream step state) = Stream step' state
670 r <- lift $ step (adaptState gst) st
672 Yield x s -> Yield x s
676{-# INLINE_NORMAL runReaderT #-}
677runReaderT :: Monad m => s -> Stream (ReaderT s m) a -> Stream m a
678runReaderT sval (Stream step state) = Stream step' state
681 r <- Reader.runReaderT (step (adaptState gst) st) sval
683 Yield x s -> Yield x s
687{-# INLINE_NORMAL evalStateT #-}
688evalStateT :: Monad m => s -> Stream (StateT s m) a -> Stream m a
689evalStateT sval (Stream step state) = Stream step' (state, sval)
691 step' gst (st, sv) = do
692 (r, sv') <- State.runStateT (step (adaptState gst) st) sv
694 Yield x s -> Yield x (s, sv')
695 Skip s -> Skip (s, sv')
698{-# INLINE_NORMAL runStateT #-}
699runStateT :: Monad m => s -> Stream (StateT s m) a -> Stream m (s, a)
700runStateT sval (Stream step state) = Stream step' (state, sval)
702 step' gst (st, sv) = do
703 (r, sv') <- State.runStateT (step (adaptState gst) st) sv
705 Yield x s -> Yield (sv', x) (s, sv')
706 Skip s -> Skip (s, sv')
709------------------------------------------------------------------------------
710-- Elimination by Folds
711------------------------------------------------------------------------------
713------------------------------------------------------------------------------
715------------------------------------------------------------------------------
717{-# INLINE_NORMAL foldr1 #-}
718foldr1 :: Monad m => (a -> a -> a) -> Stream m a -> m (Maybe a)
722 Nothing -> return Nothing
723 Just (h, t) -> fmap Just (foldr f h t)
725------------------------------------------------------------------------------
727------------------------------------------------------------------------------
729{-# INLINE_NORMAL foldlT #-}
730foldlT :: (Monad m, Monad (s m), MonadTrans s)
731 => (s m b -> a -> s m b) -> s m b -> Stream m a -> s m b
732foldlT fstep begin (Stream step state) = go SPEC begin state
735 r <- lift $ step defState st
737 Yield x s -> go SPEC (fstep acc x) s
738 Skip s -> go SPEC acc s
741-- Note, this is going to have horrible performance, because of the nature of
742-- the stream type (i.e. direct stream vs CPS). Its only for reference, it is
743-- likely be practically unusable.
744{-# INLINE_NORMAL foldlS #-}
746 => (Stream m b -> a -> Stream m b) -> Stream m b -> Stream m a -> Stream m b
747foldlS fstep begin (Stream step state) = Stream step' (Left (state, begin))
749 step' gst (Left (st, acc)) = do
750 r <- step (adaptState gst) st
752 Yield x s -> Skip (Left (s, fstep acc x))
753 Skip s -> Skip (Left (s, acc))
754 Stop -> Skip (Right acc)
756 step' gst (Right (Stream stp stt)) = do
757 r <- stp (adaptState gst) stt
759 Yield x s -> Yield x (Right (Stream stp s))
760 Skip s -> Skip (Right (Stream stp s))
763------------------------------------------------------------------------------
765------------------------------------------------------------------------------
767-- | Run a streaming composition, discard the results.
768{-# INLINE_LATE drain #-}
769drain :: Monad m => Stream m a -> m ()
770-- drain = foldrM (\_ xs -> xs) (return ())
771drain (Stream step state) = go SPEC state
774 r <- step defState st
776 Yield _ s -> go SPEC s
780{-# INLINE_NORMAL null #-}
781null :: Monad m => Stream m a -> m Bool
782null m = foldrM (\_ _ -> return False) (return True) m
784{-# INLINE_NORMAL head #-}
785head :: Monad m => Stream m a -> m (Maybe a)
786head m = foldrM (\x _ -> return (Just x)) (return Nothing) m
788-- Does not fuse, has the same performance as the StreamK version.
789{-# INLINE_NORMAL tail #-}
790tail :: Monad m => Stream m a -> m (Maybe (Stream m a))
791tail (UnStream step state) = go state
794 r <- step defState st
796 Yield _ s -> return (Just $ Stream step s)
798 Stop -> return Nothing
800-- XXX will it fuse? need custom impl?
801{-# INLINE_NORMAL last #-}
802last :: Monad m => Stream m a -> m (Maybe a)
803last = foldl' (\_ y -> Just y) Nothing
805{-# INLINE_NORMAL elem #-}
806elem :: (Monad m, Eq a) => a -> Stream m a -> m Bool
807-- elem e m = foldrM (\x xs -> if x == e then return True else xs) (return False) m
808elem e (Stream step state) = go state
811 r <- step defState st
814 | x == e -> return True
819{-# INLINE_NORMAL notElem #-}
820notElem :: (Monad m, Eq a) => a -> Stream m a -> m Bool
821notElem e s = fmap not (elem e s)
823{-# INLINE_NORMAL all #-}
824all :: Monad m => (a -> Bool) -> Stream m a -> m Bool
825-- all p m = foldrM (\x xs -> if p x then xs else return False) (return True) m
826all p (Stream step state) = go state
829 r <- step defState st
833 | otherwise -> return False
837{-# INLINE_NORMAL any #-}
838any :: Monad m => (a -> Bool) -> Stream m a -> m Bool
839-- any p m = foldrM (\x xs -> if p x then return True else xs) (return False) m
840any p (Stream step state) = go state
843 r <- step defState st
851{-# INLINE_NORMAL maximum #-}
852maximum :: (Monad m, Ord a) => Stream m a -> m (Maybe a)
853maximum (Stream step state) = go Nothing state
856 r <- step defState st
858 Yield x s -> go (Just x) s
859 Skip s -> go Nothing s
860 Stop -> return Nothing
861 go (Just acc) st = do
862 r <- step defState st
865 | acc <= x -> go (Just x) s
866 | otherwise -> go (Just acc) s
867 Skip s -> go (Just acc) s
868 Stop -> return (Just acc)
870{-# INLINE_NORMAL maximumBy #-}
871maximumBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> m (Maybe a)
872maximumBy cmp (Stream step state) = go Nothing state
875 r <- step defState st
877 Yield x s -> go (Just x) s
878 Skip s -> go Nothing s
879 Stop -> return Nothing
880 go (Just acc) st = do
881 r <- step defState st
883 Yield x s -> case cmp acc x of
884 GT -> go (Just acc) s
886 Skip s -> go (Just acc) s
887 Stop -> return (Just acc)
889{-# INLINE_NORMAL minimum #-}
890minimum :: (Monad m, Ord a) => Stream m a -> m (Maybe a)
891minimum (Stream step state) = go Nothing state
894 r <- step defState st
896 Yield x s -> go (Just x) s
897 Skip s -> go Nothing s
898 Stop -> return Nothing
899 go (Just acc) st = do
900 r <- step defState st
903 | acc <= x -> go (Just acc) s
904 | otherwise -> go (Just x) s
905 Skip s -> go (Just acc) s
906 Stop -> return (Just acc)
908{-# INLINE_NORMAL minimumBy #-}
909minimumBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> m (Maybe a)
910minimumBy cmp (Stream step state) = go Nothing state
913 r <- step defState st
915 Yield x s -> go (Just x) s
916 Skip s -> go Nothing s
917 Stop -> return Nothing
918 go (Just acc) st = do
919 r <- step defState st
921 Yield x s -> case cmp acc x of
924 Skip s -> go (Just acc) s
925 Stop -> return (Just acc)
927{-# INLINE_NORMAL (!!) #-}
928(!!) :: (Monad m) => Stream m a -> Int -> m (Maybe a)
929(Stream step state) !! i = go i state
932 r <- step defState st
934 Yield x s | n < 0 -> return Nothing
935 | n == 0 -> return $ Just x
936 | otherwise -> go (n - 1) s
938 Stop -> return Nothing
940{-# INLINE_NORMAL lookup #-}
941lookup :: (Monad m, Eq a) => a -> Stream m (a, b) -> m (Maybe b)
942lookup e m = foldrM (\(a, b) xs -> if e == a then return (Just b) else xs)
945{-# INLINE_NORMAL findM #-}
946findM :: Monad m => (a -> m Bool) -> Stream m a -> m (Maybe a)
947findM p m = foldrM (\x xs -> p x >>= \r -> if r then return (Just x) else xs)
951find :: Monad m => (a -> Bool) -> Stream m a -> m (Maybe a)
952find p = findM (return . p)
954{-# INLINE_NORMAL findIndices #-}
955findIndices :: Monad m => (a -> Bool) -> Stream m a -> Stream m Int
956findIndices p (Stream step state) = Stream step' (state, 0)
958 {-# INLINE_LATE step' #-}
959 step' gst (st, i) = do
960 r <- step (adaptState gst) st
962 Yield x s -> if p x then Yield i (s, i+1) else Skip (s, i+1)
963 Skip s -> Skip (s, i+1)
966{-# INLINE toListRev #-}
967toListRev :: Monad m => Stream m a -> m [a]
968toListRev = foldl' (flip (:)) []
970-- We can implement reverse as:
972-- > reverse = foldlS (flip cons) nil
974-- However, this implementation is unusable because of the horrible performance
975-- of cons. So we just convert it to a list first and then stream from the
978-- XXX Maybe we can use an Array instead of a list here?
979{-# INLINE_NORMAL reverse #-}
980reverse :: Monad m => Stream m a -> Stream m a
981reverse m = Stream step Nothing
983 {-# INLINE_LATE step #-}
986 return $ Skip (Just xs)
987 step _ (Just (x:xs)) = return $ Yield x (Just xs)
988 step _ (Just []) = return Stop
990-- Much faster reverse for Storables
991{-# INLINE_NORMAL reverse' #-}
992reverse' :: forall m a. (MonadIO m, Storable a) => Stream m a -> Stream m a
994-- This commented implementation copies the whole stream into one single array
995-- and then streams from that array, this is 3-4x faster than the chunked code
996-- that follows. Though this could be problematic due to unbounded large
997-- allocations. We need to figure out why the chunked code is slower and if we
998-- can optimize the chunked code to work as fast as this one. It may be a
1000import Foreign.ForeignPtr (touchForeignPtr)
1001import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
1002import Foreign.Ptr (Ptr, plusPtr)
1003reverse' m = Stream step Nothing
1005 {-# INLINE_LATE step #-}
1007 arr <- A.fromStreamD m
1008 let p = aEnd arr `plusPtr` negate (sizeOf (undefined :: a))
1009 return $ Skip $ Just (aStart arr, p)
1011 step _ (Just (start, p)) | p < unsafeForeignPtrToPtr start = return Stop
1013 step _ (Just (start, p)) = do
1014 let !x = A.unsafeInlineIO $ do
1016 touchForeignPtr start
1018 next = p `plusPtr` negate (sizeOf (undefined :: a))
1019 return $ Yield x (Just (start, next))
1026 $ A.fromStreamDArraysOf A.defaultChunkSize m
1029------------------------------------------------------------------------------
1030-- Grouping/Splitting
1031------------------------------------------------------------------------------
1033{-# INLINE_NORMAL splitSuffixBy' #-}
1034splitSuffixBy' :: Monad m
1035 => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
1036splitSuffixBy' predicate f (Stream step state) =
1037 Stream (stepOuter f) (Just state)
1041 {-# INLINE_LATE stepOuter #-}
1042 stepOuter (Fold fstep initial done) gst (Just st) = do
1043 res <- step (adaptState gst) st
1049 then done acc' >>= \val -> return $ Yield val (Just s)
1052 Skip s -> return $ Skip $ Just s
1058 res <- step (adaptState gst) stt
1063 then done acc' >>= \val -> return $ Yield val (Just s)
1065 Skip s -> go SPEC s acc
1066 Stop -> done acc >>= \val -> return $ Yield val Nothing
1068 stepOuter _ _ Nothing = return Stop
1070{-# INLINE_NORMAL groupsBy #-}
1076groupsBy cmp f (Stream step state) = Stream (stepOuter f) (Just state, Nothing)
1080 {-# INLINE_LATE stepOuter #-}
1081 stepOuter (Fold fstep initial done) gst (Just st, Nothing) = do
1082 res <- step (adaptState gst) st
1089 Skip s -> return $ Skip $ (Just s, Nothing)
1094 go !_ prev stt !acc = do
1095 res <- step (adaptState gst) stt
1102 else done acc >>= \r -> return $ Yield r (Just s, Just x)
1103 Skip s -> go SPEC prev s acc
1104 Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1106 stepOuter (Fold fstep initial done) gst (Just st, Just prev) = do
1108 acc' <- fstep acc prev
1113 -- XXX code duplicated from the previous equation
1115 res <- step (adaptState gst) stt
1122 else done acc >>= \r -> return $ Yield r (Just s, Just x)
1123 Skip s -> go SPEC s acc
1124 Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1126 stepOuter _ _ (Nothing,_) = return Stop
1128{-# INLINE_NORMAL groupsRollingBy #-}
1129groupsRollingBy :: Monad m
1134groupsRollingBy cmp f (Stream step state) =
1135 Stream (stepOuter f) (Just state, Nothing)
1138 {-# INLINE_LATE stepOuter #-}
1139 stepOuter (Fold fstep initial done) gst (Just st, Nothing) = do
1140 res <- step (adaptState gst) st
1147 Skip s -> return $ Skip $ (Just s, Nothing)
1151 go !_ prev stt !acc = do
1152 res <- step (adaptState gst) stt
1160 done acc >>= \r -> return $ Yield r (Just s, Just x)
1161 Skip s -> go SPEC prev s acc
1162 Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1164 stepOuter (Fold fstep initial done) gst (Just st, Just prev') = do
1166 acc' <- fstep acc prev'
1167 go SPEC prev' st acc'
1170 go !_ prevv stt !acc = do
1171 res <- step (adaptState gst) stt
1178 else done acc >>= \r -> return $ Yield r (Just s, Just x)
1179 Skip s -> go SPEC prevv s acc
1180 Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1182 stepOuter _ _ (Nothing, _) = return Stop
1184{-# INLINE_NORMAL splitBy #-}
1185splitBy :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
1186splitBy predicate f (Stream step state) = Stream (step' f) (Just state)
1190 {-# INLINE_LATE step' #-}
1191 step' (Fold fstep initial done) gst (Just st) = initial >>= go SPEC st
1196 res <- step (adaptState gst) stt
1200 then done acc >>= \r -> return $ Yield r (Just s)
1204 Skip s -> go SPEC s acc
1205 Stop -> done acc >>= \r -> return $ Yield r Nothing
1207 step' _ _ Nothing = return Stop
1209-- XXX requires -funfolding-use-threshold=150 in lines-unlines benchmark
1210{-# INLINE_NORMAL splitSuffixBy #-}
1211splitSuffixBy :: Monad m
1212 => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
1213splitSuffixBy predicate f (Stream step state) = Stream (step' f) (Just state)
1217 {-# INLINE_LATE step' #-}
1218 step' (Fold fstep initial done) gst (Just st) = do
1219 res <- step (adaptState gst) st
1224 then done acc >>= \val -> return $ Yield val (Just s)
1229 Skip s -> return $ Skip $ Just s
1235 res <- step (adaptState gst) stt
1239 then done acc >>= \r -> return $ Yield r (Just s)
1243 Skip s -> go SPEC s acc
1244 Stop -> done acc >>= \r -> return $ Yield r Nothing
1246 step' _ _ Nothing = return Stop
1248{-# INLINE_NORMAL wordsBy #-}
1249wordsBy :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
1250wordsBy predicate f (Stream step state) = Stream (stepOuter f) (Just state)
1254 {-# INLINE_LATE stepOuter #-}
1255 stepOuter (Fold fstep initial done) gst (Just st) = do
1256 res <- step (adaptState gst) st
1260 then return $ Skip (Just s)
1266 Skip s -> return $ Skip $ Just s
1272 res <- step (adaptState gst) stt
1276 then done acc >>= \r -> return $ Yield r (Just s)
1280 Skip s -> go SPEC s acc
1281 Stop -> done acc >>= \r -> return $ Yield r Nothing
1283 stepOuter _ _ Nothing = return Stop
1285-- String search algorithms:
1286-- http://www-igm.univ-mlv.fr/~lecroq/string/index.html
1289-- TODO can we unify the splitting operations using a splitting configuration
1290-- like in the split package.
1292data SplitStyle = Infix | Suffix | Prefix deriving (Eq, Show)
1294data SplitOptions = SplitOptions
1295 { style :: SplitStyle
1296 , withSep :: Bool -- ^ keep the separators in output
1297 -- , compact :: Bool -- ^ treat multiple consecutive separators as one
1298 -- , trimHead :: Bool -- ^ drop blank at head
1299 -- , trimTail :: Bool -- ^ drop blank at tail
1303data SplitOnState s a =
1308 | GO_KARP_RABIN s !(RB.Ring a) !(Ptr a)
1311{-# INLINE_NORMAL splitOn #-}
1313 :: forall m a b. (MonadIO m, Storable a, Enum a, Eq a)
1318splitOn patArr@Array{..} (Fold fstep initial done) (Stream step state) =
1319 Stream stepOuter GO_START
1323 patLen = A.length patArr
1324 maxIndex = patLen - 1
1325 elemBits = sizeOf (undefined :: a) * 8
1327 {-# INLINE_LATE stepOuter #-}
1328 stepOuter _ GO_START =
1330 then return $ Skip $ GO_EMPTY_PAT state
1333 r <- liftIO $ (A.unsafeIndexIO patArr 0)
1334 return $ Skip $ GO_SINGLE_PAT state r
1335 else if sizeOf (undefined :: a) * patLen
1336 <= sizeOf (undefined :: Word)
1337 then return $ Skip $ GO_SHORT_PAT state
1339 (rb, rhead) <- liftIO $ RB.new patLen
1340 return $ Skip $ GO_KARP_RABIN state rb rhead
1342 stepOuter gst (GO_SINGLE_PAT stt pat) = initial >>= go SPEC stt
1347 res <- step (adaptState gst) st
1353 return $ Yield r (GO_SINGLE_PAT s pat)
1354 else fstep acc x >>= go SPEC s
1355 Skip s -> go SPEC s acc
1356 Stop -> done acc >>= \r -> return $ Yield r GO_DONE
1358 stepOuter gst (GO_SHORT_PAT stt) = initial >>= go0 SPEC 0 (0 :: Word) stt
1363 mask = (1 `shiftL` (elemBits * patLen)) - 1
1365 addToWord wrd a = (wrd `shiftL` elemBits) .|. fromIntegral (fromEnum a)
1368 patWord = mask .&. A.foldl' addToWord 0 patArr
1370 go0 !_ !idx wrd st !acc = do
1371 res <- step (adaptState gst) st
1374 let wrd' = addToWord wrd x
1377 if wrd' .&. mask == patWord
1380 return $ Yield r (GO_SHORT_PAT s)
1381 else go1 SPEC wrd' s acc
1382 else go0 SPEC (idx + 1) wrd' s acc
1383 Skip s -> go0 SPEC idx wrd s acc
1386 then go2 wrd idx acc
1388 done acc' >>= \r -> return $ Yield r GO_DONE
1391 go1 !_ wrd st !acc = do
1392 res <- step (adaptState gst) st
1395 let wrd' = addToWord wrd x
1396 old = (mask .&. wrd) `shiftR` (elemBits * (patLen - 1))
1397 acc' <- fstep acc (toEnum $ fromIntegral old)
1398 if wrd' .&. mask == patWord
1399 then done acc' >>= \r -> return $ Yield r (GO_SHORT_PAT s)
1400 else go1 SPEC wrd' s acc'
1401 Skip s -> go1 SPEC wrd s acc
1403 acc' <- go2 wrd patLen acc
1404 done acc' >>= \r -> return $ Yield r GO_DONE
1406 go2 !wrd !n !acc | n > 0 = do
1407 let old = (mask .&. wrd) `shiftR` (elemBits * (n - 1))
1408 fstep acc (toEnum $ fromIntegral old) >>= go2 wrd (n - 1)
1409 go2 _ _ acc = return acc
1411 stepOuter gst (GO_KARP_RABIN stt rb rhead) = do
1412 initial >>= go0 SPEC 0 rhead stt
1416 k = 2891336453 :: Word32
1418 addCksum cksum a = cksum * k + fromIntegral (fromEnum a)
1419 deltaCksum cksum old new =
1420 addCksum cksum new - coeff * fromIntegral (fromEnum old)
1422 -- XXX shall we use a random starting hash or 1 instead of 0?
1423 patHash = A.foldl' addCksum 0 patArr
1426 go0 !_ !idx !rh st !acc = do
1427 res <- step (adaptState gst) st
1430 rh' <- liftIO $ RB.unsafeInsert rb rh x
1433 let fold = RB.unsafeFoldRing (RB.ringBound rb)
1434 let !ringHash = fold addCksum 0 rb
1435 if ringHash == patHash
1436 then go2 SPEC ringHash rh' s acc
1437 else go1 SPEC ringHash rh' s acc
1438 else go0 SPEC (idx + 1) rh' s acc
1439 Skip s -> go0 SPEC idx rh s acc
1441 !acc' <- if idx /= 0
1442 then RB.unsafeFoldRingM rh fstep acc rb
1444 done acc' >>= \r -> return $ Yield r GO_DONE
1446 -- XXX Theoretically this code can do 4 times faster if GHC generates
1447 -- optimal code. If we use just "(cksum' == patHash)" condition it goes
1448 -- 4x faster, as soon as we add the "RB.unsafeEqArray rb v" condition
1449 -- the generated code changes drastically and becomes 4x slower. Need
1450 -- to investigate what is going on with GHC.
1452 go1 !_ !cksum !rh st !acc = do
1453 res <- step (adaptState gst) st
1456 old <- liftIO $ peek rh
1457 let cksum' = deltaCksum cksum old x
1458 acc' <- fstep acc old
1460 if (cksum' == patHash)
1462 rh' <- liftIO (RB.unsafeInsert rb rh x)
1463 go2 SPEC cksum' rh' s acc'
1465 rh' <- liftIO (RB.unsafeInsert rb rh x)
1466 go1 SPEC cksum' rh' s acc'
1467 Skip s -> go1 SPEC cksum rh s acc
1469 acc' <- RB.unsafeFoldRingFullM rh fstep acc rb
1470 done acc' >>= \r -> return $ Yield r GO_DONE
1472 go2 !_ !cksum' !rh' s !acc' = do
1473 if RB.unsafeEqArray rb rh' patArr
1476 return $ Yield r (GO_KARP_RABIN s rb rhead)
1477 else go1 SPEC cksum' rh' s acc'
1479 stepOuter gst (GO_EMPTY_PAT st) = do
1480 res <- step (adaptState gst) st
1485 done acc' >>= \r -> return $ Yield r (GO_EMPTY_PAT s)
1486 Skip s -> return $ Skip (GO_EMPTY_PAT s)
1489 stepOuter _ GO_DONE = return Stop
1491{-# INLINE_NORMAL splitSuffixOn #-}
1493 :: forall m a b. (MonadIO m, Storable a, Enum a, Eq a)
1499splitSuffixOn withSep patArr@Array{..} (Fold fstep initial done)
1500 (Stream step state) =
1501 Stream stepOuter GO_START
1505 patLen = A.length patArr
1506 maxIndex = patLen - 1
1507 elemBits = sizeOf (undefined :: a) * 8
1509 {-# INLINE_LATE stepOuter #-}
1510 stepOuter _ GO_START =
1512 then return $ Skip $ GO_EMPTY_PAT state
1515 r <- liftIO $ (A.unsafeIndexIO patArr 0)
1516 return $ Skip $ GO_SINGLE_PAT state r
1517 else if sizeOf (undefined :: a) * patLen
1518 <= sizeOf (undefined :: Word)
1519 then return $ Skip $ GO_SHORT_PAT state
1521 (rb, rhead) <- liftIO $ RB.new patLen
1522 return $ Skip $ GO_KARP_RABIN state rb rhead
1524 stepOuter gst (GO_SINGLE_PAT stt pat) = do
1525 -- This first part is the only difference between splitOn and
1527 -- If the last element is a separator do not issue a blank segment.
1528 res <- step (adaptState gst) stt
1534 acc' <- if withSep then fstep acc x else return acc
1535 done acc' >>= \r -> return $ Yield r (GO_SINGLE_PAT s pat)
1536 else fstep acc x >>= go SPEC s
1537 Skip s -> return $ Skip $ (GO_SINGLE_PAT s pat)
1542 -- This is identical for splitOn and splitSuffixOn
1544 res <- step (adaptState gst) st
1549 acc' <- if withSep then fstep acc x else return acc
1551 return $ Yield r (GO_SINGLE_PAT s pat)
1552 else fstep acc x >>= go SPEC s
1553 Skip s -> go SPEC s acc
1554 Stop -> done acc >>= \r -> return $ Yield r GO_DONE
1556 stepOuter gst (GO_SHORT_PAT stt) = do
1558 -- Call "initial" only if the stream yields an element, otherwise we
1559 -- may call "initial" but never yield anything. initial may produce a
1560 -- side effect, therefore we will end up doing and discard a side
1565 res <- step (adaptState gst) stt
1569 let wrd' = addToWord wrd x
1570 acc' <- if withSep then fstep acc x else return acc
1573 if wrd' .&. mask == patWord
1574 then done acc' >>= \r -> return $ Yield r (GO_SHORT_PAT s)
1575 else go0 SPEC (idx + 1) wrd' s acc'
1576 else go0 SPEC (idx + 1) wrd' s acc'
1577 Skip s -> return $ Skip (GO_SHORT_PAT s)
1583 mask = (1 `shiftL` (elemBits * patLen)) - 1
1585 addToWord wrd a = (wrd `shiftL` elemBits) .|. fromIntegral (fromEnum a)
1588 patWord = mask .&. A.foldl' addToWord 0 patArr
1590 go0 !_ !idx wrd st !acc = do
1591 res <- step (adaptState gst) st
1594 let wrd' = addToWord wrd x
1595 acc' <- if withSep then fstep acc x else return acc
1598 if wrd' .&. mask == patWord
1601 return $ Yield r (GO_SHORT_PAT s)
1602 else go1 SPEC wrd' s acc'
1603 else go0 SPEC (idx + 1) wrd' s acc'
1604 Skip s -> go0 SPEC idx wrd s acc
1606 if (idx == maxIndex) && (wrd .&. mask == patWord)
1609 acc' <- if idx /= 0 && not withSep
1610 then go2 wrd idx acc
1612 done acc' >>= \r -> return $ Yield r GO_DONE
1615 go1 !_ wrd st !acc = do
1616 res <- step (adaptState gst) st
1619 let wrd' = addToWord wrd x
1620 old = (mask .&. wrd) `shiftR` (elemBits * (patLen - 1))
1623 else fstep acc (toEnum $ fromIntegral old)
1624 if wrd' .&. mask == patWord
1625 then done acc' >>= \r -> return $ Yield r (GO_SHORT_PAT s)
1626 else go1 SPEC wrd' s acc'
1627 Skip s -> go1 SPEC wrd s acc
1629 -- If the last sequence is a separator do not issue a blank
1631 if wrd .&. mask == patWord
1636 else go2 wrd patLen acc
1637 done acc' >>= \r -> return $ Yield r GO_DONE
1639 go2 !wrd !n !acc | n > 0 = do
1640 let old = (mask .&. wrd) `shiftR` (elemBits * (n - 1))
1641 fstep acc (toEnum $ fromIntegral old) >>= go2 wrd (n - 1)
1642 go2 _ _ acc = return acc
1644 stepOuter gst (GO_KARP_RABIN stt rb rhead) = do
1646 res <- step (adaptState gst) stt
1650 acc' <- if withSep then fstep acc x else return acc
1651 rh' <- liftIO (RB.unsafeInsert rb rhead x)
1654 let fold = RB.unsafeFoldRing (RB.ringBound rb)
1655 let !ringHash = fold addCksum 0 rb
1656 if ringHash == patHash
1657 then go2 SPEC ringHash rh' s acc'
1658 else go0 SPEC (idx + 1) rh' s acc'
1659 else go0 SPEC (idx + 1) rh' s acc'
1660 Skip s -> return $ Skip (GO_KARP_RABIN s rb rhead)
1665 k = 2891336453 :: Word32
1667 addCksum cksum a = cksum * k + fromIntegral (fromEnum a)
1668 deltaCksum cksum old new =
1669 addCksum cksum new - coeff * fromIntegral (fromEnum old)
1671 -- XXX shall we use a random starting hash or 1 instead of 0?
1672 patHash = A.foldl' addCksum 0 patArr
1675 go0 !_ !idx !rh st !acc = do
1676 res <- step (adaptState gst) st
1679 acc' <- if withSep then fstep acc x else return acc
1680 rh' <- liftIO (RB.unsafeInsert rb rh x)
1683 let fold = RB.unsafeFoldRing (RB.ringBound rb)
1684 let !ringHash = fold addCksum 0 rb
1685 if ringHash == patHash
1686 then go2 SPEC ringHash rh' s acc'
1687 else go1 SPEC ringHash rh' s acc'
1688 else go0 SPEC (idx + 1) rh' s acc'
1689 Skip s -> go0 SPEC idx rh s acc
1691 -- do not issue a blank segment when we end at pattern
1692 if (idx == maxIndex) && RB.unsafeEqArray rb rh patArr
1695 !acc' <- if idx /= 0 && not withSep
1696 then RB.unsafeFoldRingM rh fstep acc rb
1698 done acc' >>= \r -> return $ Yield r GO_DONE
1700 -- XXX Theoretically this code can do 4 times faster if GHC generates
1701 -- optimal code. If we use just "(cksum' == patHash)" condition it goes
1702 -- 4x faster, as soon as we add the "RB.unsafeEqArray rb v" condition
1703 -- the generated code changes drastically and becomes 4x slower. Need
1704 -- to investigate what is going on with GHC.
1706 go1 !_ !cksum !rh st !acc = do
1707 res <- step (adaptState gst) st
1710 old <- liftIO $ peek rh
1711 let cksum' = deltaCksum cksum old x
1716 if (cksum' == patHash)
1718 rh' <- liftIO (RB.unsafeInsert rb rh x)
1719 go2 SPEC cksum' rh' s acc'
1721 rh' <- liftIO (RB.unsafeInsert rb rh x)
1722 go1 SPEC cksum' rh' s acc'
1723 Skip s -> go1 SPEC cksum rh s acc
1725 if RB.unsafeEqArray rb rh patArr
1730 else RB.unsafeFoldRingFullM rh fstep acc rb
1731 done acc' >>= \r -> return $ Yield r GO_DONE
1733 go2 !_ !cksum' !rh' s !acc' = do
1734 if RB.unsafeEqArray rb rh' patArr
1737 return $ Yield r (GO_KARP_RABIN s rb rhead)
1738 else go1 SPEC cksum' rh' s acc'
1740 stepOuter gst (GO_EMPTY_PAT st) = do
1741 res <- step (adaptState gst) st
1746 done acc' >>= \r -> return $ Yield r (GO_EMPTY_PAT s)
1747 Skip s -> return $ Skip (GO_EMPTY_PAT s)
1750 stepOuter _ GO_DONE = return Stop
1752data SplitState s arr
1754 | SplitBuffering s arr
1755 | SplitSplitting s arr
1756 | SplitYielding arr (SplitState s arr)
1759-- XXX An alternative approach would be to use a partial fold (Fold m a b) to
1760-- split using a splitBy like combinator. The Fold would consume upto the
1761-- separator and return any leftover which can then be fed to the next fold.
1763-- We can revisit this once we have partial folds/parsers.
1765-- | Performs infix separator style splitting.
1766{-# INLINE_NORMAL splitInnerBy #-}
1769 => (f a -> m (f a, Maybe (f a))) -- splitter
1770 -> (f a -> f a -> m (f a)) -- joiner
1773splitInnerBy splitter joiner (Stream step1 state1) =
1774 (Stream step (SplitInitial state1))
1778 {-# INLINE_LATE step #-}
1779 step gst (SplitInitial st) = do
1783 (x1, mx2) <- splitter x
1784 return $ case mx2 of
1785 Nothing -> Skip (SplitBuffering s x1)
1786 Just x2 -> Skip (SplitYielding x1 (SplitSplitting s x2))
1787 Skip s -> return $ Skip (SplitInitial s)
1788 Stop -> return $ Stop
1790 step gst (SplitBuffering st buf) = do
1794 (x1, mx2) <- splitter x
1795 buf' <- joiner buf x1
1796 return $ case mx2 of
1797 Nothing -> Skip (SplitBuffering s buf')
1798 Just x2 -> Skip (SplitYielding buf' (SplitSplitting s x2))
1799 Skip s -> return $ Skip (SplitBuffering s buf)
1800 Stop -> return $ Skip (SplitYielding buf SplitFinishing)
1802 step _ (SplitSplitting st buf) = do
1803 (x1, mx2) <- splitter buf
1804 return $ case mx2 of
1805 Nothing -> Skip $ SplitBuffering st x1
1806 Just x2 -> Skip $ SplitYielding x1 (SplitSplitting st x2)
1808 step _ (SplitYielding x next) = return $ Yield x next
1809 step _ SplitFinishing = return $ Stop
1811-- | Performs infix separator style splitting.
1812{-# INLINE_NORMAL splitInnerBySuffix #-}
1814 :: (Monad m, Eq (f a), Monoid (f a))
1815 => (f a -> m (f a, Maybe (f a))) -- splitter
1816 -> (f a -> f a -> m (f a)) -- joiner
1819splitInnerBySuffix splitter joiner (Stream step1 state1) =
1820 (Stream step (SplitInitial state1))
1824 {-# INLINE_LATE step #-}
1825 step gst (SplitInitial st) = do
1829 (x1, mx2) <- splitter x
1830 return $ case mx2 of
1831 Nothing -> Skip (SplitBuffering s x1)
1832 Just x2 -> Skip (SplitYielding x1 (SplitSplitting s x2))
1833 Skip s -> return $ Skip (SplitInitial s)
1834 Stop -> return $ Stop
1836 step gst (SplitBuffering st buf) = do
1840 (x1, mx2) <- splitter x
1841 buf' <- joiner buf x1
1842 return $ case mx2 of
1843 Nothing -> Skip (SplitBuffering s buf')
1844 Just x2 -> Skip (SplitYielding buf' (SplitSplitting s x2))
1845 Skip s -> return $ Skip (SplitBuffering s buf)
1849 else Skip (SplitYielding buf SplitFinishing)
1851 step _ (SplitSplitting st buf) = do
1852 (x1, mx2) <- splitter buf
1853 return $ case mx2 of
1854 Nothing -> Skip $ SplitBuffering st x1
1855 Just x2 -> Skip $ SplitYielding x1 (SplitSplitting st x2)
1857 step _ (SplitYielding x next) = return $ Yield x next
1858 step _ SplitFinishing = return $ Stop
1860------------------------------------------------------------------------------
1862------------------------------------------------------------------------------
1864{-# INLINE_NORMAL isPrefixOf #-}
1865isPrefixOf :: (Eq a, Monad m) => Stream m a -> Stream m a -> m Bool
1866isPrefixOf (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)
1868 go (sa, sb, Nothing) = do
1869 r <- stepa defState sa
1871 Yield x sa' -> go (sa', sb, Just x)
1872 Skip sa' -> go (sa', sb, Nothing)
1875 go (sa, sb, Just x) = do
1876 r <- stepb defState sb
1880 then go (sa, sb', Nothing)
1882 Skip sb' -> go (sa, sb', Just x)
1883 Stop -> return False
1885{-# INLINE_NORMAL isSubsequenceOf #-}
1886isSubsequenceOf :: (Eq a, Monad m) => Stream m a -> Stream m a -> m Bool
1887isSubsequenceOf (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)
1889 go (sa, sb, Nothing) = do
1890 r <- stepa defState sa
1892 Yield x sa' -> go (sa', sb, Just x)
1893 Skip sa' -> go (sa', sb, Nothing)
1896 go (sa, sb, Just x) = do
1897 r <- stepb defState sb
1901 then go (sa, sb', Nothing)
1902 else go (sa, sb', Just x)
1903 Skip sb' -> go (sa, sb', Just x)
1904 Stop -> return False
1906{-# INLINE_NORMAL stripPrefix #-}
1909 => Stream m a -> Stream m a -> m (Maybe (Stream m a))
1910stripPrefix (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)
1912 go (sa, sb, Nothing) = do
1913 r <- stepa defState sa
1915 Yield x sa' -> go (sa', sb, Just x)
1916 Skip sa' -> go (sa', sb, Nothing)
1917 Stop -> return $ Just (Stream stepb sb)
1919 go (sa, sb, Just x) = do
1920 r <- stepb defState sb
1924 then go (sa, sb', Nothing)
1926 Skip sb' -> go (sa, sb', Just x)
1927 Stop -> return Nothing
1929------------------------------------------------------------------------------
1931------------------------------------------------------------------------------
1933-- | Execute a monadic action for each element of the 'Stream'
1934{-# INLINE_NORMAL mapM_ #-}
1935mapM_ :: Monad m => (a -> m b) -> Stream m a -> m ()
1936mapM_ m = drain . mapM m
1938-------------------------------------------------------------------------------
1939-- Stream transformations using Unfolds
1940-------------------------------------------------------------------------------
1942-- Define a unique structure to use in inspection testing
1943data ConcatMapUState o i =
1945 | ConcatMapUInner o i
1947-- | @concatMapU unfold stream@ uses @unfold@ to map the input stream elements
1948-- to streams and then flattens the generated streams into a single output
1951-- This is like 'concatMap' but uses an unfold with an explicit state to
1952-- generate the stream instead of a 'Stream' type generator. This allows better
1953-- optimization via fusion. This can be many times more efficient than
1956{-# INLINE_NORMAL concatMapU #-}
1957concatMapU :: Monad m => Unfold m a b -> Stream m a -> Stream m b
1958concatMapU (Unfold istep inject) (Stream ostep ost) =
1959 Stream step (ConcatMapUOuter ost)
1961 {-# INLINE_LATE step #-}
1962 step gst (ConcatMapUOuter o) = do
1963 r <- ostep (adaptState gst) o
1967 i `seq` return (Skip (ConcatMapUInner o' i))
1968 Skip o' -> return $ Skip (ConcatMapUOuter o')
1969 Stop -> return $ Stop
1971 step _ (ConcatMapUInner o i) = do
1974 Yield x i' -> Yield x (ConcatMapUInner o i')
1975 Skip i' -> Skip (ConcatMapUInner o i')
1976 Stop -> Skip (ConcatMapUOuter o)
1978data ConcatUnfoldInterleaveState o i =
1979 ConcatUnfoldInterleaveOuter o [i]
1980 | ConcatUnfoldInterleaveInner o [i]
1981 | ConcatUnfoldInterleaveInnerL [i] [i]
1982 | ConcatUnfoldInterleaveInnerR [i] [i]
1984-- XXX use arrays to store state instead of lists.
1985-- XXX In general we can use different scheduling strategies e.g. how to
1986-- schedule the outer vs inner loop or assigning weights to different streams
1987-- or outer and inner loops.
1989-- After a yield, switch to the next stream. Do not switch streams on Skip.
1990-- Yield from outer stream switches to the inner stream.
1992-- There are two choices here, (1) exhaust the outer stream first and then
1993-- start yielding from the inner streams, this is much simpler to implement,
1994-- (2) yield at least one element from an inner stream before going back to
1995-- outer stream and opening the next stream from it.
1997-- Ideally, we need some scheduling bias to inner streams vs outer stream.
1998-- Maybe we can configure the behavior.
2000{-# INLINE_NORMAL concatUnfoldInterleave #-}
2001concatUnfoldInterleave :: Monad m => Unfold m a b -> Stream m a -> Stream m b
2002concatUnfoldInterleave (Unfold istep inject) (Stream ostep ost) =
2003 Stream step (ConcatUnfoldInterleaveOuter ost [])
2005 {-# INLINE_LATE step #-}
2006 step gst (ConcatUnfoldInterleaveOuter o ls) = do
2007 r <- ostep (adaptState gst) o
2011 i `seq` return (Skip (ConcatUnfoldInterleaveInner o' (i : ls)))
2012 Skip o' -> return $ Skip (ConcatUnfoldInterleaveOuter o' ls)
2013 Stop -> return $ Skip (ConcatUnfoldInterleaveInnerL ls [])
2015 step _ (ConcatUnfoldInterleaveInner _ []) = undefined
2016 step _ (ConcatUnfoldInterleaveInner o (st:ls)) = do
2019 Yield x s -> Yield x (ConcatUnfoldInterleaveOuter o (s:ls))
2020 Skip s -> Skip (ConcatUnfoldInterleaveInner o (s:ls))
2021 Stop -> Skip (ConcatUnfoldInterleaveOuter o ls)
2023 step _ (ConcatUnfoldInterleaveInnerL [] []) = return Stop
2024 step _ (ConcatUnfoldInterleaveInnerL [] rs) =
2025 return $ Skip (ConcatUnfoldInterleaveInnerR [] rs)
2027 step _ (ConcatUnfoldInterleaveInnerL (st:ls) rs) = do
2030 Yield x s -> Yield x (ConcatUnfoldInterleaveInnerL ls (s:rs))
2031 Skip s -> Skip (ConcatUnfoldInterleaveInnerL (s:ls) rs)
2032 Stop -> Skip (ConcatUnfoldInterleaveInnerL ls rs)
2034 step _ (ConcatUnfoldInterleaveInnerR [] []) = return Stop
2035 step _ (ConcatUnfoldInterleaveInnerR ls []) =
2036 return $ Skip (ConcatUnfoldInterleaveInnerL ls [])
2038 step _ (ConcatUnfoldInterleaveInnerR ls (st:rs)) = do
2041 Yield x s -> Yield x (ConcatUnfoldInterleaveInnerR (s:ls) rs)
2042 Skip s -> Skip (ConcatUnfoldInterleaveInnerR ls (s:rs))
2043 Stop -> Skip (ConcatUnfoldInterleaveInnerR ls rs)
2045-- XXX In general we can use different scheduling strategies e.g. how to
2046-- schedule the outer vs inner loop or assigning weights to different streams
2047-- or outer and inner loops.
2049-- This could be inefficient if the tasks are too small.
2051-- Compared to concatUnfoldInterleave this one switches streams on Skips.
2053{-# INLINE_NORMAL concatUnfoldRoundrobin #-}
2054concatUnfoldRoundrobin :: Monad m => Unfold m a b -> Stream m a -> Stream m b
2055concatUnfoldRoundrobin (Unfold istep inject) (Stream ostep ost) =
2056 Stream step (ConcatUnfoldInterleaveOuter ost [])
2058 {-# INLINE_LATE step #-}
2059 step gst (ConcatUnfoldInterleaveOuter o ls) = do
2060 r <- ostep (adaptState gst) o
2064 i `seq` return (Skip (ConcatUnfoldInterleaveInner o' (i : ls)))
2065 Skip o' -> return $ Skip (ConcatUnfoldInterleaveInner o' ls)
2066 Stop -> return $ Skip (ConcatUnfoldInterleaveInnerL ls [])
2068 step _ (ConcatUnfoldInterleaveInner o []) =
2069 return $ Skip (ConcatUnfoldInterleaveOuter o [])
2071 step _ (ConcatUnfoldInterleaveInner o (st:ls)) = do
2074 Yield x s -> Yield x (ConcatUnfoldInterleaveOuter o (s:ls))
2075 Skip s -> Skip (ConcatUnfoldInterleaveOuter o (s:ls))
2076 Stop -> Skip (ConcatUnfoldInterleaveOuter o ls)
2078 step _ (ConcatUnfoldInterleaveInnerL [] []) = return Stop
2079 step _ (ConcatUnfoldInterleaveInnerL [] rs) =
2080 return $ Skip (ConcatUnfoldInterleaveInnerR [] rs)
2082 step _ (ConcatUnfoldInterleaveInnerL (st:ls) rs) = do
2085 Yield x s -> Yield x (ConcatUnfoldInterleaveInnerL ls (s:rs))
2086 Skip s -> Skip (ConcatUnfoldInterleaveInnerL ls (s:rs))
2087 Stop -> Skip (ConcatUnfoldInterleaveInnerL ls rs)
2089 step _ (ConcatUnfoldInterleaveInnerR [] []) = return Stop
2090 step _ (ConcatUnfoldInterleaveInnerR ls []) =
2091 return $ Skip (ConcatUnfoldInterleaveInnerL ls [])
2093 step _ (ConcatUnfoldInterleaveInnerR ls (st:rs)) = do
2096 Yield x s -> Yield x (ConcatUnfoldInterleaveInnerR (s:ls) rs)
2097 Skip s -> Skip (ConcatUnfoldInterleaveInnerR (s:ls) rs)
2098 Stop -> Skip (ConcatUnfoldInterleaveInnerR ls rs)
2100data AppendState s1 s2 = AppendFirst s1 | AppendSecond s2
2102-- Note that this could be much faster compared to the CPS stream. However, as
2103-- the number of streams being composed increases this may become expensive.
2104-- Need to see where the breaking point is between the two.
2106{-# INLINE_NORMAL append #-}
2107append :: Monad m => Stream m a -> Stream m a -> Stream m a
2108append (Stream step1 state1) (Stream step2 state2) =
2109 Stream step (AppendFirst state1)
2113 {-# INLINE_LATE step #-}
2114 step gst (AppendFirst st) = do
2117 Yield a s -> Yield a (AppendFirst s)
2118 Skip s -> Skip (AppendFirst s)
2119 Stop -> Skip (AppendSecond state2)
2121 step gst (AppendSecond st) = do
2124 Yield a s -> Yield a (AppendSecond s)
2125 Skip s -> Skip (AppendSecond s)
2128data InterleaveState s1 s2 = InterleaveFirst s1 s2 | InterleaveSecond s1 s2
2129 | InterleaveSecondOnly s2 | InterleaveFirstOnly s1
2131{-# INLINE_NORMAL interleave #-}
2132interleave :: Monad m => Stream m a -> Stream m a -> Stream m a
2133interleave (Stream step1 state1) (Stream step2 state2) =
2134 Stream step (InterleaveFirst state1 state2)
2138 {-# INLINE_LATE step #-}
2139 step gst (InterleaveFirst st1 st2) = do
2142 Yield a s -> Yield a (InterleaveSecond s st2)
2143 Skip s -> Skip (InterleaveFirst s st2)
2144 Stop -> Skip (InterleaveSecondOnly st2)
2146 step gst (InterleaveSecond st1 st2) = do
2149 Yield a s -> Yield a (InterleaveFirst st1 s)
2150 Skip s -> Skip (InterleaveSecond st1 s)
2151 Stop -> Skip (InterleaveFirstOnly st1)
2153 step gst (InterleaveFirstOnly st1) = do
2156 Yield a s -> Yield a (InterleaveFirstOnly s)
2157 Skip s -> Skip (InterleaveFirstOnly s)
2160 step gst (InterleaveSecondOnly st2) = do
2163 Yield a s -> Yield a (InterleaveSecondOnly s)
2164 Skip s -> Skip (InterleaveSecondOnly s)
2167{-# INLINE_NORMAL interleaveMin #-}
2168interleaveMin :: Monad m => Stream m a -> Stream m a -> Stream m a
2169interleaveMin (Stream step1 state1) (Stream step2 state2) =
2170 Stream step (InterleaveFirst state1 state2)
2174 {-# INLINE_LATE step #-}
2175 step gst (InterleaveFirst st1 st2) = do
2178 Yield a s -> Yield a (InterleaveSecond s st2)
2179 Skip s -> Skip (InterleaveFirst s st2)
2182 step gst (InterleaveSecond st1 st2) = do
2185 Yield a s -> Yield a (InterleaveFirst st1 s)
2186 Skip s -> Skip (InterleaveSecond st1 s)
2189 step _ (InterleaveFirstOnly _) = undefined
2190 step _ (InterleaveSecondOnly _) = undefined
2192{-# INLINE_NORMAL interleaveSuffix #-}
2193interleaveSuffix :: Monad m => Stream m a -> Stream m a -> Stream m a
2194interleaveSuffix (Stream step1 state1) (Stream step2 state2) =
2195 Stream step (InterleaveFirst state1 state2)
2199 {-# INLINE_LATE step #-}
2200 step gst (InterleaveFirst st1 st2) = do
2203 Yield a s -> Yield a (InterleaveSecond s st2)
2204 Skip s -> Skip (InterleaveFirst s st2)
2207 step gst (InterleaveSecond st1 st2) = do
2210 Yield a s -> Yield a (InterleaveFirst st1 s)
2211 Skip s -> Skip (InterleaveSecond st1 s)
2212 Stop -> Skip (InterleaveFirstOnly st1)
2214 step gst (InterleaveFirstOnly st1) = do
2217 Yield a s -> Yield a (InterleaveFirstOnly s)
2218 Skip s -> Skip (InterleaveFirstOnly s)
2221 step _ (InterleaveSecondOnly _) = undefined
2223data InterleaveInfixState s1 s2 a
2224 = InterleaveInfixFirst s1 s2
2225 | InterleaveInfixSecondBuf s1 s2
2226 | InterleaveInfixSecondYield s1 s2 a
2227 | InterleaveInfixFirstYield s1 s2 a
2228 | InterleaveInfixFirstOnly s1
2230{-# INLINE_NORMAL interleaveInfix #-}
2231interleaveInfix :: Monad m => Stream m a -> Stream m a -> Stream m a
2232interleaveInfix (Stream step1 state1) (Stream step2 state2) =
2233 Stream step (InterleaveInfixFirst state1 state2)
2237 {-# INLINE_LATE step #-}
2238 step gst (InterleaveInfixFirst st1 st2) = do
2241 Yield a s -> Yield a (InterleaveInfixSecondBuf s st2)
2242 Skip s -> Skip (InterleaveInfixFirst s st2)
2245 step gst (InterleaveInfixSecondBuf st1 st2) = do
2248 Yield a s -> Skip (InterleaveInfixSecondYield st1 s a)
2249 Skip s -> Skip (InterleaveInfixSecondBuf st1 s)
2250 Stop -> Skip (InterleaveInfixFirstOnly st1)
2252 step gst (InterleaveInfixSecondYield st1 st2 x) = do
2255 Yield a s -> Yield x (InterleaveInfixFirstYield s st2 a)
2256 Skip s -> Skip (InterleaveInfixSecondYield s st2 x)
2259 step _ (InterleaveInfixFirstYield st1 st2 x) = do
2260 return $ Yield x (InterleaveInfixSecondBuf st1 st2)
2262 step gst (InterleaveInfixFirstOnly st1) = do
2265 Yield a s -> Yield a (InterleaveInfixFirstOnly s)
2266 Skip s -> Skip (InterleaveInfixFirstOnly s)
2269{-# INLINE_NORMAL roundRobin #-}
2270roundRobin :: Monad m => Stream m a -> Stream m a -> Stream m a
2271roundRobin (Stream step1 state1) (Stream step2 state2) =
2272 Stream step (InterleaveFirst state1 state2)
2276 {-# INLINE_LATE step #-}
2277 step gst (InterleaveFirst st1 st2) = do
2280 Yield a s -> Yield a (InterleaveSecond s st2)
2281 Skip s -> Skip (InterleaveSecond s st2)
2282 Stop -> Skip (InterleaveSecondOnly st2)
2284 step gst (InterleaveSecond st1 st2) = do
2287 Yield a s -> Yield a (InterleaveFirst st1 s)
2288 Skip s -> Skip (InterleaveFirst st1 s)
2289 Stop -> Skip (InterleaveFirstOnly st1)
2291 step gst (InterleaveSecondOnly st2) = do
2294 Yield a s -> Yield a (InterleaveSecondOnly s)
2295 Skip s -> Skip (InterleaveSecondOnly s)
2298 step gst (InterleaveFirstOnly st1) = do
2301 Yield a s -> Yield a (InterleaveFirstOnly s)
2302 Skip s -> Skip (InterleaveFirstOnly s)
2305data ICUState s1 s2 i1 i2 =
2310 | ICUFirstInner s1 s2 i1
2311 | ICUSecondInner s1 s2 i2
2312 | ICUFirstOnlyInner s1 i1
2313 | ICUSecondOnlyInner s2 i2
2315-- | Interleave streams (full streams, not the elements) unfolded from two
2316-- input streams and concat. Stop when the first stream stops. If the second
2317-- stream ends before the first one then first stream still keeps running alone
2318-- without any interleaving with the second stream.
2320-- [a1, a2, ... an] [b1, b2 ...]
2321-- => [streamA1, streamA2, ... streamAn] [streamB1, streamB2, ...]
2322-- => [streamA1, streamB1, streamA2...StreamAn, streamBn]
2323-- => [a11, a12, ...a1j, b11, b12, ...b1k, a21, a22, ...]
2325{-# INLINE_NORMAL gintercalateSuffix #-}
2328 => Unfold m a c -> Stream m a -> Unfold m b c -> Stream m b -> Stream m c
2330 (Unfold istep1 inject1) (Stream step1 state1)
2331 (Unfold istep2 inject2) (Stream step2 state2) =
2332 Stream step (ICUFirst state1 state2)
2336 {-# INLINE_LATE step #-}
2337 step gst (ICUFirst s1 s2) = do
2338 r <- step1 (adaptState gst) s1
2342 i `seq` return (Skip (ICUFirstInner s s2 i))
2343 Skip s -> return $ Skip (ICUFirst s s2)
2346 step gst (ICUFirstOnly s1) = do
2347 r <- step1 (adaptState gst) s1
2351 i `seq` return (Skip (ICUFirstOnlyInner s i))
2352 Skip s -> return $ Skip (ICUFirstOnly s)
2355 step _ (ICUFirstInner s1 s2 i1) = do
2358 Yield x i' -> Yield x (ICUFirstInner s1 s2 i')
2359 Skip i' -> Skip (ICUFirstInner s1 s2 i')
2360 Stop -> Skip (ICUSecond s1 s2)
2362 step _ (ICUFirstOnlyInner s1 i1) = do
2365 Yield x i' -> Yield x (ICUFirstOnlyInner s1 i')
2366 Skip i' -> Skip (ICUFirstOnlyInner s1 i')
2367 Stop -> Skip (ICUFirstOnly s1)
2369 step gst (ICUSecond s1 s2) = do
2370 r <- step2 (adaptState gst) s2
2374 i `seq` return (Skip (ICUSecondInner s1 s i))
2375 Skip s -> return $ Skip (ICUSecond s1 s)
2376 Stop -> return $ Skip (ICUFirstOnly s1)
2378 step _ (ICUSecondInner s1 s2 i2) = do
2381 Yield x i' -> Yield x (ICUSecondInner s1 s2 i')
2382 Skip i' -> Skip (ICUSecondInner s1 s2 i')
2383 Stop -> Skip (ICUFirst s1 s2)
2385 step _ (ICUSecondOnly _s2) = undefined
2386 step _ (ICUSecondOnlyInner _s2 _i2) = undefined
2388data InterposeSuffixState s1 i1 =
2389 InterposeSuffixFirst s1
2390 -- | InterposeSuffixFirstYield s1 i1
2391 | InterposeSuffixFirstInner s1 i1
2392 | InterposeSuffixSecond s1
2394-- Note that if an unfolded layer turns out to be nil we still emit the
2395-- separator effect. An alternate behavior could be to emit the separator
2396-- effect only if at least one element has been yielded by the unfolding.
2397-- However, that becomes a bit complicated, so we have chosen the former
2399{-# INLINE_NORMAL interposeSuffix #-}
2402 => m c -> Unfold m b c -> Stream m b -> Stream m c
2405 (Unfold istep1 inject1) (Stream step1 state1) =
2406 Stream step (InterposeSuffixFirst state1)
2410 {-# INLINE_LATE step #-}
2411 step gst (InterposeSuffixFirst s1) = do
2412 r <- step1 (adaptState gst) s1
2416 i `seq` return (Skip (InterposeSuffixFirstInner s i))
2417 -- i `seq` return (Skip (InterposeSuffixFirstYield s i))
2418 Skip s -> return $ Skip (InterposeSuffixFirst s)
2422 step _ (InterposeSuffixFirstYield s1 i1) = do
2425 Yield x i' -> Yield x (InterposeSuffixFirstInner s1 i')
2426 Skip i' -> Skip (InterposeSuffixFirstYield s1 i')
2427 Stop -> Skip (InterposeSuffixFirst s1)
2430 step _ (InterposeSuffixFirstInner s1 i1) = do
2433 Yield x i' -> Yield x (InterposeSuffixFirstInner s1 i')
2434 Skip i' -> Skip (InterposeSuffixFirstInner s1 i')
2435 Stop -> Skip (InterposeSuffixSecond s1)
2437 step _ (InterposeSuffixSecond s1) = do
2439 return $ Yield r (InterposeSuffixFirst s1)
2441data ICALState s1 s2 i1 i2 a =
2443 -- | ICALFirstYield s1 s2 i1
2444 | ICALFirstInner s1 s2 i1
2446 | ICALFirstOnlyInner s1 i1
2447 | ICALSecondInject s1 s2
2448 | ICALFirstInject s1 s2 i2
2449 -- | ICALFirstBuf s1 s2 i1 i2
2450 | ICALSecondInner s1 s2 i1 i2
2451 -- -- | ICALSecondInner s1 s2 i1 i2 a
2452 -- -- | ICALFirstResume s1 s2 i1 i2 a
2454-- | Interleave streams (full streams, not the elements) unfolded from two
2455-- input streams and concat. Stop when the first stream stops. If the second
2456-- stream ends before the first one then first stream still keeps running alone
2457-- without any interleaving with the second stream.
2459-- [a1, a2, ... an] [b1, b2 ...]
2460-- => [streamA1, streamA2, ... streamAn] [streamB1, streamB2, ...]
2461-- => [streamA1, streamB1, streamA2...StreamAn, streamBn]
2462-- => [a11, a12, ...a1j, b11, b12, ...b1k, a21, a22, ...]
2464{-# INLINE_NORMAL gintercalate #-}
2467 => Unfold m a c -> Stream m a -> Unfold m b c -> Stream m b -> Stream m c
2469 (Unfold istep1 inject1) (Stream step1 state1)
2470 (Unfold istep2 inject2) (Stream step2 state2) =
2471 Stream step (ICALFirst state1 state2)
2475 {-# INLINE_LATE step #-}
2476 step gst (ICALFirst s1 s2) = do
2477 r <- step1 (adaptState gst) s1
2481 i `seq` return (Skip (ICALFirstInner s s2 i))
2482 -- i `seq` return (Skip (ICALFirstYield s s2 i))
2483 Skip s -> return $ Skip (ICALFirst s s2)
2487 step _ (ICALFirstYield s1 s2 i1) = do
2490 Yield x i' -> Yield x (ICALFirstInner s1 s2 i')
2491 Skip i' -> Skip (ICALFirstYield s1 s2 i')
2492 Stop -> Skip (ICALFirst s1 s2)
2495 step _ (ICALFirstInner s1 s2 i1) = do
2498 Yield x i' -> Yield x (ICALFirstInner s1 s2 i')
2499 Skip i' -> Skip (ICALFirstInner s1 s2 i')
2500 Stop -> Skip (ICALSecondInject s1 s2)
2502 step gst (ICALFirstOnly s1) = do
2503 r <- step1 (adaptState gst) s1
2507 i `seq` return (Skip (ICALFirstOnlyInner s i))
2508 Skip s -> return $ Skip (ICALFirstOnly s)
2511 step _ (ICALFirstOnlyInner s1 i1) = do
2514 Yield x i' -> Yield x (ICALFirstOnlyInner s1 i')
2515 Skip i' -> Skip (ICALFirstOnlyInner s1 i')
2516 Stop -> Skip (ICALFirstOnly s1)
2518 -- We inject the second stream even before checking if the first stream
2519 -- would yield any more elements. There is no clear choice whether we
2520 -- should do this before or after that. Doing it after may make the state
2521 -- machine a bit simpler though.
2522 step gst (ICALSecondInject s1 s2) = do
2523 r <- step2 (adaptState gst) s2
2527 i `seq` return (Skip (ICALFirstInject s1 s i))
2528 Skip s -> return $ Skip (ICALSecondInject s1 s)
2529 Stop -> return $ Skip (ICALFirstOnly s1)
2531 step gst (ICALFirstInject s1 s2 i2) = do
2532 r <- step1 (adaptState gst) s1
2536 i `seq` return (Skip (ICALSecondInner s s2 i i2))
2537 -- i `seq` return (Skip (ICALFirstBuf s s2 i i2))
2538 Skip s -> return $ Skip (ICALFirstInject s s2 i2)
2542 step _ (ICALFirstBuf s1 s2 i1 i2) = do
2545 Yield x i' -> Skip (ICALSecondInner s1 s2 i' i2 x)
2546 Skip i' -> Skip (ICALFirstBuf s1 s2 i' i2)
2549 step _ (ICALSecondInner s1 s2 i1 i2 v) = do
2552 Yield x i' -> Yield x (ICALSecondInner s1 s2 i1 i' v)
2553 Skip i' -> Skip (ICALSecondInner s1 s2 i1 i' v)
2554 Stop -> Skip (ICALFirstResume s1 s2 i1 i2 v)
2557 step _ (ICALSecondInner s1 s2 i1 i2) = do
2560 Yield x i' -> Yield x (ICALSecondInner s1 s2 i1 i')
2561 Skip i' -> Skip (ICALSecondInner s1 s2 i1 i')
2562 Stop -> Skip (ICALFirstInner s1 s2 i1)
2563 -- Stop -> Skip (ICALFirstResume s1 s2 i1 i2)
2566 step _ (ICALFirstResume s1 s2 i1 i2 x) = do
2567 return $ Yield x (ICALFirstInner s1 s2 i1 i2)
2570data InterposeState s1 i1 a =
2572 -- | InterposeFirstYield s1 i1
2573 | InterposeFirstInner s1 i1
2574 | InterposeFirstInject s1
2575 -- | InterposeFirstBuf s1 i1
2576 | InterposeSecondYield s1 i1
2577 -- -- | InterposeSecondYield s1 i1 a
2578 -- -- | InterposeFirstResume s1 i1 a
2580-- Note that this only interposes the pure values, we may run many effects to
2581-- generate those values as some effects may not generate anything (Skip).
2582{-# INLINE_NORMAL interpose #-}
2583interpose :: Monad m => m c -> Unfold m b c -> Stream m b -> Stream m c
2586 (Unfold istep1 inject1) (Stream step1 state1) =
2587 Stream step (InterposeFirst state1)
2591 {-# INLINE_LATE step #-}
2592 step gst (InterposeFirst s1) = do
2593 r <- step1 (adaptState gst) s1
2597 i `seq` return (Skip (InterposeFirstInner s i))
2598 -- i `seq` return (Skip (InterposeFirstYield s i))
2599 Skip s -> return $ Skip (InterposeFirst s)
2603 step _ (InterposeFirstYield s1 i1) = do
2606 Yield x i' -> Yield x (InterposeFirstInner s1 i')
2607 Skip i' -> Skip (InterposeFirstYield s1 i')
2608 Stop -> Skip (InterposeFirst s1)
2611 step _ (InterposeFirstInner s1 i1) = do
2614 Yield x i' -> Yield x (InterposeFirstInner s1 i')
2615 Skip i' -> Skip (InterposeFirstInner s1 i')
2616 Stop -> Skip (InterposeFirstInject s1)
2618 step gst (InterposeFirstInject s1) = do
2619 r <- step1 (adaptState gst) s1
2623 -- i `seq` return (Skip (InterposeFirstBuf s i))
2624 i `seq` return (Skip (InterposeSecondYield s i))
2625 Skip s -> return $ Skip (InterposeFirstInject s)
2629 step _ (InterposeFirstBuf s1 i1) = do
2632 Yield x i' -> Skip (InterposeSecondYield s1 i' x)
2633 Skip i' -> Skip (InterposeFirstBuf s1 i')
2638 step _ (InterposeSecondYield s1 i1 v) = do
2640 return $ Yield r (InterposeFirstResume s1 i1 v)
2642 step _ (InterposeSecondYield s1 i1) = do
2644 return $ Yield r (InterposeFirstInner s1 i1)
2647 step _ (InterposeFirstResume s1 i1 v) = do
2648 return $ Yield v (InterposeFirstInner s1 i1)
2651------------------------------------------------------------------------------
2653------------------------------------------------------------------------------
2655data GbracketState s1 s2 v
2657 | GBracketNormal s1 v
2658 | GBracketException s2
2660-- | The most general bracketing and exception combinator. All other
2661-- combinators can be expressed in terms of this combinator. This can also be
2662-- used for cases which are not covered by the standard combinators.
2666{-# INLINE_NORMAL gbracket #-}
2670 -> (forall s. m s -> m (Either e s)) -- ^ try (exception handling)
2671 -> (c -> m d) -- ^ after, on normal stop
2672 -> (c -> e -> Stream m b) -- ^ on exception
2673 -> (c -> Stream m b) -- ^ stream generator
2675gbracket bef exc aft fexc fnormal =
2676 Stream step GBracketInit
2680 {-# INLINE_LATE step #-}
2681 step _ GBracketInit = do
2683 return $ Skip $ GBracketNormal (fnormal r) r
2685 step gst (GBracketNormal (UnStream step1 st) v) = do
2686 res <- exc $ step1 gst st
2688 Right r -> case r of
2690 return $ Yield x (GBracketNormal (Stream step1 s) v)
2691 Skip s -> return $ Skip (GBracketNormal (Stream step1 s) v)
2692 Stop -> aft v >> return Stop
2693 Left e -> return $ Skip (GBracketException (fexc v e))
2694 step gst (GBracketException (UnStream step1 st)) = do
2697 Yield x s -> return $ Yield x (GBracketException (Stream step1 s))
2698 Skip s -> return $ Skip (GBracketException (Stream step1 s))
2701-- | Run a side effect before the stream yields its first element.
2702{-# INLINE_NORMAL before #-}
2703before :: Monad m => m b -> Stream m a -> Stream m a
2704before action (Stream step state) = Stream step' Nothing
2708 {-# INLINE_LATE step' #-}
2709 step' _ Nothing = action >> return (Skip (Just state))
2711 step' gst (Just st) = do
2714 Yield x s -> return $ Yield x (Just s)
2715 Skip s -> return $ Skip (Just s)
2718-- | Run a side effect whenever the stream stops normally.
2719{-# INLINE_NORMAL after #-}
2720after :: Monad m => m b -> Stream m a -> Stream m a
2721after action (Stream step state) = Stream step' state
2725 {-# INLINE_LATE step' #-}
2729 Yield x s -> return $ Yield x s
2730 Skip s -> return $ Skip s
2731 Stop -> action >> return Stop
2733-- XXX These combinators are expensive due to the call to
2734-- onException/handle/try on each step. Therefore, when possible, they should
2735-- be called in an outer loop where we perform less iterations. For example, we
2736-- cannot call them on each iteration in a char stream, instead we can call
2737-- them when doing an IO on an array.
2739-- XXX For high performance error checks in busy streams we may need another
2740-- Error constructor in step.
2742-- | Run a side effect whenever the stream aborts due to an exception. The
2743-- exception is not caught, simply rethrown.
2744{-# INLINE_NORMAL onException #-}
2745onException :: MonadCatch m => m b -> Stream m a -> Stream m a
2746onException action str =
2747 gbracket (return ()) MC.try return
2748 (\_ (e :: MC.SomeException) -> nilM (action >> MC.throwM e))
2751{-# INLINE_NORMAL _onException #-}
2752_onException :: MonadCatch m => m b -> Stream m a -> Stream m a
2753_onException action (Stream step state) = Stream step' state
2757 {-# INLINE_LATE step' #-}
2759 res <- step gst st `MC.onException` action
2761 Yield x s -> return $ Yield x s
2762 Skip s -> return $ Skip s
2765-- XXX bracket is like concatMap, it generates a stream and then flattens it.
2766-- Like concatMap it has 10x worse performance compared to linear fused
2769-- | Run the first action before the stream starts and remember its output,
2770-- generate a stream using the output, run the second action providing the
2771-- remembered value as an argument whenever the stream ends normally or due to
2773{-# INLINE_NORMAL bracket #-}
2774bracket :: MonadCatch m => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a
2775bracket bef aft bet =
2776 gbracket bef MC.try aft
2777 (\a (e :: SomeException) -> nilM (aft a >> MC.throwM e)) bet
2779data BracketState s v = BracketInit | BracketRun s v
2781{-# INLINE_NORMAL _bracket #-}
2782_bracket :: MonadCatch m => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a
2783_bracket bef aft bet = Stream step' BracketInit
2787 {-# INLINE_LATE step' #-}
2788 step' _ BracketInit = bef >>= \x -> return (Skip (BracketRun (bet x) x))
2790 -- NOTE: It is important to use UnStream instead of the Stream pattern
2791 -- here, otherwise we get huge perf degradation, see note in concatMap.
2792 step' gst (BracketRun (UnStream step state) v) = do
2793 -- res <- step gst state `MC.onException` aft v
2794 res <- MC.try $ step gst state
2796 Left (e :: SomeException) -> aft v >> MC.throwM e >> return Stop
2797 Right r -> case r of
2798 Yield x s -> return $ Yield x (BracketRun (Stream step s) v)
2799 Skip s -> return $ Skip (BracketRun (Stream step s) v)
2800 Stop -> aft v >> return Stop
2802-- | Run a side effect whenever the stream stops normally or aborts due to an
2804{-# INLINE finally #-}
2805finally :: MonadCatch m => m b -> Stream m a -> Stream m a
2806-- finally action xs = after action $ onException action xs
2807finally action xs = bracket (return ()) (\_ -> action) (const xs)
2809-- | When evaluating a stream if an exception occurs, stream evaluation aborts
2810-- and the specified exception handler is run with the exception as argument.
2811{-# INLINE_NORMAL handle #-}
2812handle :: (MonadCatch m, Exception e)
2813 => (e -> Stream m a) -> Stream m a -> Stream m a
2815 gbracket (return ()) MC.try return (\_ e -> f e) (\_ -> str)
2817{-# INLINE_NORMAL _handle #-}
2818_handle :: (MonadCatch m, Exception e)
2819 => (e -> Stream m a) -> Stream m a -> Stream m a
2820_handle f (Stream step state) = Stream step' (Left state)
2824 {-# INLINE_LATE step' #-}
2825 step' gst (Left st) = do
2826 res <- MC.try $ step gst st
2828 Left e -> return $ Skip $ Right (f e)
2829 Right r -> case r of
2830 Yield x s -> return $ Yield x (Left s)
2831 Skip s -> return $ Skip (Left s)
2834 step' gst (Right (UnStream step1 st)) = do
2837 Yield x s -> return $ Yield x (Right (Stream step1 s))
2838 Skip s -> return $ Skip (Right (Stream step1 s))
2841-------------------------------------------------------------------------------
2842-- General transformation
2843-------------------------------------------------------------------------------
2845{-# INLINE_NORMAL transform #-}
2846transform :: Monad m => Pipe m a b -> Stream m a -> Stream m b
2847transform (Pipe pstep1 pstep2 pstate) (Stream step state) =
2848 Stream step' (Consume pstate, state)
2852 {-# INLINE_LATE step' #-}
2854 step' gst (Consume pst, st) = pst `seq` do
2855 r <- step (adaptState gst) st
2860 Pipe.Yield b pst' -> return $ Yield b (pst', s)
2861 Pipe.Continue pst' -> return $ Skip (pst', s)
2862 Skip s -> return $ Skip (Consume pst, s)
2865 step' _ (Produce pst, st) = pst `seq` do
2868 Pipe.Yield b pst' -> return $ Yield b (pst', st)
2869 Pipe.Continue pst' -> return $ Skip (pst', st)
2871------------------------------------------------------------------------------
2872-- Transformation by Folding (Scans)
2873------------------------------------------------------------------------------
2875------------------------------------------------------------------------------
2877------------------------------------------------------------------------------
2879-- XXX Is a prescan useful, discarding the last step does not sound useful? I
2880-- am not sure about the utility of this function, so this is implemented but
2881-- not exposed. We can expose it if someone provides good reasons why this is
2884-- XXX We have to execute the stream one step ahead to know that we are at the
2885-- last step. The vector implementation of prescan executes the last fold step
2886-- but does not yield the result. This means we have executed the effect but
2887-- discarded value. This does not sound right. In this implementation we are
2888-- not executing the last fold step.
2889{-# INLINE_NORMAL prescanlM' #-}
2890prescanlM' :: Monad m => (b -> a -> m b) -> m b -> Stream m a -> Stream m b
2891prescanlM' f mz (Stream step state) = Stream step' (state, mz)
2893 {-# INLINE_LATE step' #-}
2894 step' gst (st, prev) = do
2895 r <- step (adaptState gst) st
2899 return $ Yield acc (s, f acc x)
2900 Skip s -> return $ Skip (s, prev)
2903{-# INLINE prescanl' #-}
2904prescanl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b
2905prescanl' f z = prescanlM' (\a b -> return (f a b)) (return z)
2907------------------------------------------------------------------------------
2908-- Monolithic postscans (postscan followed by a map)
2909------------------------------------------------------------------------------
2911-- The performance of a modular postscan followed by a map seems to be
2912-- equivalent to this monolithic scan followed by map therefore we may not need
2913-- this implementation. We just have it for performance comparison and in case
2914-- modular version does not perform well in some situation.
2916{-# INLINE_NORMAL postscanlMx' #-}
2917postscanlMx' :: Monad m
2918 => (x -> a -> m x) -> m x -> (x -> m b) -> Stream m a -> Stream m b
2919postscanlMx' fstep begin done (Stream step state) = do
2920 Stream step' (state, begin)
2922 {-# INLINE_LATE step' #-}
2923 step' gst (st, acc) = do
2924 r <- step (adaptState gst) st
2930 v `seq` y `seq` return (Yield v (s, return y))
2931 Skip s -> return $ Skip (s, acc)
2934{-# INLINE_NORMAL postscanlx' #-}
2935postscanlx' :: Monad m
2936 => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> Stream m b
2937postscanlx' fstep begin done s =
2938 postscanlMx' (\b a -> return (fstep b a)) (return begin) (return . done) s
2940-- XXX do we need consM strict to evaluate the begin value?
2941{-# INLINE scanlMx' #-}
2943 => (x -> a -> m x) -> m x -> (x -> m b) -> Stream m a -> Stream m b
2944scanlMx' fstep begin done s =
2945 (begin >>= \x -> x `seq` done x) `consM` postscanlMx' fstep begin done s
2947{-# INLINE scanlx' #-}
2949 => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> Stream m b
2950scanlx' fstep begin done s =
2951 scanlMx' (\b a -> return (fstep b a)) (return begin) (return . done) s
2953------------------------------------------------------------------------------
2955------------------------------------------------------------------------------
2957{-# INLINE_NORMAL postscanlM' #-}
2958postscanlM' :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
2959postscanlM' fstep begin (Stream step state) =
2960 begin `seq` Stream step' (state, begin)
2962 {-# INLINE_LATE step' #-}
2963 step' gst (st, acc) = acc `seq` do
2964 r <- step (adaptState gst) st
2968 y `seq` return (Yield y (s, y))
2969 Skip s -> return $ Skip (s, acc)
2972{-# INLINE_NORMAL postscanl' #-}
2973postscanl' :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a
2974postscanl' f = postscanlM' (\a b -> return (f a b))
2976{-# INLINE_NORMAL postscanlM #-}
2977postscanlM :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
2978postscanlM fstep begin (Stream step state) = Stream step' (state, begin)
2980 {-# INLINE_LATE step' #-}
2981 step' gst (st, acc) = do
2982 r <- step (adaptState gst) st
2986 return (Yield y (s, y))
2987 Skip s -> return $ Skip (s, acc)
2990{-# INLINE_NORMAL postscanl #-}
2991postscanl :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a
2992postscanl f = postscanlM (\a b -> return (f a b))
2994{-# INLINE_NORMAL scanlM' #-}
2995scanlM' :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
2996scanlM' fstep begin s = begin `seq` (begin `cons` postscanlM' fstep begin s)
2998{-# INLINE scanl' #-}
2999scanl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b
3000scanl' f = scanlM' (\a b -> return (f a b))
3002{-# INLINE_NORMAL scanlM #-}
3003scanlM :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
3004scanlM fstep begin s = begin `cons` postscanlM fstep begin s
3007scanl :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b
3008scanl f = scanlM (\a b -> return (f a b))
3010{-# INLINE_NORMAL scanl1M #-}
3011scanl1M :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a
3012scanl1M fstep (Stream step state) = Stream step' (state, Nothing)
3014 {-# INLINE_LATE step' #-}
3015 step' gst (st, Nothing) = do
3018 Yield x s -> return $ Yield x (s, Just x)
3019 Skip s -> return $ Skip (s, Nothing)
3022 step' gst (st, Just acc) = do
3027 return $ Yield z (s, Just z)
3028 Skip s -> return $ Skip (s, Just acc)
3031{-# INLINE scanl1 #-}
3032scanl1 :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a
3033scanl1 f = scanl1M (\x y -> return (f x y))
3035{-# INLINE_NORMAL scanl1M' #-}
3036scanl1M' :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a
3037scanl1M' fstep (Stream step state) = Stream step' (state, Nothing)
3039 {-# INLINE_LATE step' #-}
3040 step' gst (st, Nothing) = do
3043 Yield x s -> x `seq` return $ Yield x (s, Just x)
3044 Skip s -> return $ Skip (s, Nothing)
3047 step' gst (st, Just acc) = acc `seq` do
3052 z `seq` return $ Yield z (s, Just z)
3053 Skip s -> return $ Skip (s, Just acc)
3056{-# INLINE scanl1' #-}
3057scanl1' :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a
3058scanl1' f = scanl1M' (\x y -> return (f x y))
3061tap :: Monad m => Fold m a b -> Stream m a -> Stream m a
3062tap (Fold fstep initial extract) (Stream step state) = Stream step' Nothing
3066 step' _ Nothing = do
3068 return $ Skip (Just (r, state))
3070 step' gst (Just (acc, st)) = do
3075 return $ Yield x (Just (acc', s))
3076 Skip s -> return $ Skip (Just (acc, s))
3081-------------------------------------------------------------------------------
3083-------------------------------------------------------------------------------
3085{-# INLINE_NORMAL takeWhileM #-}
3086takeWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a
3087takeWhileM f (Stream step state) = Stream step' state
3089 {-# INLINE_LATE step' #-}
3095 return $ if b then Yield x s else Stop
3096 Skip s -> return $ Skip s
3099{-# INLINE takeWhile #-}
3100takeWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
3101takeWhile f = takeWhileM (return . f)
3103{-# INLINE_NORMAL drop #-}
3104drop :: Monad m => Int -> Stream m a -> Stream m a
3105drop n (Stream step state) = Stream step' (state, Just n)
3107 {-# INLINE_LATE step' #-}
3108 step' gst (st, Just i)
3113 Yield _ s -> Skip (s, Just (i - 1))
3114 Skip s -> Skip (s, Just i)
3116 | otherwise = return $ Skip (st, Nothing)
3118 step' gst (st, Nothing) = do
3122 Yield x s -> Yield x (s, Nothing)
3123 Skip s -> Skip (s, Nothing)
3126data DropWhileState s a
3128 | DropWhileYield a s
3131{-# INLINE_NORMAL dropWhileM #-}
3132dropWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a
3133dropWhileM f (Stream step state) = Stream step' (DropWhileDrop state)
3135 {-# INLINE_LATE step' #-}
3136 step' gst (DropWhileDrop st) = do
3142 then return $ Skip (DropWhileDrop s)
3143 else return $ Skip (DropWhileYield x s)
3144 Skip s -> return $ Skip (DropWhileDrop s)
3147 step' gst (DropWhileNext st) = do
3150 Yield x s -> return $ Skip (DropWhileYield x s)
3151 Skip s -> return $ Skip (DropWhileNext s)
3154 step' _ (DropWhileYield x st) = return $ Yield x (DropWhileNext st)
3156{-# INLINE dropWhile #-}
3157dropWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
3158dropWhile f = dropWhileM (return . f)
3160{-# INLINE_NORMAL filterM #-}
3161filterM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a
3162filterM f (Stream step state) = Stream step' state
3164 {-# INLINE_LATE step' #-}
3173 Skip s -> return $ Skip s
3176{-# INLINE filter #-}
3177filter :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
3178filter f = filterM (return . f)
3180{-# INLINE_NORMAL uniq #-}
3181uniq :: (Eq a, Monad m) => Stream m a -> Stream m a
3182uniq (Stream step state) = Stream step' (Nothing, state)
3184 {-# INLINE_LATE step' #-}
3185 step' gst (Nothing, st) = do
3188 Yield x s -> return $ Yield x (Just x, s)
3189 Skip s -> return $ Skip (Nothing, s)
3191 step' gst (Just x, st) = do
3194 Yield y s | x == y -> return $ Skip (Just x, s)
3195 | otherwise -> return $ Yield y (Just y, s)
3196 Skip s -> return $ Skip (Just x, s)
3199------------------------------------------------------------------------------
3200-- Transformation by Mapping
3201------------------------------------------------------------------------------
3203{-# INLINE_NORMAL sequence #-}
3204sequence :: Monad m => Stream m (m a) -> Stream m a
3205sequence (Stream step state) = Stream step' state
3207 {-# INLINE_LATE step' #-}
3209 r <- step (adaptState gst) st
3211 Yield x s -> x >>= \a -> return (Yield a s)
3212 Skip s -> return $ Skip s
3215------------------------------------------------------------------------------
3217------------------------------------------------------------------------------
3219data LoopState x s = FirstYield s
3220 | InterspersingYield s
3223{-# INLINE_NORMAL intersperseM #-}
3224intersperseM :: Monad m => m a -> Stream m a -> Stream m a
3225intersperseM m (Stream step state) = Stream step' (FirstYield state)
3227 {-# INLINE_LATE step' #-}
3228 step' gst (FirstYield st) = do
3232 Yield x s -> Skip (YieldAndCarry x s)
3233 Skip s -> Skip (FirstYield s)
3236 step' gst (InterspersingYield st) = do
3241 return $ Yield a (YieldAndCarry x s)
3242 Skip s -> return $ Skip $ InterspersingYield s
3245 step' _ (YieldAndCarry x st) = return $ Yield x (InterspersingYield st)
3250 | SuffixYield a (SuffixState s a)
3252{-# INLINE_NORMAL intersperseSuffix #-}
3253intersperseSuffix :: forall m a. Monad m => m a -> Stream m a -> Stream m a
3254intersperseSuffix action (Stream step state) = Stream step' (SuffixElem state)
3256 {-# INLINE_LATE step' #-}
3257 step' gst (SuffixElem st) = do
3260 Yield x s -> Skip (SuffixYield x (SuffixSuffix s))
3261 Skip s -> Skip (SuffixElem s)
3264 step' _ (SuffixSuffix st) = do
3265 action >>= \r -> return $ Skip (SuffixYield r (SuffixElem st))
3267 step' _ (SuffixYield x next) = return $ Yield x next
3269{-# INLINE intersperse #-}
3270intersperse :: Monad m => a -> Stream m a -> Stream m a
3271intersperse a = intersperseM (return a)
3273{-# INLINE_NORMAL insertBy #-}
3274insertBy :: Monad m => (a -> a -> Ordering) -> a -> Stream m a -> Stream m a
3275insertBy cmp a (Stream step state) = Stream step' (state, False, Nothing)
3277 {-# INLINE_LATE step' #-}
3278 step' gst (st, False, _) = do
3281 Yield x s -> case cmp a x of
3282 GT -> return $ Yield x (s, False, Nothing)
3283 _ -> return $ Yield a (s, True, Just x)
3284 Skip s -> return $ Skip (s, False, Nothing)
3285 Stop -> return $ Yield a (st, True, Nothing)
3287 step' _ (_, True, Nothing) = return Stop
3289 step' gst (st, True, Just prev) = do
3292 Yield x s -> return $ Yield prev (s, True, Just x)
3293 Skip s -> return $ Skip (s, True, Just prev)
3294 Stop -> return $ Yield prev (st, True, Nothing)
3296------------------------------------------------------------------------------
3298------------------------------------------------------------------------------
3300{-# INLINE_NORMAL deleteBy #-}
3301deleteBy :: Monad m => (a -> a -> Bool) -> a -> Stream m a -> Stream m a
3302deleteBy eq x (Stream step state) = Stream step' (state, False)
3304 {-# INLINE_LATE step' #-}
3305 step' gst (st, False) = do
3308 Yield y s -> return $
3309 if eq x y then Skip (s, True) else Yield y (s, False)
3310 Skip s -> return $ Skip (s, False)
3313 step' gst (st, True) = do
3316 Yield y s -> return $ Yield y (s, True)
3317 Skip s -> return $ Skip (s, True)
3320------------------------------------------------------------------------------
3321-- Transformation by Map and Filter
3322------------------------------------------------------------------------------
3324-- XXX Will this always fuse properly?
3325{-# INLINE_NORMAL mapMaybe #-}
3326mapMaybe :: Monad m => (a -> Maybe b) -> Stream m a -> Stream m b
3327mapMaybe f = fmap fromJust . filter isJust . map f
3329{-# INLINE_NORMAL mapMaybeM #-}
3330mapMaybeM :: Monad m => (a -> m (Maybe b)) -> Stream m a -> Stream m b
3331mapMaybeM f = fmap fromJust . filter isJust . mapM f
3333------------------------------------------------------------------------------
3335------------------------------------------------------------------------------
3337{-# INLINE_NORMAL indexed #-}
3338indexed :: Monad m => Stream m a -> Stream m (Int, a)
3339indexed (Stream step state) = Stream step' (state, 0)
3341 {-# INLINE_LATE step' #-}
3342 step' gst (st, i) = i `seq` do
3343 r <- step (adaptState gst) st
3345 Yield x s -> return $ Yield (i, x) (s, i+1)
3346 Skip s -> return $ Skip (s, i)
3349{-# INLINE_NORMAL indexedR #-}
3350indexedR :: Monad m => Int -> Stream m a -> Stream m (Int, a)
3351indexedR m (Stream step state) = Stream step' (state, m)
3353 {-# INLINE_LATE step' #-}
3354 step' gst (st, i) = i `seq` do
3355 r <- step (adaptState gst) st
3357 Yield x s -> let i' = i - 1
3358 in return $ Yield (i, x) (s, i')
3359 Skip s -> return $ Skip (s, i)
3362{-# INLINE_NORMAL zipWithM #-}
3364 => (a -> b -> m c) -> Stream m a -> Stream m b -> Stream m c
3365zipWithM f (Stream stepa ta) (Stream stepb tb) = Stream step (ta, tb, Nothing)
3367 {-# INLINE_LATE step #-}
3368 step gst (sa, sb, Nothing) = do
3369 r <- stepa (adaptState gst) sa
3372 Yield x sa' -> Skip (sa', sb, Just x)
3373 Skip sa' -> Skip (sa', sb, Nothing)
3376 step gst (sa, sb, Just x) = do
3377 r <- stepb (adaptState gst) sb
3381 return $ Yield z (sa, sb', Nothing)
3382 Skip sb' -> return $ Skip (sa, sb', Just x)
3385#if __GLASGOW_HASKELL__ >= 801
3386{-# RULES "zipWithM xs xs"
3387 forall f xs. zipWithM @Identity f xs xs = mapM (\x -> f x x) xs #-}
3390{-# INLINE zipWith #-}
3391zipWith :: Monad m => (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c
3392zipWith f = zipWithM (\a b -> return (f a b))
3394------------------------------------------------------------------------------
3396------------------------------------------------------------------------------
3398{-# INLINE_NORMAL mergeByM #-}
3401 => (a -> a -> m Ordering) -> Stream m a -> Stream m a -> Stream m a
3402mergeByM cmp (Stream stepa ta) (Stream stepb tb) =
3403 Stream step (Just ta, Just tb, Nothing, Nothing)
3405 {-# INLINE_LATE step #-}
3407 -- one of the values is missing, and the corresponding stream is running
3408 step gst (Just sa, sb, Nothing, b) = do
3411 Yield a sa' -> Skip (Just sa', sb, Just a, b)
3412 Skip sa' -> Skip (Just sa', sb, Nothing, b)
3413 Stop -> Skip (Nothing, sb, Nothing, b)
3415 step gst (sa, Just sb, a, Nothing) = do
3418 Yield b sb' -> Skip (sa, Just sb', a, Just b)
3419 Skip sb' -> Skip (sa, Just sb', a, Nothing)
3420 Stop -> Skip (sa, Nothing, a, Nothing)
3422 -- both the values are available
3423 step _ (sa, sb, Just a, Just b) = do
3425 return $ case res of
3426 GT -> Yield b (sa, sb, Just a, Nothing)
3427 _ -> Yield a (sa, sb, Nothing, Just b)
3429 -- one of the values is missing, corresponding stream is done
3430 step _ (Nothing, sb, Nothing, Just b) =
3431 return $ Yield b (Nothing, sb, Nothing, Nothing)
3433 step _ (sa, Nothing, Just a, Nothing) =
3434 return $ Yield a (sa, Nothing, Nothing, Nothing)
3436 step _ (Nothing, Nothing, Nothing, Nothing) = return Stop
3438{-# INLINE mergeBy #-}
3441 => (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a
3442mergeBy cmp = mergeByM (\a b -> return $ cmp a b)
3444------------------------------------------------------------------------------
3445-- Transformation comprehensions
3446------------------------------------------------------------------------------
3448{-# INLINE_NORMAL the #-}
3449the :: (Eq a, Monad m) => Stream m a -> m (Maybe a)
3450the (Stream step state) = go state
3453 r <- step defState st
3455 Yield x s -> go' x s
3457 Stop -> return Nothing
3459 r <- step defState st
3461 Yield x s | x == n -> go' n s
3462 | otherwise -> return Nothing
3464 Stop -> return (Just n)
3466--------------------------------------------------------------------------------
3467-- UTF8 Encoding / Decoding
3468--------------------------------------------------------------------------------
3470-- UTF-8 primitives, Lifted from GHC.IO.Encoding.UTF8.
3473ord2 :: Char -> WList
3474ord2 c = assert (n >= 0x80 && n <= 0x07ff) (WCons x1 (WCons x2 WNil))
3477 x1 = fromIntegral $ (n `shiftR` 6) + 0xC0
3478 x2 = fromIntegral $ (n .&. 0x3F) + 0x80
3481ord3 :: Char -> WList
3482ord3 c = assert (n >= 0x0800 && n <= 0xffff) (WCons x1 (WCons x2 (WCons x3 WNil)))
3485 x1 = fromIntegral $ (n `shiftR` 12) + 0xE0
3486 x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
3487 x3 = fromIntegral $ (n .&. 0x3F) + 0x80
3490ord4 :: Char -> WList
3491ord4 c = assert (n >= 0x10000) (WCons x1 (WCons x2 (WCons x3 (WCons x4 WNil))))
3494 x1 = fromIntegral $ (n `shiftR` 18) + 0xF0
3495 x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80
3496 x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
3497 x4 = fromIntegral $ (n .&. 0x3F) + 0x80
3499data CodingFailureMode
3500 = TransliterateCodingFailure
3501 | ErrorOnCodingFailure
3504{-# INLINE replacementChar #-}
3505replacementChar :: Char
3506replacementChar = '\xFFFD'
3508-- Int helps in cheaper conversion from Int to Char
3510type DecodeState = Word8
3512-- See http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ for details.
3514{-# INLINE runFold #-}
3515runFold :: (Monad m) => Fold m a b -> Stream m a -> m b
3516runFold (Fold step begin done) = foldlMx' step begin done
3518-- XXX Use names decodeSuccess = 0, decodeFailure = 12
3520decodeTable :: [Word8]
3522 -- The first part of the table maps bytes to character classes that
3523 -- to reduce the size of the transition table and create bitmasks.
3524 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,
3525 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,
3526 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,
3527 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,
3528 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,
3529 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,
3530 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,
3531 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,
3533 -- The second part is a transition table that maps a combination
3534 -- of a state of the automaton and a character class to a state.
3535 0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12,
3536 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,
3537 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,
3538 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,
3539 12,36,12,12,12,12,12,12,12,12,12,12
3542utf8d :: A.Array Word8
3545 -- Aligning to cacheline makes a barely noticeable difference
3546 -- XXX currently alignment is not implemented for unmanaged allocation
3547 $ runFold (A.writeNAlignedUnmanaged 64 (length decodeTable))
3548 (fromList decodeTable)
3550-- | Return element at the specified index without checking the bounds.
3551-- and without touching the foreign ptr.
3552{-# INLINE_NORMAL unsafePeekElemOff #-}
3553unsafePeekElemOff :: forall a. Storable a => Ptr a -> Int -> a
3554unsafePeekElemOff p i = let !x = A.unsafeInlineIO $ peekElemOff p i in x
3556-- decode is split into two separate cases to avoid branching instructions.
3557-- From the higher level flow we already know which case we are in so we can
3558-- call the appropriate decode function.
3560-- When the state is 0
3561{-# INLINE decode0 #-}
3562decode0 :: Ptr Word8 -> Word8 -> Tuple' DecodeState CodePoint
3564 let !t = table `unsafePeekElemOff` fromIntegral byte
3565 !codep' = (0xff `shiftR` (fromIntegral t)) .&. fromIntegral byte
3566 !state' = table `unsafePeekElemOff` (256 + fromIntegral t)
3567 in assert ((byte > 0x7f || error showByte)
3568 && (state' /= 0 || error (showByte ++ showTable)))
3569 (Tuple' state' codep')
3574 let !(Ptr addr) = table
3575 end = table `plusPtr` 364
3576 in A.Array (ForeignPtr addr undefined) end end :: A.Array Word8
3577 showByte = "Streamly: decode0: byte: " ++ show byte
3578 showTable = " table: " ++ show utf8table
3580-- When the state is not 0
3581{-# INLINE decode1 #-}
3587 -> Tuple' DecodeState CodePoint
3588decode1 table state codep byte =
3589 -- Remember codep is Int type!
3590 -- Can it be unsafe to convert the resulting Int to Char?
3591 let !t = table `unsafePeekElemOff` fromIntegral byte
3592 !codep' = (fromIntegral byte .&. 0x3f) .|. (codep `shiftL` 6)
3593 !state' = table `unsafePeekElemOff`
3594 (256 + fromIntegral state + fromIntegral t)
3595 in assert (codep' <= 0x10FFFF
3596 || error (showByte ++ showState state codep))
3597 (Tuple' state' codep')
3601 let !(Ptr addr) = table
3602 end = table `plusPtr` 364
3603 in A.Array (ForeignPtr addr undefined) end end :: A.Array Word8
3604 showByte = "Streamly: decode1: byte: " ++ show byte
3606 " state: " ++ show st ++
3607 " codepoint: " ++ show cp ++
3608 " table: " ++ show utf8table
3610-- We can divide the errors in three general categories:
3611-- * A non-starter was encountered in a begin state
3612-- * A starter was encountered without completing a codepoint
3613-- * The last codepoint was not complete (input underflow)
3615data DecodeError = DecodeError !DecodeState !CodePoint deriving Show
3618 = FreshPointDecodeInit s
3619 | FreshPointDecodeInit1 s Word8
3620 | FreshPointDecodeFirst s Word8
3621 | FreshPointDecoding s !DecodeState !CodePoint
3622 | YieldAndContinue a (FreshPoint s a)
3625-- XXX Add proper error messages
3626-- XXX Implement this in terms of decodeUtf8Either
3627{-# INLINE_NORMAL decodeUtf8With #-}
3628decodeUtf8With :: Monad m => CodingFailureMode -> Stream m Word8 -> Stream m Char
3629decodeUtf8With cfm (Stream step state) =
3630 let Array p _ _ = utf8d
3631 !ptr = (unsafeForeignPtrToPtr p)
3632 in Stream (step' ptr) (FreshPointDecodeInit state)
3634 {-# INLINE transliterateOrError #-}
3635 transliterateOrError e s =
3637 ErrorOnCodingFailure -> error e
3638 TransliterateCodingFailure -> YieldAndContinue replacementChar s
3639 {-# INLINE inputUnderflow #-}
3642 ErrorOnCodingFailure ->
3643 error "Streamly.Streams.StreamD.decodeUtf8With: Input Underflow"
3644 TransliterateCodingFailure -> YieldAndContinue replacementChar Done
3645 {-# INLINE_LATE step' #-}
3646 step' _ gst (FreshPointDecodeInit st) = do
3647 r <- step (adaptState gst) st
3649 Yield x s -> Skip (FreshPointDecodeInit1 s x)
3650 Skip s -> Skip (FreshPointDecodeInit s)
3653 step' _ _ (FreshPointDecodeInit1 st x) = do
3654 -- Note: It is important to use a ">" instead of a "<=" test
3655 -- here for GHC to generate code layout for default branch
3656 -- prediction for the common case. This is fragile and might
3657 -- change with the compiler versions, we need a more reliable
3658 -- "likely" primitive to control branch predication.
3661 return $ Skip $ YieldAndContinue
3662 (unsafeChr (fromIntegral x))
3663 (FreshPointDecodeInit st)
3664 -- Using a separate state here generates a jump to a
3665 -- separate code block in the core which seems to perform
3666 -- slightly better for the non-ascii case.
3667 True -> return $ Skip $ FreshPointDecodeFirst st x
3669 -- XXX should we merge it with FreshPointDecodeInit1?
3670 step' table _ (FreshPointDecodeFirst st x) = do
3671 let (Tuple' sv cp) = decode0 table x
3676 transliterateOrError
3677 "Streamly.Streams.StreamD.decodeUtf8With: Invalid UTF8 codepoint encountered"
3678 (FreshPointDecodeInit st)
3679 0 -> error "unreachable state"
3680 _ -> Skip (FreshPointDecoding st sv cp)
3682 -- We recover by trying the new byte x a starter of a new codepoint.
3683 -- XXX need to use the same recovery in array decoding routine as well
3684 step' table gst (FreshPointDecoding st statePtr codepointPtr) = do
3685 r <- step (adaptState gst) st
3688 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
3691 0 -> Skip $ YieldAndContinue (unsafeChr cp)
3692 (FreshPointDecodeInit s)
3695 transliterateOrError
3696 "Streamly.Streams.StreamD.decodeUtf8With: Invalid UTF8 codepoint encountered"
3697 (FreshPointDecodeInit1 s x)
3698 _ -> Skip (FreshPointDecoding s sv cp)
3699 Skip s -> return $ Skip (FreshPointDecoding s statePtr codepointPtr)
3700 Stop -> return $ Skip inputUnderflow
3702 step' _ _ (YieldAndContinue c s) = return $ Yield c s
3703 step' _ _ Done = return Stop
3705{-# INLINE decodeUtf8 #-}
3706decodeUtf8 :: Monad m => Stream m Word8 -> Stream m Char
3707decodeUtf8 = decodeUtf8With ErrorOnCodingFailure
3709{-# INLINE decodeUtf8Lenient #-}
3710decodeUtf8Lenient :: Monad m => Stream m Word8 -> Stream m Char
3711decodeUtf8Lenient = decodeUtf8With TransliterateCodingFailure
3713{-# INLINE_NORMAL resumeDecodeUtf8Either #-}
3714resumeDecodeUtf8Either
3719 -> Stream m (Either DecodeError Char)
3720resumeDecodeUtf8Either dst codep (Stream step state) =
3721 let Array p _ _ = utf8d
3722 !ptr = (unsafeForeignPtrToPtr p)
3725 then FreshPointDecodeInit state
3726 else FreshPointDecoding state dst codep
3727 in Stream (step' ptr) stt
3729 {-# INLINE_LATE step' #-}
3730 step' _ gst (FreshPointDecodeInit st) = do
3731 r <- step (adaptState gst) st
3733 Yield x s -> Skip (FreshPointDecodeInit1 s x)
3734 Skip s -> Skip (FreshPointDecodeInit s)
3737 step' _ _ (FreshPointDecodeInit1 st x) = do
3738 -- Note: It is important to use a ">" instead of a "<=" test
3739 -- here for GHC to generate code layout for default branch
3740 -- prediction for the common case. This is fragile and might
3741 -- change with the compiler versions, we need a more reliable
3742 -- "likely" primitive to control branch predication.
3745 return $ Skip $ YieldAndContinue
3746 (Right $ unsafeChr (fromIntegral x))
3747 (FreshPointDecodeInit st)
3748 -- Using a separate state here generates a jump to a
3749 -- separate code block in the core which seems to perform
3750 -- slightly better for the non-ascii case.
3751 True -> return $ Skip $ FreshPointDecodeFirst st x
3753 -- XXX should we merge it with FreshPointDecodeInit1?
3754 step' table _ (FreshPointDecodeFirst st x) = do
3755 let (Tuple' sv cp) = decode0 table x
3759 Skip $ YieldAndContinue (Left $ DecodeError 0 (fromIntegral x))
3760 (FreshPointDecodeInit st)
3761 0 -> error "unreachable state"
3762 _ -> Skip (FreshPointDecoding st sv cp)
3764 -- We recover by trying the new byte x a starter of a new codepoint.
3765 -- XXX need to use the same recovery in array decoding routine as well
3766 step' table gst (FreshPointDecoding st statePtr codepointPtr) = do
3767 r <- step (adaptState gst) st
3770 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
3773 0 -> Skip $ YieldAndContinue (Right $ unsafeChr cp)
3774 (FreshPointDecodeInit s)
3776 Skip $ YieldAndContinue (Left $ DecodeError statePtr codepointPtr)
3777 (FreshPointDecodeInit1 s x)
3778 _ -> Skip (FreshPointDecoding s sv cp)
3779 Skip s -> return $ Skip (FreshPointDecoding s statePtr codepointPtr)
3780 Stop -> return $ Skip $ YieldAndContinue (Left $ DecodeError statePtr codepointPtr) Done
3782 step' _ _ (YieldAndContinue c s) = return $ Yield c s
3783 step' _ _ Done = return Stop
3785{-# INLINE_NORMAL decodeUtf8Either #-}
3786decodeUtf8Either :: Monad m
3787 => Stream m Word8 -> Stream m (Either DecodeError Char)
3788decodeUtf8Either = resumeDecodeUtf8Either 0 0
3790data FlattenState s a
3791 = OuterLoop s !(Maybe (DecodeState, CodePoint))
3792 | InnerLoopDecodeInit s (ForeignPtr a) !(Ptr a) !(Ptr a)
3793 | InnerLoopDecodeFirst s (ForeignPtr a) !(Ptr a) !(Ptr a) Word8
3794 | InnerLoopDecoding s (ForeignPtr a) !(Ptr a) !(Ptr a)
3795 !DecodeState !CodePoint
3796 | YAndC !Char (FlattenState s a) -- These constructors can be
3797 -- encoded in the FreshPoint
3798 -- type, I prefer to keep these
3799 -- flat even though that means
3800 -- coming up with new names
3803-- The normal decodeUtf8 above should fuse with flattenArrays
3804-- to create this exact code but it doesn't for some reason, as of now this
3805-- remains the fastest way I could figure out to decodeUtf8.
3807-- XXX Add Proper error messages
3808{-# INLINE_NORMAL decodeUtf8ArraysWith #-}
3809decodeUtf8ArraysWith ::
3811 => CodingFailureMode
3812 -> Stream m (A.Array Word8)
3814decodeUtf8ArraysWith cfm (Stream step state) =
3815 let Array p _ _ = utf8d
3816 !ptr = (unsafeForeignPtrToPtr p)
3817 in Stream (step' ptr) (OuterLoop state Nothing)
3819 {-# INLINE transliterateOrError #-}
3820 transliterateOrError e s =
3822 ErrorOnCodingFailure -> error e
3823 TransliterateCodingFailure -> YAndC replacementChar s
3824 {-# INLINE inputUnderflow #-}
3827 ErrorOnCodingFailure ->
3829 "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Input Underflow"
3830 TransliterateCodingFailure -> YAndC replacementChar D
3831 {-# INLINE_LATE step' #-}
3832 step' _ gst (OuterLoop st Nothing) = do
3833 r <- step (adaptState gst) st
3836 Yield A.Array {..} s ->
3837 let p = unsafeForeignPtrToPtr aStart
3838 in Skip (InnerLoopDecodeInit s aStart p aEnd)
3839 Skip s -> Skip (OuterLoop s Nothing)
3841 step' _ gst (OuterLoop st dst@(Just (ds, cp))) = do
3842 r <- step (adaptState gst) st
3845 Yield A.Array {..} s ->
3846 let p = unsafeForeignPtrToPtr aStart
3847 in Skip (InnerLoopDecoding s aStart p aEnd ds cp)
3848 Skip s -> Skip (OuterLoop s dst)
3849 Stop -> Skip inputUnderflow
3850 step' _ _ (InnerLoopDecodeInit st startf p end)
3852 liftIO $ touchForeignPtr startf
3853 return $ Skip $ OuterLoop st Nothing
3854 step' _ _ (InnerLoopDecodeInit st startf p end) = do
3855 x <- liftIO $ peek p
3856 -- Note: It is important to use a ">" instead of a "<=" test here for
3857 -- GHC to generate code layout for default branch prediction for the
3858 -- common case. This is fragile and might change with the compiler
3859 -- versions, we need a more reliable "likely" primitive to control
3860 -- branch predication.
3863 return $ Skip $ YAndC
3864 (unsafeChr (fromIntegral x))
3865 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
3866 -- Using a separate state here generates a jump to a separate code
3867 -- block in the core which seems to perform slightly better for the
3869 True -> return $ Skip $ InnerLoopDecodeFirst st startf p end x
3871 step' table _ (InnerLoopDecodeFirst st startf p end x) = do
3872 let (Tuple' sv cp) = decode0 table x
3877 transliterateOrError
3878 "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered"
3879 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
3880 0 -> error "unreachable state"
3881 _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)
3882 step' _ _ (InnerLoopDecoding st startf p end sv cp)
3884 liftIO $ touchForeignPtr startf
3885 return $ Skip $ OuterLoop st (Just (sv, cp))
3886 step' table _ (InnerLoopDecoding st startf p end statePtr codepointPtr) = do
3887 x <- liftIO $ peek p
3888 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
3895 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
3898 transliterateOrError
3899 "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered"
3900 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
3901 _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)
3902 step' _ _ (YAndC c s) = return $ Yield c s
3903 step' _ _ D = return Stop
3905{-# INLINE decodeUtf8Arrays #-}
3908 => Stream m (A.Array Word8)
3910decodeUtf8Arrays = decodeUtf8ArraysWith ErrorOnCodingFailure
3912{-# INLINE decodeUtf8ArraysLenient #-}
3913decodeUtf8ArraysLenient ::
3915 => Stream m (A.Array Word8)
3917decodeUtf8ArraysLenient = decodeUtf8ArraysWith TransliterateCodingFailure
3919data WList = WCons !Word8 !WList | WNil
3921data EncodeState s = EncodeState s !WList
3923-- More yield points improve performance, but I am not sure if they can cause
3924-- too much code bloat or some trouble with fusion. So keeping only two yield
3925-- points for now, one for the ascii chars (fast path) and one for all other
3926-- paths (slow path).
3927{-# INLINE_NORMAL encodeUtf8 #-}
3928encodeUtf8 :: Monad m => Stream m Char -> Stream m Word8
3929encodeUtf8 (Stream step state) = Stream step' (EncodeState state WNil)
3931 {-# INLINE_LATE step' #-}
3932 step' gst (EncodeState st WNil) = do
3933 r <- step (adaptState gst) st
3940 Yield (fromIntegral x) (EncodeState s WNil)
3941 | x <= 0x7FF -> Skip (EncodeState s (ord2 c))
3945 "Streamly.Streams.StreamD.encodeUtf8: Encountered a surrogate"
3946 else Skip (EncodeState s (ord3 c))
3947 | otherwise -> Skip (EncodeState s (ord4 c))
3948 Skip s -> Skip (EncodeState s WNil)
3950 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