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
186 -- | Transform a stream into another type.
203 -- ** By folding (scans)
269 -- * Transformation comprehensions
281 -- * UTF8 Encoding / Decoding transformations.
289 , resumeDecodeUtf8Either
291 , decodeUtf8ArraysLenient
295import Control.Exception (Exception, SomeException)
296import Control.Monad (void)
297import Control.Monad.Catch (MonadCatch)
298import Control.Monad.IO.Class (MonadIO(..))
299import Control.Monad.Reader (ReaderT)
300import Control.Monad.State.Strict (StateT)
301import Control.Monad.Trans (MonadTrans(lift))
302import Data.Bits (shiftR, shiftL, (.|.), (.&.))
303import Data.Functor.Identity (Identity(..))
304import Data.Maybe (fromJust, isJust)
305import Data.Word (Word32)
306import Foreign.Ptr (Ptr)
307import Foreign.Storable (Storable(..))
308import GHC.Base (assert, Char(..), unsafeChr, ord)
309import GHC.IO.Encoding.Failure (isSurrogate)
310import GHC.ForeignPtr (ForeignPtr (..))
311import GHC.Ptr (Ptr (..))
312import GHC.Types (SPEC(..))
313import GHC.Word (Word8(..))
314import System.IO.Unsafe (unsafePerformIO)
316 hiding (map, mapM, mapM_, repeat, foldr, last, take, filter,
317 takeWhile, drop, dropWhile, all, any, maximum, minimum, elem,
318 notElem, null, head, tail, zipWith, lookup, foldr1, sequence,
319 (!!), scanl, scanl1, concatMap, replicate, enumFromTo, concat,
322import qualified Control.Monad.Catch as MC
323import qualified Control.Monad.Reader as Reader
324import qualified Control.Monad.State.Strict as State
326import Streamly.Internal.Memory.Array.Types (Array(..))
327import Streamly.Internal.Data.Fold.Types (Fold(..))
328import Streamly.Internal.Data.Pipe.Types (Pipe(..), PipeState(..))
329import Streamly.Internal.Data.SVar (MonadAsync, defState, adaptState)
330import Streamly.Internal.Data.Unfold.Types (Unfold(..))
331import Streamly.Internal.Data.Strict (Tuple'(..))
333import Streamly.Internal.Data.Stream.StreamD.Type
335import qualified Streamly.Internal.Data.Pipe.Types as Pipe
336import qualified Streamly.Internal.Memory.Array.Types as A
337import qualified Streamly.Memory.Ring as RB
338import qualified Streamly.Streams.StreamK as K
340import Foreign.Ptr (plusPtr)
341import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
342import Foreign.ForeignPtr (touchForeignPtr)
344------------------------------------------------------------------------------
346------------------------------------------------------------------------------
348-- | An empty 'Stream'.
349{-# INLINE_NORMAL nil #-}
350nil :: Monad m => Stream m a
351nil = Stream (\_ _ -> return Stop) ()
353-- | An empty 'Stream' with a side effect.
354{-# INLINE_NORMAL nilM #-}
355nilM :: Monad m => m b -> Stream m a
356nilM m = Stream (\_ _ -> m >> return Stop) ()
358{-# INLINE_NORMAL consM #-}
359consM :: Monad m => m a -> Stream m a -> Stream m a
360consM m (Stream step state) = Stream step1 Nothing
362 {-# INLINE_LATE step1 #-}
363 step1 _ Nothing = m >>= \x -> return $ Yield x (Just state)
364 step1 gst (Just st) = do
368 Yield a s -> Yield a (Just s)
369 Skip s -> Skip (Just s)
372-- XXX implement in terms of consM?
373-- cons x = consM (return x)
375-- | Can fuse but has O(n^2) complexity.
376{-# INLINE_NORMAL cons #-}
377cons :: Monad m => a -> Stream m a -> Stream m a
378cons x (Stream step state) = Stream step1 Nothing
380 {-# INLINE_LATE step1 #-}
381 step1 _ Nothing = return $ Yield x (Just state)
382 step1 gst (Just st) = do
386 Yield a s -> Yield a (Just s)
387 Skip s -> Skip (Just s)
390-------------------------------------------------------------------------------
392-------------------------------------------------------------------------------
394-- Does not fuse, has the same performance as the StreamK version.
395{-# INLINE_NORMAL uncons #-}
396uncons :: Monad m => Stream m a -> m (Maybe (a, Stream m a))
397uncons (UnStream step state) = go state
400 r <- step defState st
402 Yield x s -> return $ Just (x, Stream step s)
404 Stop -> return Nothing
406------------------------------------------------------------------------------
407-- Generation by unfold
408------------------------------------------------------------------------------
410{-# INLINE_NORMAL unfoldrM #-}
411unfoldrM :: Monad m => (s -> m (Maybe (a, s))) -> s -> Stream m a
412unfoldrM next state = Stream step state
414 {-# INLINE_LATE step #-}
418 Just (x, s) -> Yield x s
421{-# INLINE_LATE unfoldr #-}
422unfoldr :: Monad m => (s -> Maybe (a, s)) -> s -> Stream m a
423unfoldr f = unfoldrM (return . f)
425-- | Convert an 'Unfold' into a 'Stream' by supplying it a seed.
427{-# INLINE_NORMAL unfold #-}
428unfold :: Monad m => Unfold m a b -> a -> Stream m b
429unfold (Unfold ustep inject) seed = Stream step Nothing
431 {-# INLINE_LATE step #-}
432 step _ Nothing = inject seed >>= return . Skip . Just
433 step _ (Just st) = do
436 Yield x s -> Yield x (Just s)
437 Skip s -> Skip (Just s)
440------------------------------------------------------------------------------
441-- Specialized Generation
442------------------------------------------------------------------------------
444repeatM :: Monad m => m a -> Stream m a
445repeatM x = Stream (\_ _ -> x >>= \r -> return $ Yield r ()) ()
447repeat :: Monad m => a -> Stream m a
448repeat x = Stream (\_ _ -> return $ Yield x ()) ()
450{-# INLINE_NORMAL replicateM #-}
451replicateM :: forall m a. Monad m => Int -> m a -> Stream m a
452replicateM n p = Stream step n
454 {-# INLINE_LATE step #-}
456 | i <= 0 = return Stop
459 return $ Yield x (i - 1)
461{-# INLINE_NORMAL replicate #-}
462replicate :: Monad m => Int -> a -> Stream m a
463replicate n x = replicateM n (return x)
465-- This would not work properly for floats, therefore we put an Integral
467-- | Can be used to enumerate unbounded integrals. This does not check for
468-- overflow or underflow for bounded integrals.
469{-# INLINE_NORMAL enumerateFromStepIntegral #-}
470enumerateFromStepIntegral :: (Integral a, Monad m) => a -> a -> Stream m a
471enumerateFromStepIntegral from stride =
472 from `seq` stride `seq` Stream step from
474 {-# INLINE_LATE step #-}
475 step _ !x = return $ Yield x $! (x + stride)
477-- We are assuming that "to" is constrained by the type to be within
479{-# INLINE enumerateFromToIntegral #-}
480enumerateFromToIntegral :: (Monad m, Integral a) => a -> a -> Stream m a
481enumerateFromToIntegral from to =
482 takeWhile (<= to) $ enumerateFromStepIntegral from 1
484{-# INLINE enumerateFromIntegral #-}
485enumerateFromIntegral :: (Monad m, Integral a, Bounded a) => a -> Stream m a
486enumerateFromIntegral from = enumerateFromToIntegral from maxBound
488data EnumState a = EnumInit | EnumYield a a a | EnumStop
490{-# INLINE_NORMAL enumerateFromThenToIntegralUp #-}
491enumerateFromThenToIntegralUp
492 :: (Monad m, Integral a)
493 => a -> a -> a -> Stream m a
494enumerateFromThenToIntegralUp from next to = Stream step EnumInit
496 {-# INLINE_LATE step #-}
502 else Yield from EnumStop
503 else -- from <= next <= to
504 let stride = next - from
505 in Skip $ EnumYield from stride (to - stride)
507 step _ (EnumYield x stride toMinus) =
510 then Yield x EnumStop
511 else Yield x $ EnumYield (x + stride) stride toMinus
513 step _ EnumStop = return Stop
515{-# INLINE_NORMAL enumerateFromThenToIntegralDn #-}
516enumerateFromThenToIntegralDn
517 :: (Monad m, Integral a)
518 => a -> a -> a -> Stream m a
519enumerateFromThenToIntegralDn from next to = Stream step EnumInit
521 {-# INLINE_LATE step #-}
523 return $ if to > next
526 else Yield from EnumStop
527 else -- from >= next >= to
528 let stride = next - from
529 in Skip $ EnumYield from stride (to - stride)
531 step _ (EnumYield x stride toMinus) =
534 then Yield x EnumStop
535 else Yield x $ EnumYield (x + stride) stride toMinus
537 step _ EnumStop = return Stop
539{-# INLINE_NORMAL enumerateFromThenToIntegral #-}
540enumerateFromThenToIntegral
541 :: (Monad m, Integral a)
542 => a -> a -> a -> Stream m a
543enumerateFromThenToIntegral from next to
544 | next >= from = enumerateFromThenToIntegralUp from next to
545 | otherwise = enumerateFromThenToIntegralDn from next to
547{-# INLINE_NORMAL enumerateFromThenIntegral #-}
548enumerateFromThenIntegral
549 :: (Monad m, Integral a, Bounded a)
550 => a -> a -> Stream m a
551enumerateFromThenIntegral from next =
553 then enumerateFromThenToIntegralUp from next maxBound
554 else enumerateFromThenToIntegralDn from next minBound
556-- For floating point numbers if the increment is less than the precision then
557-- it just gets lost. Therefore we cannot always increment it correctly by just
559-- 9007199254740992 + 1 + 1 :: Double => 9.007199254740992e15
560-- 9007199254740992 + 2 :: Double => 9.007199254740994e15
562-- Instead we accumulate the increment counter and compute the increment
563-- everytime before adding it to the starting number.
565-- This works for Integrals as well as floating point numbers, but
566-- enumerateFromStepIntegral is faster for integrals.
567{-# INLINE_NORMAL enumerateFromStepNum #-}
568enumerateFromStepNum :: (Monad m, Num a) => a -> a -> Stream m a
569enumerateFromStepNum from stride = Stream step 0
571 {-# INLINE_LATE step #-}
572 step _ !i = return $ (Yield $! (from + i * stride)) $! (i + 1)
574{-# INLINE_NORMAL numFrom #-}
575numFrom :: (Monad m, Num a) => a -> Stream m a
576numFrom from = enumerateFromStepNum from 1
578{-# INLINE_NORMAL numFromThen #-}
579numFromThen :: (Monad m, Num a) => a -> a -> Stream m a
580numFromThen from next = enumerateFromStepNum from (next - from)
582-- We cannot write a general function for Num. The only way to write code
583-- portable between the two is to use a 'Real' constraint and convert between
584-- Fractional and Integral using fromRational which is horribly slow.
585{-# INLINE_NORMAL enumerateFromToFractional #-}
586enumerateFromToFractional
587 :: (Monad m, Fractional a, Ord a)
588 => a -> a -> Stream m a
589enumerateFromToFractional from to =
590 takeWhile (<= to + 1 / 2) $ enumerateFromStepNum from 1
592{-# INLINE_NORMAL enumerateFromThenToFractional #-}
593enumerateFromThenToFractional
594 :: (Monad m, Fractional a, Ord a)
595 => a -> a -> a -> Stream m a
596enumerateFromThenToFractional from next to =
597 takeWhile predicate $ numFromThen from next
599 mid = (next - from) / 2
600 predicate | next >= from = (<= to + mid)
601 | otherwise = (>= to + mid)
603-------------------------------------------------------------------------------
604-- Generation by Conversion
605-------------------------------------------------------------------------------
607{-# INLINE_NORMAL fromIndicesM #-}
608fromIndicesM :: Monad m => (Int -> m a) -> Stream m a
609fromIndicesM gen = Stream step 0
611 {-# INLINE_LATE step #-}
614 return $ Yield x (i + 1)
616{-# INLINE fromIndices #-}
617fromIndices :: Monad m => (Int -> a) -> Stream m a
618fromIndices gen = fromIndicesM (return . gen)
620{-# INLINE_NORMAL generateM #-}
621generateM :: Monad m => Int -> (Int -> m a) -> Stream m a
622generateM n gen = n `seq` Stream step 0
624 {-# INLINE_LATE step #-}
625 step _ i | i < n = do
627 return $ Yield x (i + 1)
628 | otherwise = return Stop
630{-# INLINE generate #-}
631generate :: Monad m => Int -> (Int -> a) -> Stream m a
632generate n gen = generateM n (return . gen)
634-- XXX we need the MonadAsync constraint because of a rewrite rule.
635-- | Convert a list of monadic actions to a 'Stream'
636{-# INLINE_LATE fromListM #-}
637fromListM :: MonadAsync m => [m a] -> Stream m a
638fromListM = Stream step
640 {-# INLINE_LATE step #-}
641 step _ (m:ms) = m >>= \x -> return $ Yield x ms
642 step _ [] = return Stop
644{-# INLINE toStreamD #-}
645toStreamD :: (K.IsStream t, Monad m) => t m a -> Stream m a
646toStreamD = fromStreamK . K.toStream
648{-# INLINE_NORMAL hoist #-}
649hoist :: Monad n => (forall x. m x -> n x) -> Stream m a -> Stream n a
650hoist f (Stream step state) = (Stream step' state)
653 r <- f $ step (adaptState gst) st
655 Yield x s -> Yield x s
659{-# INLINE_NORMAL generally #-}
660generally :: Monad m => Stream Identity a -> Stream m a
661generally = hoist (return . runIdentity)
663{-# INLINE_NORMAL liftInner #-}
664liftInner :: (Monad m, MonadTrans t, Monad (t m))
665 => Stream m a -> Stream (t m) a
666liftInner (Stream step state) = Stream step' state
669 r <- lift $ step (adaptState gst) st
671 Yield x s -> Yield x s
675{-# INLINE_NORMAL runReaderT #-}
676runReaderT :: Monad m => s -> Stream (ReaderT s m) a -> Stream m a
677runReaderT sval (Stream step state) = Stream step' state
680 r <- Reader.runReaderT (step (adaptState gst) st) sval
682 Yield x s -> Yield x s
686{-# INLINE_NORMAL evalStateT #-}
687evalStateT :: Monad m => s -> Stream (StateT s m) a -> Stream m a
688evalStateT sval (Stream step state) = Stream step' (state, sval)
690 step' gst (st, sv) = do
691 (r, sv') <- State.runStateT (step (adaptState gst) st) sv
693 Yield x s -> Yield x (s, sv')
694 Skip s -> Skip (s, sv')
697{-# INLINE_NORMAL runStateT #-}
698runStateT :: Monad m => s -> Stream (StateT s m) a -> Stream m (s, a)
699runStateT sval (Stream step state) = Stream step' (state, sval)
701 step' gst (st, sv) = do
702 (r, sv') <- State.runStateT (step (adaptState gst) st) sv
704 Yield x s -> Yield (sv', x) (s, sv')
705 Skip s -> Skip (s, sv')
708------------------------------------------------------------------------------
709-- Elimination by Folds
710------------------------------------------------------------------------------
712------------------------------------------------------------------------------
714------------------------------------------------------------------------------
716{-# INLINE_NORMAL foldr1 #-}
717foldr1 :: Monad m => (a -> a -> a) -> Stream m a -> m (Maybe a)
721 Nothing -> return Nothing
722 Just (h, t) -> fmap Just (foldr f h t)
724------------------------------------------------------------------------------
726------------------------------------------------------------------------------
728{-# INLINE_NORMAL foldlT #-}
729foldlT :: (Monad m, Monad (s m), MonadTrans s)
730 => (s m b -> a -> s m b) -> s m b -> Stream m a -> s m b
731foldlT fstep begin (Stream step state) = go SPEC begin state
734 r <- lift $ step defState st
736 Yield x s -> go SPEC (fstep acc x) s
737 Skip s -> go SPEC acc s
740-- Note, this is going to have horrible performance, because of the nature of
741-- the stream type (i.e. direct stream vs CPS). Its only for reference, it is
742-- likely be practically unusable.
743{-# INLINE_NORMAL foldlS #-}
745 => (Stream m b -> a -> Stream m b) -> Stream m b -> Stream m a -> Stream m b
746foldlS fstep begin (Stream step state) = Stream step' (Left (state, begin))
748 step' gst (Left (st, acc)) = do
749 r <- step (adaptState gst) st
751 Yield x s -> Skip (Left (s, fstep acc x))
752 Skip s -> Skip (Left (s, acc))
753 Stop -> Skip (Right acc)
755 step' gst (Right (Stream stp stt)) = do
756 r <- stp (adaptState gst) stt
758 Yield x s -> Yield x (Right (Stream stp s))
759 Skip s -> Skip (Right (Stream stp s))
762------------------------------------------------------------------------------
764------------------------------------------------------------------------------
766-- | Run a streaming composition, discard the results.
767{-# INLINE_LATE drain #-}
768drain :: Monad m => Stream m a -> m ()
769-- drain = foldrM (\_ xs -> xs) (return ())
770drain (Stream step state) = go SPEC state
773 r <- step defState st
775 Yield _ s -> go SPEC s
779{-# INLINE_NORMAL null #-}
780null :: Monad m => Stream m a -> m Bool
781null m = foldrM (\_ _ -> return False) (return True) m
783{-# INLINE_NORMAL head #-}
784head :: Monad m => Stream m a -> m (Maybe a)
785head m = foldrM (\x _ -> return (Just x)) (return Nothing) m
787-- Does not fuse, has the same performance as the StreamK version.
788{-# INLINE_NORMAL tail #-}
789tail :: Monad m => Stream m a -> m (Maybe (Stream m a))
790tail (UnStream step state) = go state
793 r <- step defState st
795 Yield _ s -> return (Just $ Stream step s)
797 Stop -> return Nothing
799-- XXX will it fuse? need custom impl?
800{-# INLINE_NORMAL last #-}
801last :: Monad m => Stream m a -> m (Maybe a)
802last = foldl' (\_ y -> Just y) Nothing
804{-# INLINE_NORMAL elem #-}
805elem :: (Monad m, Eq a) => a -> Stream m a -> m Bool
806-- elem e m = foldrM (\x xs -> if x == e then return True else xs) (return False) m
807elem e (Stream step state) = go state
810 r <- step defState st
813 | x == e -> return True
818{-# INLINE_NORMAL notElem #-}
819notElem :: (Monad m, Eq a) => a -> Stream m a -> m Bool
820notElem e s = fmap not (elem e s)
822{-# INLINE_NORMAL all #-}
823all :: Monad m => (a -> Bool) -> Stream m a -> m Bool
824-- all p m = foldrM (\x xs -> if p x then xs else return False) (return True) m
825all p (Stream step state) = go state
828 r <- step defState st
832 | otherwise -> return False
836{-# INLINE_NORMAL any #-}
837any :: Monad m => (a -> Bool) -> Stream m a -> m Bool
838-- any p m = foldrM (\x xs -> if p x then return True else xs) (return False) m
839any p (Stream step state) = go state
842 r <- step defState st
850{-# INLINE_NORMAL maximum #-}
851maximum :: (Monad m, Ord a) => Stream m a -> m (Maybe a)
852maximum (Stream step state) = go Nothing state
855 r <- step defState st
857 Yield x s -> go (Just x) s
858 Skip s -> go Nothing s
859 Stop -> return Nothing
860 go (Just acc) st = do
861 r <- step defState st
864 | acc <= x -> go (Just x) s
865 | otherwise -> go (Just acc) s
866 Skip s -> go (Just acc) s
867 Stop -> return (Just acc)
869{-# INLINE_NORMAL maximumBy #-}
870maximumBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> m (Maybe a)
871maximumBy cmp (Stream step state) = go Nothing state
874 r <- step defState st
876 Yield x s -> go (Just x) s
877 Skip s -> go Nothing s
878 Stop -> return Nothing
879 go (Just acc) st = do
880 r <- step defState st
882 Yield x s -> case cmp acc x of
883 GT -> go (Just acc) s
885 Skip s -> go (Just acc) s
886 Stop -> return (Just acc)
888{-# INLINE_NORMAL minimum #-}
889minimum :: (Monad m, Ord a) => Stream m a -> m (Maybe a)
890minimum (Stream step state) = go Nothing state
893 r <- step defState st
895 Yield x s -> go (Just x) s
896 Skip s -> go Nothing s
897 Stop -> return Nothing
898 go (Just acc) st = do
899 r <- step defState st
902 | acc <= x -> go (Just acc) s
903 | otherwise -> go (Just x) s
904 Skip s -> go (Just acc) s
905 Stop -> return (Just acc)
907{-# INLINE_NORMAL minimumBy #-}
908minimumBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> m (Maybe a)
909minimumBy cmp (Stream step state) = go Nothing state
912 r <- step defState st
914 Yield x s -> go (Just x) s
915 Skip s -> go Nothing s
916 Stop -> return Nothing
917 go (Just acc) st = do
918 r <- step defState st
920 Yield x s -> case cmp acc x of
923 Skip s -> go (Just acc) s
924 Stop -> return (Just acc)
926{-# INLINE_NORMAL (!!) #-}
927(!!) :: (Monad m) => Stream m a -> Int -> m (Maybe a)
928(Stream step state) !! i = go i state
931 r <- step defState st
933 Yield x s | n < 0 -> return Nothing
934 | n == 0 -> return $ Just x
935 | otherwise -> go (n - 1) s
937 Stop -> return Nothing
939{-# INLINE_NORMAL lookup #-}
940lookup :: (Monad m, Eq a) => a -> Stream m (a, b) -> m (Maybe b)
941lookup e m = foldrM (\(a, b) xs -> if e == a then return (Just b) else xs)
944{-# INLINE_NORMAL findM #-}
945findM :: Monad m => (a -> m Bool) -> Stream m a -> m (Maybe a)
946findM p m = foldrM (\x xs -> p x >>= \r -> if r then return (Just x) else xs)
950find :: Monad m => (a -> Bool) -> Stream m a -> m (Maybe a)
951find p = findM (return . p)
953{-# INLINE_NORMAL findIndices #-}
954findIndices :: Monad m => (a -> Bool) -> Stream m a -> Stream m Int
955findIndices p (Stream step state) = Stream step' (state, 0)
957 {-# INLINE_LATE step' #-}
958 step' gst (st, i) = do
959 r <- step (adaptState gst) st
961 Yield x s -> if p x then Yield i (s, i+1) else Skip (s, i+1)
962 Skip s -> Skip (s, i+1)
965{-# INLINE toListRev #-}
966toListRev :: Monad m => Stream m a -> m [a]
967toListRev = foldl' (flip (:)) []
969-- We can implement reverse as:
971-- > reverse = foldlS (flip cons) nil
973-- However, this implementation is unusable because of the horrible performance
974-- of cons. So we just convert it to a list first and then stream from the
977-- XXX Maybe we can use an Array instead of a list here?
978{-# INLINE_NORMAL reverse #-}
979reverse :: Monad m => Stream m a -> Stream m a
980reverse m = Stream step Nothing
982 {-# INLINE_LATE step #-}
985 return $ Skip (Just xs)
986 step _ (Just (x:xs)) = return $ Yield x (Just xs)
987 step _ (Just []) = return Stop
989-- Much faster reverse for Storables
990{-# INLINE_NORMAL reverse' #-}
991reverse' :: forall m a. (MonadIO m, Storable a) => Stream m a -> Stream m a
993-- This commented implementation copies the whole stream into one single array
994-- and then streams from that array, this is 3-4x faster than the chunked code
995-- that follows. Though this could be problematic due to unbounded large
996-- allocations. We need to figure out why the chunked code is slower and if we
997-- can optimize the chunked code to work as fast as this one. It may be a
999import Foreign.ForeignPtr (touchForeignPtr)
1000import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
1001import Foreign.Ptr (Ptr, plusPtr)
1002reverse' m = Stream step Nothing
1004 {-# INLINE_LATE step #-}
1006 arr <- A.fromStreamD m
1007 let p = aEnd arr `plusPtr` negate (sizeOf (undefined :: a))
1008 return $ Skip $ Just (aStart arr, p)
1010 step _ (Just (start, p)) | p < unsafeForeignPtrToPtr start = return Stop
1012 step _ (Just (start, p)) = do
1013 let !x = A.unsafeInlineIO $ do
1015 touchForeignPtr start
1017 next = p `plusPtr` negate (sizeOf (undefined :: a))
1018 return $ Yield x (Just (start, next))
1025 $ A.fromStreamDArraysOf A.defaultChunkSize m
1028------------------------------------------------------------------------------
1029-- Grouping/Splitting
1030------------------------------------------------------------------------------
1032{-# INLINE_NORMAL splitSuffixBy' #-}
1033splitSuffixBy' :: Monad m
1034 => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
1035splitSuffixBy' predicate f (Stream step state) =
1036 Stream (stepOuter f) (Just state)
1040 {-# INLINE_LATE stepOuter #-}
1041 stepOuter (Fold fstep initial done) gst (Just st) = do
1042 res <- step (adaptState gst) st
1048 then done acc' >>= \val -> return $ Yield val (Just s)
1051 Skip s -> return $ Skip $ Just s
1057 res <- step (adaptState gst) stt
1062 then done acc' >>= \val -> return $ Yield val (Just s)
1064 Skip s -> go SPEC s acc
1065 Stop -> done acc >>= \val -> return $ Yield val Nothing
1067 stepOuter _ _ Nothing = return Stop
1069{-# INLINE_NORMAL groupsBy #-}
1075groupsBy cmp f (Stream step state) = Stream (stepOuter f) (Just state, Nothing)
1079 {-# INLINE_LATE stepOuter #-}
1080 stepOuter (Fold fstep initial done) gst (Just st, Nothing) = do
1081 res <- step (adaptState gst) st
1088 Skip s -> return $ Skip $ (Just s, Nothing)
1093 go !_ prev stt !acc = do
1094 res <- step (adaptState gst) stt
1101 else done acc >>= \r -> return $ Yield r (Just s, Just x)
1102 Skip s -> go SPEC prev s acc
1103 Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1105 stepOuter (Fold fstep initial done) gst (Just st, Just prev) = do
1107 acc' <- fstep acc prev
1112 -- XXX code duplicated from the previous equation
1114 res <- step (adaptState gst) stt
1121 else done acc >>= \r -> return $ Yield r (Just s, Just x)
1122 Skip s -> go SPEC s acc
1123 Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1125 stepOuter _ _ (Nothing,_) = return Stop
1127{-# INLINE_NORMAL groupsRollingBy #-}
1128groupsRollingBy :: Monad m
1133groupsRollingBy cmp f (Stream step state) =
1134 Stream (stepOuter f) (Just state, Nothing)
1137 {-# INLINE_LATE stepOuter #-}
1138 stepOuter (Fold fstep initial done) gst (Just st, Nothing) = do
1139 res <- step (adaptState gst) st
1146 Skip s -> return $ Skip $ (Just s, Nothing)
1150 go !_ prev stt !acc = do
1151 res <- step (adaptState gst) stt
1159 done acc >>= \r -> return $ Yield r (Just s, Just x)
1160 Skip s -> go SPEC prev s acc
1161 Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1163 stepOuter (Fold fstep initial done) gst (Just st, Just prev') = do
1165 acc' <- fstep acc prev'
1166 go SPEC prev' st acc'
1169 go !_ prevv stt !acc = do
1170 res <- step (adaptState gst) stt
1177 else done acc >>= \r -> return $ Yield r (Just s, Just x)
1178 Skip s -> go SPEC prevv s acc
1179 Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1181 stepOuter _ _ (Nothing, _) = return Stop
1183{-# INLINE_NORMAL splitBy #-}
1184splitBy :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
1185splitBy predicate f (Stream step state) = Stream (step' f) (Just state)
1189 {-# INLINE_LATE step' #-}
1190 step' (Fold fstep initial done) gst (Just st) = initial >>= go SPEC st
1195 res <- step (adaptState gst) stt
1199 then done acc >>= \r -> return $ Yield r (Just s)
1203 Skip s -> go SPEC s acc
1204 Stop -> done acc >>= \r -> return $ Yield r Nothing
1206 step' _ _ Nothing = return Stop
1208-- XXX requires -funfolding-use-threshold=150 in lines-unlines benchmark
1209{-# INLINE_NORMAL splitSuffixBy #-}
1210splitSuffixBy :: Monad m
1211 => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
1212splitSuffixBy predicate f (Stream step state) = Stream (step' f) (Just state)
1216 {-# INLINE_LATE step' #-}
1217 step' (Fold fstep initial done) gst (Just st) = do
1218 res <- step (adaptState gst) st
1223 then done acc >>= \val -> return $ Yield val (Just s)
1228 Skip s -> return $ Skip $ Just s
1234 res <- step (adaptState gst) stt
1238 then done acc >>= \r -> return $ Yield r (Just s)
1242 Skip s -> go SPEC s acc
1243 Stop -> done acc >>= \r -> return $ Yield r Nothing
1245 step' _ _ Nothing = return Stop
1247{-# INLINE_NORMAL wordsBy #-}
1248wordsBy :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
1249wordsBy predicate f (Stream step state) = Stream (stepOuter f) (Just state)
1253 {-# INLINE_LATE stepOuter #-}
1254 stepOuter (Fold fstep initial done) gst (Just st) = do
1255 res <- step (adaptState gst) st
1259 then return $ Skip (Just s)
1265 Skip s -> return $ Skip $ Just s
1271 res <- step (adaptState gst) stt
1275 then done acc >>= \r -> return $ Yield r (Just s)
1279 Skip s -> go SPEC s acc
1280 Stop -> done acc >>= \r -> return $ Yield r Nothing
1282 stepOuter _ _ Nothing = return Stop
1284-- String search algorithms:
1285-- http://www-igm.univ-mlv.fr/~lecroq/string/index.html
1288-- TODO can we unify the splitting operations using a splitting configuration
1289-- like in the split package.
1291data SplitStyle = Infix | Suffix | Prefix deriving (Eq, Show)
1293data SplitOptions = SplitOptions
1294 { style :: SplitStyle
1295 , withSep :: Bool -- ^ keep the separators in output
1296 -- , compact :: Bool -- ^ treat multiple consecutive separators as one
1297 -- , trimHead :: Bool -- ^ drop blank at head
1298 -- , trimTail :: Bool -- ^ drop blank at tail
1302data SplitOnState s a =
1307 | GO_KARP_RABIN s !(RB.Ring a) !(Ptr a)
1310{-# INLINE_NORMAL splitOn #-}
1312 :: forall m a b. (MonadIO m, Storable a, Enum a, Eq a)
1317splitOn patArr@Array{..} (Fold fstep initial done) (Stream step state) =
1318 Stream stepOuter GO_START
1322 patLen = A.length patArr
1323 maxIndex = patLen - 1
1324 elemBits = sizeOf (undefined :: a) * 8
1326 {-# INLINE_LATE stepOuter #-}
1327 stepOuter _ GO_START =
1329 then return $ Skip $ GO_EMPTY_PAT state
1332 r <- liftIO $ (A.unsafeIndexIO patArr 0)
1333 return $ Skip $ GO_SINGLE_PAT state r
1334 else if sizeOf (undefined :: a) * patLen
1335 <= sizeOf (undefined :: Word)
1336 then return $ Skip $ GO_SHORT_PAT state
1338 (rb, rhead) <- liftIO $ RB.new patLen
1339 return $ Skip $ GO_KARP_RABIN state rb rhead
1341 stepOuter gst (GO_SINGLE_PAT stt pat) = initial >>= go SPEC stt
1346 res <- step (adaptState gst) st
1352 return $ Yield r (GO_SINGLE_PAT s pat)
1353 else fstep acc x >>= go SPEC s
1354 Skip s -> go SPEC s acc
1355 Stop -> done acc >>= \r -> return $ Yield r GO_DONE
1357 stepOuter gst (GO_SHORT_PAT stt) = initial >>= go0 SPEC 0 (0 :: Word) stt
1362 mask = (1 `shiftL` (elemBits * patLen)) - 1
1364 addToWord wrd a = (wrd `shiftL` elemBits) .|. fromIntegral (fromEnum a)
1367 patWord = mask .&. A.foldl' addToWord 0 patArr
1369 go0 !_ !idx wrd st !acc = do
1370 res <- step (adaptState gst) st
1373 let wrd' = addToWord wrd x
1376 if wrd' .&. mask == patWord
1379 return $ Yield r (GO_SHORT_PAT s)
1380 else go1 SPEC wrd' s acc
1381 else go0 SPEC (idx + 1) wrd' s acc
1382 Skip s -> go0 SPEC idx wrd s acc
1385 then go2 wrd idx acc
1387 done acc' >>= \r -> return $ Yield r GO_DONE
1390 go1 !_ wrd st !acc = do
1391 res <- step (adaptState gst) st
1394 let wrd' = addToWord wrd x
1395 old = (mask .&. wrd) `shiftR` (elemBits * (patLen - 1))
1396 acc' <- fstep acc (toEnum $ fromIntegral old)
1397 if wrd' .&. mask == patWord
1398 then done acc' >>= \r -> return $ Yield r (GO_SHORT_PAT s)
1399 else go1 SPEC wrd' s acc'
1400 Skip s -> go1 SPEC wrd s acc
1402 acc' <- go2 wrd patLen acc
1403 done acc' >>= \r -> return $ Yield r GO_DONE
1405 go2 !wrd !n !acc | n > 0 = do
1406 let old = (mask .&. wrd) `shiftR` (elemBits * (n - 1))
1407 fstep acc (toEnum $ fromIntegral old) >>= go2 wrd (n - 1)
1408 go2 _ _ acc = return acc
1410 stepOuter gst (GO_KARP_RABIN stt rb rhead) = do
1411 initial >>= go0 SPEC 0 rhead stt
1415 k = 2891336453 :: Word32
1417 addCksum cksum a = cksum * k + fromIntegral (fromEnum a)
1418 deltaCksum cksum old new =
1419 addCksum cksum new - coeff * fromIntegral (fromEnum old)
1421 -- XXX shall we use a random starting hash or 1 instead of 0?
1422 patHash = A.foldl' addCksum 0 patArr
1425 go0 !_ !idx !rh st !acc = do
1426 res <- step (adaptState gst) st
1429 rh' <- liftIO $ RB.unsafeInsert rb rh x
1432 let fold = RB.unsafeFoldRing (RB.ringBound rb)
1433 let !ringHash = fold addCksum 0 rb
1434 if ringHash == patHash
1435 then go2 SPEC ringHash rh' s acc
1436 else go1 SPEC ringHash rh' s acc
1437 else go0 SPEC (idx + 1) rh' s acc
1438 Skip s -> go0 SPEC idx rh s acc
1440 !acc' <- if idx /= 0
1441 then RB.unsafeFoldRingM rh fstep acc rb
1443 done acc' >>= \r -> return $ Yield r GO_DONE
1445 -- XXX Theoretically this code can do 4 times faster if GHC generates
1446 -- optimal code. If we use just "(cksum' == patHash)" condition it goes
1447 -- 4x faster, as soon as we add the "RB.unsafeEqArray rb v" condition
1448 -- the generated code changes drastically and becomes 4x slower. Need
1449 -- to investigate what is going on with GHC.
1451 go1 !_ !cksum !rh st !acc = do
1452 res <- step (adaptState gst) st
1455 old <- liftIO $ peek rh
1456 let cksum' = deltaCksum cksum old x
1457 acc' <- fstep acc old
1459 if (cksum' == patHash)
1461 rh' <- liftIO (RB.unsafeInsert rb rh x)
1462 go2 SPEC cksum' rh' s acc'
1464 rh' <- liftIO (RB.unsafeInsert rb rh x)
1465 go1 SPEC cksum' rh' s acc'
1466 Skip s -> go1 SPEC cksum rh s acc
1468 acc' <- RB.unsafeFoldRingFullM rh fstep acc rb
1469 done acc' >>= \r -> return $ Yield r GO_DONE
1471 go2 !_ !cksum' !rh' s !acc' = do
1472 if RB.unsafeEqArray rb rh' patArr
1475 return $ Yield r (GO_KARP_RABIN s rb rhead)
1476 else go1 SPEC cksum' rh' s acc'
1478 stepOuter gst (GO_EMPTY_PAT st) = do
1479 res <- step (adaptState gst) st
1484 done acc' >>= \r -> return $ Yield r (GO_EMPTY_PAT s)
1485 Skip s -> return $ Skip (GO_EMPTY_PAT s)
1488 stepOuter _ GO_DONE = return Stop
1490{-# INLINE_NORMAL splitSuffixOn #-}
1492 :: forall m a b. (MonadIO m, Storable a, Enum a, Eq a)
1498splitSuffixOn withSep patArr@Array{..} (Fold fstep initial done)
1499 (Stream step state) =
1500 Stream stepOuter GO_START
1504 patLen = A.length patArr
1505 maxIndex = patLen - 1
1506 elemBits = sizeOf (undefined :: a) * 8
1508 {-# INLINE_LATE stepOuter #-}
1509 stepOuter _ GO_START =
1511 then return $ Skip $ GO_EMPTY_PAT state
1514 r <- liftIO $ (A.unsafeIndexIO patArr 0)
1515 return $ Skip $ GO_SINGLE_PAT state r
1516 else if sizeOf (undefined :: a) * patLen
1517 <= sizeOf (undefined :: Word)
1518 then return $ Skip $ GO_SHORT_PAT state
1520 (rb, rhead) <- liftIO $ RB.new patLen
1521 return $ Skip $ GO_KARP_RABIN state rb rhead
1523 stepOuter gst (GO_SINGLE_PAT stt pat) = do
1524 -- This first part is the only difference between splitOn and
1526 -- If the last element is a separator do not issue a blank segment.
1527 res <- step (adaptState gst) stt
1533 acc' <- if withSep then fstep acc x else return acc
1534 done acc' >>= \r -> return $ Yield r (GO_SINGLE_PAT s pat)
1535 else fstep acc x >>= go SPEC s
1536 Skip s -> return $ Skip $ (GO_SINGLE_PAT s pat)
1541 -- This is identical for splitOn and splitSuffixOn
1543 res <- step (adaptState gst) st
1548 acc' <- if withSep then fstep acc x else return acc
1550 return $ Yield r (GO_SINGLE_PAT s pat)
1551 else fstep acc x >>= go SPEC s
1552 Skip s -> go SPEC s acc
1553 Stop -> done acc >>= \r -> return $ Yield r GO_DONE
1555 stepOuter gst (GO_SHORT_PAT stt) = do
1557 -- Call "initial" only if the stream yields an element, otherwise we
1558 -- may call "initial" but never yield anything. initial may produce a
1559 -- side effect, therefore we will end up doing and discard a side
1564 res <- step (adaptState gst) stt
1568 let wrd' = addToWord wrd x
1569 acc' <- if withSep then fstep acc x else return acc
1572 if wrd' .&. mask == patWord
1573 then done acc' >>= \r -> return $ Yield r (GO_SHORT_PAT s)
1574 else go0 SPEC (idx + 1) wrd' s acc'
1575 else go0 SPEC (idx + 1) wrd' s acc'
1576 Skip s -> return $ Skip (GO_SHORT_PAT s)
1582 mask = (1 `shiftL` (elemBits * patLen)) - 1
1584 addToWord wrd a = (wrd `shiftL` elemBits) .|. fromIntegral (fromEnum a)
1587 patWord = mask .&. A.foldl' addToWord 0 patArr
1589 go0 !_ !idx wrd st !acc = do
1590 res <- step (adaptState gst) st
1593 let wrd' = addToWord wrd x
1594 acc' <- if withSep then fstep acc x else return acc
1597 if wrd' .&. mask == patWord
1600 return $ Yield r (GO_SHORT_PAT s)
1601 else go1 SPEC wrd' s acc'
1602 else go0 SPEC (idx + 1) wrd' s acc'
1603 Skip s -> go0 SPEC idx wrd s acc
1605 if (idx == maxIndex) && (wrd .&. mask == patWord)
1608 acc' <- if idx /= 0 && not withSep
1609 then go2 wrd idx acc
1611 done acc' >>= \r -> return $ Yield r GO_DONE
1614 go1 !_ wrd st !acc = do
1615 res <- step (adaptState gst) st
1618 let wrd' = addToWord wrd x
1619 old = (mask .&. wrd) `shiftR` (elemBits * (patLen - 1))
1622 else fstep acc (toEnum $ fromIntegral old)
1623 if wrd' .&. mask == patWord
1624 then done acc' >>= \r -> return $ Yield r (GO_SHORT_PAT s)
1625 else go1 SPEC wrd' s acc'
1626 Skip s -> go1 SPEC wrd s acc
1628 -- If the last sequence is a separator do not issue a blank
1630 if wrd .&. mask == patWord
1635 else go2 wrd patLen acc
1636 done acc' >>= \r -> return $ Yield r GO_DONE
1638 go2 !wrd !n !acc | n > 0 = do
1639 let old = (mask .&. wrd) `shiftR` (elemBits * (n - 1))
1640 fstep acc (toEnum $ fromIntegral old) >>= go2 wrd (n - 1)
1641 go2 _ _ acc = return acc
1643 stepOuter gst (GO_KARP_RABIN stt rb rhead) = do
1645 res <- step (adaptState gst) stt
1649 acc' <- if withSep then fstep acc x else return acc
1650 rh' <- liftIO (RB.unsafeInsert rb rhead x)
1653 let fold = RB.unsafeFoldRing (RB.ringBound rb)
1654 let !ringHash = fold addCksum 0 rb
1655 if ringHash == patHash
1656 then go2 SPEC ringHash rh' s acc'
1657 else go0 SPEC (idx + 1) rh' s acc'
1658 else go0 SPEC (idx + 1) rh' s acc'
1659 Skip s -> return $ Skip (GO_KARP_RABIN s rb rhead)
1664 k = 2891336453 :: Word32
1666 addCksum cksum a = cksum * k + fromIntegral (fromEnum a)
1667 deltaCksum cksum old new =
1668 addCksum cksum new - coeff * fromIntegral (fromEnum old)
1670 -- XXX shall we use a random starting hash or 1 instead of 0?
1671 patHash = A.foldl' addCksum 0 patArr
1674 go0 !_ !idx !rh st !acc = do
1675 res <- step (adaptState gst) st
1678 acc' <- if withSep then fstep acc x else return acc
1679 rh' <- liftIO (RB.unsafeInsert rb rh x)
1682 let fold = RB.unsafeFoldRing (RB.ringBound rb)
1683 let !ringHash = fold addCksum 0 rb
1684 if ringHash == patHash
1685 then go2 SPEC ringHash rh' s acc'
1686 else go1 SPEC ringHash rh' s acc'
1687 else go0 SPEC (idx + 1) rh' s acc'
1688 Skip s -> go0 SPEC idx rh s acc
1690 -- do not issue a blank segment when we end at pattern
1691 if (idx == maxIndex) && RB.unsafeEqArray rb rh patArr
1694 !acc' <- if idx /= 0 && not withSep
1695 then RB.unsafeFoldRingM rh fstep acc rb
1697 done acc' >>= \r -> return $ Yield r GO_DONE
1699 -- XXX Theoretically this code can do 4 times faster if GHC generates
1700 -- optimal code. If we use just "(cksum' == patHash)" condition it goes
1701 -- 4x faster, as soon as we add the "RB.unsafeEqArray rb v" condition
1702 -- the generated code changes drastically and becomes 4x slower. Need
1703 -- to investigate what is going on with GHC.
1705 go1 !_ !cksum !rh st !acc = do
1706 res <- step (adaptState gst) st
1709 old <- liftIO $ peek rh
1710 let cksum' = deltaCksum cksum old x
1715 if (cksum' == patHash)
1717 rh' <- liftIO (RB.unsafeInsert rb rh x)
1718 go2 SPEC cksum' rh' s acc'
1720 rh' <- liftIO (RB.unsafeInsert rb rh x)
1721 go1 SPEC cksum' rh' s acc'
1722 Skip s -> go1 SPEC cksum rh s acc
1724 if RB.unsafeEqArray rb rh patArr
1729 else RB.unsafeFoldRingFullM rh fstep acc rb
1730 done acc' >>= \r -> return $ Yield r GO_DONE
1732 go2 !_ !cksum' !rh' s !acc' = do
1733 if RB.unsafeEqArray rb rh' patArr
1736 return $ Yield r (GO_KARP_RABIN s rb rhead)
1737 else go1 SPEC cksum' rh' s acc'
1739 stepOuter gst (GO_EMPTY_PAT st) = do
1740 res <- step (adaptState gst) st
1745 done acc' >>= \r -> return $ Yield r (GO_EMPTY_PAT s)
1746 Skip s -> return $ Skip (GO_EMPTY_PAT s)
1749 stepOuter _ GO_DONE = return Stop
1751data SplitState s arr
1753 | SplitBuffering s arr
1754 | SplitSplitting s arr
1755 | SplitYielding arr (SplitState s arr)
1758-- XXX An alternative approach would be to use a partial fold (Fold m a b) to
1759-- split using a splitBy like combinator. The Fold would consume upto the
1760-- separator and return any leftover which can then be fed to the next fold.
1762-- We can revisit this once we have partial folds/parsers.
1764-- | Performs infix separator style splitting.
1765{-# INLINE_NORMAL splitInnerBy #-}
1768 => (f a -> m (f a, Maybe (f a))) -- splitter
1769 -> (f a -> f a -> m (f a)) -- joiner
1772splitInnerBy splitter joiner (Stream step1 state1) =
1773 (Stream step (SplitInitial state1))
1777 {-# INLINE_LATE step #-}
1778 step gst (SplitInitial st) = do
1782 (x1, mx2) <- splitter x
1783 return $ case mx2 of
1784 Nothing -> Skip (SplitBuffering s x1)
1785 Just x2 -> Skip (SplitYielding x1 (SplitSplitting s x2))
1786 Skip s -> return $ Skip (SplitInitial s)
1787 Stop -> return $ Stop
1789 step gst (SplitBuffering st buf) = do
1793 (x1, mx2) <- splitter x
1794 buf' <- joiner buf x1
1795 return $ case mx2 of
1796 Nothing -> Skip (SplitBuffering s buf')
1797 Just x2 -> Skip (SplitYielding buf' (SplitSplitting s x2))
1798 Skip s -> return $ Skip (SplitBuffering s buf)
1799 Stop -> return $ Skip (SplitYielding buf SplitFinishing)
1801 step _ (SplitSplitting st buf) = do
1802 (x1, mx2) <- splitter buf
1803 return $ case mx2 of
1804 Nothing -> Skip $ SplitBuffering st x1
1805 Just x2 -> Skip $ SplitYielding x1 (SplitSplitting st x2)
1807 step _ (SplitYielding x next) = return $ Yield x next
1808 step _ SplitFinishing = return $ Stop
1810-- | Performs infix separator style splitting.
1811{-# INLINE_NORMAL splitInnerBySuffix #-}
1813 :: (Monad m, Eq (f a), Monoid (f a))
1814 => (f a -> m (f a, Maybe (f a))) -- splitter
1815 -> (f a -> f a -> m (f a)) -- joiner
1818splitInnerBySuffix splitter joiner (Stream step1 state1) =
1819 (Stream step (SplitInitial state1))
1823 {-# INLINE_LATE step #-}
1824 step gst (SplitInitial st) = do
1828 (x1, mx2) <- splitter x
1829 return $ case mx2 of
1830 Nothing -> Skip (SplitBuffering s x1)
1831 Just x2 -> Skip (SplitYielding x1 (SplitSplitting s x2))
1832 Skip s -> return $ Skip (SplitInitial s)
1833 Stop -> return $ Stop
1835 step gst (SplitBuffering st buf) = do
1839 (x1, mx2) <- splitter x
1840 buf' <- joiner buf x1
1841 return $ case mx2 of
1842 Nothing -> Skip (SplitBuffering s buf')
1843 Just x2 -> Skip (SplitYielding buf' (SplitSplitting s x2))
1844 Skip s -> return $ Skip (SplitBuffering s buf)
1848 else Skip (SplitYielding buf SplitFinishing)
1850 step _ (SplitSplitting st buf) = do
1851 (x1, mx2) <- splitter buf
1852 return $ case mx2 of
1853 Nothing -> Skip $ SplitBuffering st x1
1854 Just x2 -> Skip $ SplitYielding x1 (SplitSplitting st x2)
1856 step _ (SplitYielding x next) = return $ Yield x next
1857 step _ SplitFinishing = return $ Stop
1859------------------------------------------------------------------------------
1861------------------------------------------------------------------------------
1863{-# INLINE_NORMAL isPrefixOf #-}
1864isPrefixOf :: (Eq a, Monad m) => Stream m a -> Stream m a -> m Bool
1865isPrefixOf (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)
1867 go (sa, sb, Nothing) = do
1868 r <- stepa defState sa
1870 Yield x sa' -> go (sa', sb, Just x)
1871 Skip sa' -> go (sa', sb, Nothing)
1874 go (sa, sb, Just x) = do
1875 r <- stepb defState sb
1879 then go (sa, sb', Nothing)
1881 Skip sb' -> go (sa, sb', Just x)
1882 Stop -> return False
1884{-# INLINE_NORMAL isSubsequenceOf #-}
1885isSubsequenceOf :: (Eq a, Monad m) => Stream m a -> Stream m a -> m Bool
1886isSubsequenceOf (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)
1888 go (sa, sb, Nothing) = do
1889 r <- stepa defState sa
1891 Yield x sa' -> go (sa', sb, Just x)
1892 Skip sa' -> go (sa', sb, Nothing)
1895 go (sa, sb, Just x) = do
1896 r <- stepb defState sb
1900 then go (sa, sb', Nothing)
1901 else go (sa, sb', Just x)
1902 Skip sb' -> go (sa, sb', Just x)
1903 Stop -> return False
1905{-# INLINE_NORMAL stripPrefix #-}
1908 => Stream m a -> Stream m a -> m (Maybe (Stream m a))
1909stripPrefix (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)
1911 go (sa, sb, Nothing) = do
1912 r <- stepa defState sa
1914 Yield x sa' -> go (sa', sb, Just x)
1915 Skip sa' -> go (sa', sb, Nothing)
1916 Stop -> return $ Just (Stream stepb sb)
1918 go (sa, sb, Just x) = do
1919 r <- stepb defState sb
1923 then go (sa, sb', Nothing)
1925 Skip sb' -> go (sa, sb', Just x)
1926 Stop -> return Nothing
1928------------------------------------------------------------------------------
1930------------------------------------------------------------------------------
1932-- | Execute a monadic action for each element of the 'Stream'
1933{-# INLINE_NORMAL mapM_ #-}
1934mapM_ :: Monad m => (a -> m b) -> Stream m a -> m ()
1935mapM_ m = drain . mapM m
1937-------------------------------------------------------------------------------
1938-- Stream transformations using Unfolds
1939-------------------------------------------------------------------------------
1941-- Define a unique structure to use in inspection testing
1942data ConcatMapUState o i =
1944 | ConcatMapUInner o i
1946-- | @concatMapU unfold stream@ uses @unfold@ to map the input stream elements
1947-- to streams and then flattens the generated streams into a single output
1950-- This is like 'concatMap' but uses an unfold with an explicit state to
1951-- generate the stream instead of a 'Stream' type generator. This allows better
1952-- optimization via fusion. This can be many times more efficient than
1955{-# INLINE_NORMAL concatMapU #-}
1956concatMapU :: Monad m => Unfold m a b -> Stream m a -> Stream m b
1957concatMapU (Unfold istep inject) (Stream ostep ost) =
1958 Stream step (ConcatMapUOuter ost)
1960 {-# INLINE_LATE step #-}
1961 step gst (ConcatMapUOuter o) = do
1962 r <- ostep (adaptState gst) o
1966 i `seq` return (Skip (ConcatMapUInner o' i))
1967 Skip o' -> return $ Skip (ConcatMapUOuter o')
1968 Stop -> return $ Stop
1970 step _ (ConcatMapUInner o i) = do
1973 Yield x i' -> Yield x (ConcatMapUInner o i')
1974 Skip i' -> Skip (ConcatMapUInner o i')
1975 Stop -> Skip (ConcatMapUOuter o)
1977data ConcatUnfoldInterleaveState o i =
1978 ConcatUnfoldInterleaveOuter o [i]
1979 | ConcatUnfoldInterleaveInner o [i]
1980 | ConcatUnfoldInterleaveInnerL [i] [i]
1981 | ConcatUnfoldInterleaveInnerR [i] [i]
1983-- XXX use arrays to store state instead of lists.
1984-- XXX In general we can use different scheduling strategies e.g. how to
1985-- schedule the outer vs inner loop or assigning weights to different streams
1986-- or outer and inner loops.
1988-- After a yield, switch to the next stream. Do not switch streams on Skip.
1989-- Yield from outer stream switches to the inner stream.
1991-- There are two choices here, (1) exhaust the outer stream first and then
1992-- start yielding from the inner streams, this is much simpler to implement,
1993-- (2) yield at least one element from an inner stream before going back to
1994-- outer stream and opening the next stream from it.
1996-- Ideally, we need some scheduling bias to inner streams vs outer stream.
1997-- Maybe we can configure the behavior.
1999{-# INLINE_NORMAL concatUnfoldInterleave #-}
2000concatUnfoldInterleave :: Monad m => Unfold m a b -> Stream m a -> Stream m b
2001concatUnfoldInterleave (Unfold istep inject) (Stream ostep ost) =
2002 Stream step (ConcatUnfoldInterleaveOuter ost [])
2004 {-# INLINE_LATE step #-}
2005 step gst (ConcatUnfoldInterleaveOuter o ls) = do
2006 r <- ostep (adaptState gst) o
2010 i `seq` return (Skip (ConcatUnfoldInterleaveInner o' (i : ls)))
2011 Skip o' -> return $ Skip (ConcatUnfoldInterleaveOuter o' ls)
2012 Stop -> return $ Skip (ConcatUnfoldInterleaveInnerL ls [])
2014 step _ (ConcatUnfoldInterleaveInner _ []) = undefined
2015 step _ (ConcatUnfoldInterleaveInner o (st:ls)) = do
2018 Yield x s -> Yield x (ConcatUnfoldInterleaveOuter o (s:ls))
2019 Skip s -> Skip (ConcatUnfoldInterleaveInner o (s:ls))
2020 Stop -> Skip (ConcatUnfoldInterleaveOuter o ls)
2022 step _ (ConcatUnfoldInterleaveInnerL [] []) = return Stop
2023 step _ (ConcatUnfoldInterleaveInnerL [] rs) =
2024 return $ Skip (ConcatUnfoldInterleaveInnerR [] rs)
2026 step _ (ConcatUnfoldInterleaveInnerL (st:ls) rs) = do
2029 Yield x s -> Yield x (ConcatUnfoldInterleaveInnerL ls (s:rs))
2030 Skip s -> Skip (ConcatUnfoldInterleaveInnerL (s:ls) rs)
2031 Stop -> Skip (ConcatUnfoldInterleaveInnerL ls rs)
2033 step _ (ConcatUnfoldInterleaveInnerR [] []) = return Stop
2034 step _ (ConcatUnfoldInterleaveInnerR ls []) =
2035 return $ Skip (ConcatUnfoldInterleaveInnerL ls [])
2037 step _ (ConcatUnfoldInterleaveInnerR ls (st:rs)) = do
2040 Yield x s -> Yield x (ConcatUnfoldInterleaveInnerR (s:ls) rs)
2041 Skip s -> Skip (ConcatUnfoldInterleaveInnerR ls (s:rs))
2042 Stop -> Skip (ConcatUnfoldInterleaveInnerR ls rs)
2044-- XXX In general we can use different scheduling strategies e.g. how to
2045-- schedule the outer vs inner loop or assigning weights to different streams
2046-- or outer and inner loops.
2048-- This could be inefficient if the tasks are too small.
2050-- Compared to concatUnfoldInterleave this one switches streams on Skips.
2052{-# INLINE_NORMAL concatUnfoldRoundrobin #-}
2053concatUnfoldRoundrobin :: Monad m => Unfold m a b -> Stream m a -> Stream m b
2054concatUnfoldRoundrobin (Unfold istep inject) (Stream ostep ost) =
2055 Stream step (ConcatUnfoldInterleaveOuter ost [])
2057 {-# INLINE_LATE step #-}
2058 step gst (ConcatUnfoldInterleaveOuter o ls) = do
2059 r <- ostep (adaptState gst) o
2063 i `seq` return (Skip (ConcatUnfoldInterleaveInner o' (i : ls)))
2064 Skip o' -> return $ Skip (ConcatUnfoldInterleaveInner o' ls)
2065 Stop -> return $ Skip (ConcatUnfoldInterleaveInnerL ls [])
2067 step _ (ConcatUnfoldInterleaveInner o []) =
2068 return $ Skip (ConcatUnfoldInterleaveOuter o [])
2070 step _ (ConcatUnfoldInterleaveInner o (st:ls)) = do
2073 Yield x s -> Yield x (ConcatUnfoldInterleaveOuter o (s:ls))
2074 Skip s -> Skip (ConcatUnfoldInterleaveOuter o (s:ls))
2075 Stop -> Skip (ConcatUnfoldInterleaveOuter o ls)
2077 step _ (ConcatUnfoldInterleaveInnerL [] []) = return Stop
2078 step _ (ConcatUnfoldInterleaveInnerL [] rs) =
2079 return $ Skip (ConcatUnfoldInterleaveInnerR [] rs)
2081 step _ (ConcatUnfoldInterleaveInnerL (st:ls) rs) = do
2084 Yield x s -> Yield x (ConcatUnfoldInterleaveInnerL ls (s:rs))
2085 Skip s -> Skip (ConcatUnfoldInterleaveInnerL ls (s:rs))
2086 Stop -> Skip (ConcatUnfoldInterleaveInnerL ls rs)
2088 step _ (ConcatUnfoldInterleaveInnerR [] []) = return Stop
2089 step _ (ConcatUnfoldInterleaveInnerR ls []) =
2090 return $ Skip (ConcatUnfoldInterleaveInnerL ls [])
2092 step _ (ConcatUnfoldInterleaveInnerR ls (st:rs)) = do
2095 Yield x s -> Yield x (ConcatUnfoldInterleaveInnerR (s:ls) rs)
2096 Skip s -> Skip (ConcatUnfoldInterleaveInnerR (s:ls) rs)
2097 Stop -> Skip (ConcatUnfoldInterleaveInnerR ls rs)
2099data AppendState s1 s2 = AppendFirst s1 | AppendSecond s2
2101-- Note that this could be much faster compared to the CPS stream. However, as
2102-- the number of streams being composed increases this may become expensive.
2103-- Need to see where the breaking point is between the two.
2105{-# INLINE_NORMAL append #-}
2106append :: Monad m => Stream m a -> Stream m a -> Stream m a
2107append (Stream step1 state1) (Stream step2 state2) =
2108 Stream step (AppendFirst state1)
2112 {-# INLINE_LATE step #-}
2113 step gst (AppendFirst st) = do
2116 Yield a s -> Yield a (AppendFirst s)
2117 Skip s -> Skip (AppendFirst s)
2118 Stop -> Skip (AppendSecond state2)
2120 step gst (AppendSecond st) = do
2123 Yield a s -> Yield a (AppendSecond s)
2124 Skip s -> Skip (AppendSecond s)
2127data InterleaveState s1 s2 = InterleaveFirst s1 s2 | InterleaveSecond s1 s2
2128 | InterleaveSecondOnly s2 | InterleaveFirstOnly s1
2130{-# INLINE_NORMAL interleave #-}
2131interleave :: Monad m => Stream m a -> Stream m a -> Stream m a
2132interleave (Stream step1 state1) (Stream step2 state2) =
2133 Stream step (InterleaveFirst state1 state2)
2137 {-# INLINE_LATE step #-}
2138 step gst (InterleaveFirst st1 st2) = do
2141 Yield a s -> Yield a (InterleaveSecond s st2)
2142 Skip s -> Skip (InterleaveFirst s st2)
2143 Stop -> Skip (InterleaveSecondOnly st2)
2145 step gst (InterleaveSecond st1 st2) = do
2148 Yield a s -> Yield a (InterleaveFirst st1 s)
2149 Skip s -> Skip (InterleaveSecond st1 s)
2150 Stop -> Skip (InterleaveFirstOnly st1)
2152 step gst (InterleaveFirstOnly st1) = do
2155 Yield a s -> Yield a (InterleaveFirstOnly s)
2156 Skip s -> Skip (InterleaveFirstOnly s)
2159 step gst (InterleaveSecondOnly st2) = do
2162 Yield a s -> Yield a (InterleaveSecondOnly s)
2163 Skip s -> Skip (InterleaveSecondOnly s)
2166{-# INLINE_NORMAL interleaveMin #-}
2167interleaveMin :: Monad m => Stream m a -> Stream m a -> Stream m a
2168interleaveMin (Stream step1 state1) (Stream step2 state2) =
2169 Stream step (InterleaveFirst state1 state2)
2173 {-# INLINE_LATE step #-}
2174 step gst (InterleaveFirst st1 st2) = do
2177 Yield a s -> Yield a (InterleaveSecond s st2)
2178 Skip s -> Skip (InterleaveFirst s st2)
2181 step gst (InterleaveSecond st1 st2) = do
2184 Yield a s -> Yield a (InterleaveFirst st1 s)
2185 Skip s -> Skip (InterleaveSecond st1 s)
2188 step _ (InterleaveFirstOnly _) = undefined
2189 step _ (InterleaveSecondOnly _) = undefined
2191{-# INLINE_NORMAL interleaveSuffix #-}
2192interleaveSuffix :: Monad m => Stream m a -> Stream m a -> Stream m a
2193interleaveSuffix (Stream step1 state1) (Stream step2 state2) =
2194 Stream step (InterleaveFirst state1 state2)
2198 {-# INLINE_LATE step #-}
2199 step gst (InterleaveFirst st1 st2) = do
2202 Yield a s -> Yield a (InterleaveSecond s st2)
2203 Skip s -> Skip (InterleaveFirst s st2)
2206 step gst (InterleaveSecond st1 st2) = do
2209 Yield a s -> Yield a (InterleaveFirst st1 s)
2210 Skip s -> Skip (InterleaveSecond st1 s)
2211 Stop -> Skip (InterleaveFirstOnly st1)
2213 step gst (InterleaveFirstOnly st1) = do
2216 Yield a s -> Yield a (InterleaveFirstOnly s)
2217 Skip s -> Skip (InterleaveFirstOnly s)
2220 step _ (InterleaveSecondOnly _) = undefined
2222data InterleaveInfixState s1 s2 a
2223 = InterleaveInfixFirst s1 s2
2224 | InterleaveInfixSecondBuf s1 s2
2225 | InterleaveInfixSecondYield s1 s2 a
2226 | InterleaveInfixFirstYield s1 s2 a
2227 | InterleaveInfixFirstOnly s1
2229{-# INLINE_NORMAL interleaveInfix #-}
2230interleaveInfix :: Monad m => Stream m a -> Stream m a -> Stream m a
2231interleaveInfix (Stream step1 state1) (Stream step2 state2) =
2232 Stream step (InterleaveInfixFirst state1 state2)
2236 {-# INLINE_LATE step #-}
2237 step gst (InterleaveInfixFirst st1 st2) = do
2240 Yield a s -> Yield a (InterleaveInfixSecondBuf s st2)
2241 Skip s -> Skip (InterleaveInfixFirst s st2)
2244 step gst (InterleaveInfixSecondBuf st1 st2) = do
2247 Yield a s -> Skip (InterleaveInfixSecondYield st1 s a)
2248 Skip s -> Skip (InterleaveInfixSecondBuf st1 s)
2249 Stop -> Skip (InterleaveInfixFirstOnly st1)
2251 step gst (InterleaveInfixSecondYield st1 st2 x) = do
2254 Yield a s -> Yield x (InterleaveInfixFirstYield s st2 a)
2255 Skip s -> Skip (InterleaveInfixSecondYield s st2 x)
2258 step _ (InterleaveInfixFirstYield st1 st2 x) = do
2259 return $ Yield x (InterleaveInfixSecondBuf st1 st2)
2261 step gst (InterleaveInfixFirstOnly st1) = do
2264 Yield a s -> Yield a (InterleaveInfixFirstOnly s)
2265 Skip s -> Skip (InterleaveInfixFirstOnly s)
2268{-# INLINE_NORMAL roundRobin #-}
2269roundRobin :: Monad m => Stream m a -> Stream m a -> Stream m a
2270roundRobin (Stream step1 state1) (Stream step2 state2) =
2271 Stream step (InterleaveFirst state1 state2)
2275 {-# INLINE_LATE step #-}
2276 step gst (InterleaveFirst st1 st2) = do
2279 Yield a s -> Yield a (InterleaveSecond s st2)
2280 Skip s -> Skip (InterleaveSecond s st2)
2281 Stop -> Skip (InterleaveSecondOnly st2)
2283 step gst (InterleaveSecond st1 st2) = do
2286 Yield a s -> Yield a (InterleaveFirst st1 s)
2287 Skip s -> Skip (InterleaveFirst st1 s)
2288 Stop -> Skip (InterleaveFirstOnly st1)
2290 step gst (InterleaveSecondOnly st2) = do
2293 Yield a s -> Yield a (InterleaveSecondOnly s)
2294 Skip s -> Skip (InterleaveSecondOnly s)
2297 step gst (InterleaveFirstOnly st1) = do
2300 Yield a s -> Yield a (InterleaveFirstOnly s)
2301 Skip s -> Skip (InterleaveFirstOnly s)
2304data ICUState s1 s2 i1 i2 =
2309 | ICUFirstInner s1 s2 i1
2310 | ICUSecondInner s1 s2 i2
2311 | ICUFirstOnlyInner s1 i1
2312 | ICUSecondOnlyInner s2 i2
2314-- | Interleave streams (full streams, not the elements) unfolded from two
2315-- input streams and concat. Stop when the first stream stops. If the second
2316-- stream ends before the first one then first stream still keeps running alone
2317-- without any interleaving with the second stream.
2319-- [a1, a2, ... an] [b1, b2 ...]
2320-- => [streamA1, streamA2, ... streamAn] [streamB1, streamB2, ...]
2321-- => [streamA1, streamB1, streamA2...StreamAn, streamBn]
2322-- => [a11, a12, ...a1j, b11, b12, ...b1k, a21, a22, ...]
2324{-# INLINE_NORMAL gintercalateSuffix #-}
2327 => Unfold m a c -> Stream m a -> Unfold m b c -> Stream m b -> Stream m c
2329 (Unfold istep1 inject1) (Stream step1 state1)
2330 (Unfold istep2 inject2) (Stream step2 state2) =
2331 Stream step (ICUFirst state1 state2)
2335 {-# INLINE_LATE step #-}
2336 step gst (ICUFirst s1 s2) = do
2337 r <- step1 (adaptState gst) s1
2341 i `seq` return (Skip (ICUFirstInner s s2 i))
2342 Skip s -> return $ Skip (ICUFirst s s2)
2345 step gst (ICUFirstOnly s1) = do
2346 r <- step1 (adaptState gst) s1
2350 i `seq` return (Skip (ICUFirstOnlyInner s i))
2351 Skip s -> return $ Skip (ICUFirstOnly s)
2354 step _ (ICUFirstInner s1 s2 i1) = do
2357 Yield x i' -> Yield x (ICUFirstInner s1 s2 i')
2358 Skip i' -> Skip (ICUFirstInner s1 s2 i')
2359 Stop -> Skip (ICUSecond s1 s2)
2361 step _ (ICUFirstOnlyInner s1 i1) = do
2364 Yield x i' -> Yield x (ICUFirstOnlyInner s1 i')
2365 Skip i' -> Skip (ICUFirstOnlyInner s1 i')
2366 Stop -> Skip (ICUFirstOnly s1)
2368 step gst (ICUSecond s1 s2) = do
2369 r <- step2 (adaptState gst) s2
2373 i `seq` return (Skip (ICUSecondInner s1 s i))
2374 Skip s -> return $ Skip (ICUSecond s1 s)
2375 Stop -> return $ Skip (ICUFirstOnly s1)
2377 step _ (ICUSecondInner s1 s2 i2) = do
2380 Yield x i' -> Yield x (ICUSecondInner s1 s2 i')
2381 Skip i' -> Skip (ICUSecondInner s1 s2 i')
2382 Stop -> Skip (ICUFirst s1 s2)
2384 step _ (ICUSecondOnly _s2) = undefined
2385 step _ (ICUSecondOnlyInner _s2 _i2) = undefined
2387data InterposeSuffixState s1 i1 =
2388 InterposeSuffixFirst s1
2389 -- | InterposeSuffixFirstYield s1 i1
2390 | InterposeSuffixFirstInner s1 i1
2391 | InterposeSuffixSecond s1
2393-- Note that if an unfolded layer turns out to be nil we still emit the
2394-- separator effect. An alternate behavior could be to emit the separator
2395-- effect only if at least one element has been yielded by the unfolding.
2396-- However, that becomes a bit complicated, so we have chosen the former
2398{-# INLINE_NORMAL interposeSuffix #-}
2401 => m c -> Unfold m b c -> Stream m b -> Stream m c
2404 (Unfold istep1 inject1) (Stream step1 state1) =
2405 Stream step (InterposeSuffixFirst state1)
2409 {-# INLINE_LATE step #-}
2410 step gst (InterposeSuffixFirst s1) = do
2411 r <- step1 (adaptState gst) s1
2415 i `seq` return (Skip (InterposeSuffixFirstInner s i))
2416 -- i `seq` return (Skip (InterposeSuffixFirstYield s i))
2417 Skip s -> return $ Skip (InterposeSuffixFirst s)
2421 step _ (InterposeSuffixFirstYield s1 i1) = do
2424 Yield x i' -> Yield x (InterposeSuffixFirstInner s1 i')
2425 Skip i' -> Skip (InterposeSuffixFirstYield s1 i')
2426 Stop -> Skip (InterposeSuffixFirst s1)
2429 step _ (InterposeSuffixFirstInner s1 i1) = do
2432 Yield x i' -> Yield x (InterposeSuffixFirstInner s1 i')
2433 Skip i' -> Skip (InterposeSuffixFirstInner s1 i')
2434 Stop -> Skip (InterposeSuffixSecond s1)
2436 step _ (InterposeSuffixSecond s1) = do
2438 return $ Yield r (InterposeSuffixFirst s1)
2440data ICALState s1 s2 i1 i2 a =
2442 -- | ICALFirstYield s1 s2 i1
2443 | ICALFirstInner s1 s2 i1
2445 | ICALFirstOnlyInner s1 i1
2446 | ICALSecondInject s1 s2
2447 | ICALFirstInject s1 s2 i2
2448 -- | ICALFirstBuf s1 s2 i1 i2
2449 | ICALSecondInner s1 s2 i1 i2
2450 -- -- | ICALSecondInner s1 s2 i1 i2 a
2451 -- -- | ICALFirstResume s1 s2 i1 i2 a
2453-- | Interleave streams (full streams, not the elements) unfolded from two
2454-- input streams and concat. Stop when the first stream stops. If the second
2455-- stream ends before the first one then first stream still keeps running alone
2456-- without any interleaving with the second stream.
2458-- [a1, a2, ... an] [b1, b2 ...]
2459-- => [streamA1, streamA2, ... streamAn] [streamB1, streamB2, ...]
2460-- => [streamA1, streamB1, streamA2...StreamAn, streamBn]
2461-- => [a11, a12, ...a1j, b11, b12, ...b1k, a21, a22, ...]
2463{-# INLINE_NORMAL gintercalate #-}
2466 => Unfold m a c -> Stream m a -> Unfold m b c -> Stream m b -> Stream m c
2468 (Unfold istep1 inject1) (Stream step1 state1)
2469 (Unfold istep2 inject2) (Stream step2 state2) =
2470 Stream step (ICALFirst state1 state2)
2474 {-# INLINE_LATE step #-}
2475 step gst (ICALFirst s1 s2) = do
2476 r <- step1 (adaptState gst) s1
2480 i `seq` return (Skip (ICALFirstInner s s2 i))
2481 -- i `seq` return (Skip (ICALFirstYield s s2 i))
2482 Skip s -> return $ Skip (ICALFirst s s2)
2486 step _ (ICALFirstYield s1 s2 i1) = do
2489 Yield x i' -> Yield x (ICALFirstInner s1 s2 i')
2490 Skip i' -> Skip (ICALFirstYield s1 s2 i')
2491 Stop -> Skip (ICALFirst s1 s2)
2494 step _ (ICALFirstInner s1 s2 i1) = do
2497 Yield x i' -> Yield x (ICALFirstInner s1 s2 i')
2498 Skip i' -> Skip (ICALFirstInner s1 s2 i')
2499 Stop -> Skip (ICALSecondInject s1 s2)
2501 step gst (ICALFirstOnly s1) = do
2502 r <- step1 (adaptState gst) s1
2506 i `seq` return (Skip (ICALFirstOnlyInner s i))
2507 Skip s -> return $ Skip (ICALFirstOnly s)
2510 step _ (ICALFirstOnlyInner s1 i1) = do
2513 Yield x i' -> Yield x (ICALFirstOnlyInner s1 i')
2514 Skip i' -> Skip (ICALFirstOnlyInner s1 i')
2515 Stop -> Skip (ICALFirstOnly s1)
2517 -- We inject the second stream even before checking if the first stream
2518 -- would yield any more elements. There is no clear choice whether we
2519 -- should do this before or after that. Doing it after may make the state
2520 -- machine a bit simpler though.
2521 step gst (ICALSecondInject s1 s2) = do
2522 r <- step2 (adaptState gst) s2
2526 i `seq` return (Skip (ICALFirstInject s1 s i))
2527 Skip s -> return $ Skip (ICALSecondInject s1 s)
2528 Stop -> return $ Skip (ICALFirstOnly s1)
2530 step gst (ICALFirstInject s1 s2 i2) = do
2531 r <- step1 (adaptState gst) s1
2535 i `seq` return (Skip (ICALSecondInner s s2 i i2))
2536 -- i `seq` return (Skip (ICALFirstBuf s s2 i i2))
2537 Skip s -> return $ Skip (ICALFirstInject s s2 i2)
2541 step _ (ICALFirstBuf s1 s2 i1 i2) = do
2544 Yield x i' -> Skip (ICALSecondInner s1 s2 i' i2 x)
2545 Skip i' -> Skip (ICALFirstBuf s1 s2 i' i2)
2548 step _ (ICALSecondInner s1 s2 i1 i2 v) = do
2551 Yield x i' -> Yield x (ICALSecondInner s1 s2 i1 i' v)
2552 Skip i' -> Skip (ICALSecondInner s1 s2 i1 i' v)
2553 Stop -> Skip (ICALFirstResume s1 s2 i1 i2 v)
2556 step _ (ICALSecondInner s1 s2 i1 i2) = do
2559 Yield x i' -> Yield x (ICALSecondInner s1 s2 i1 i')
2560 Skip i' -> Skip (ICALSecondInner s1 s2 i1 i')
2561 Stop -> Skip (ICALFirstInner s1 s2 i1)
2562 -- Stop -> Skip (ICALFirstResume s1 s2 i1 i2)
2565 step _ (ICALFirstResume s1 s2 i1 i2 x) = do
2566 return $ Yield x (ICALFirstInner s1 s2 i1 i2)
2569data InterposeState s1 i1 a =
2571 -- | InterposeFirstYield s1 i1
2572 | InterposeFirstInner s1 i1
2573 | InterposeFirstInject s1
2574 -- | InterposeFirstBuf s1 i1
2575 | InterposeSecondYield s1 i1
2576 -- -- | InterposeSecondYield s1 i1 a
2577 -- -- | InterposeFirstResume s1 i1 a
2579-- Note that this only interposes the pure values, we may run many effects to
2580-- generate those values as some effects may not generate anything (Skip).
2581{-# INLINE_NORMAL interpose #-}
2582interpose :: Monad m => m c -> Unfold m b c -> Stream m b -> Stream m c
2585 (Unfold istep1 inject1) (Stream step1 state1) =
2586 Stream step (InterposeFirst state1)
2590 {-# INLINE_LATE step #-}
2591 step gst (InterposeFirst s1) = do
2592 r <- step1 (adaptState gst) s1
2596 i `seq` return (Skip (InterposeFirstInner s i))
2597 -- i `seq` return (Skip (InterposeFirstYield s i))
2598 Skip s -> return $ Skip (InterposeFirst s)
2602 step _ (InterposeFirstYield s1 i1) = do
2605 Yield x i' -> Yield x (InterposeFirstInner s1 i')
2606 Skip i' -> Skip (InterposeFirstYield s1 i')
2607 Stop -> Skip (InterposeFirst s1)
2610 step _ (InterposeFirstInner s1 i1) = do
2613 Yield x i' -> Yield x (InterposeFirstInner s1 i')
2614 Skip i' -> Skip (InterposeFirstInner s1 i')
2615 Stop -> Skip (InterposeFirstInject s1)
2617 step gst (InterposeFirstInject s1) = do
2618 r <- step1 (adaptState gst) s1
2622 -- i `seq` return (Skip (InterposeFirstBuf s i))
2623 i `seq` return (Skip (InterposeSecondYield s i))
2624 Skip s -> return $ Skip (InterposeFirstInject s)
2628 step _ (InterposeFirstBuf s1 i1) = do
2631 Yield x i' -> Skip (InterposeSecondYield s1 i' x)
2632 Skip i' -> Skip (InterposeFirstBuf s1 i')
2637 step _ (InterposeSecondYield s1 i1 v) = do
2639 return $ Yield r (InterposeFirstResume s1 i1 v)
2641 step _ (InterposeSecondYield s1 i1) = do
2643 return $ Yield r (InterposeFirstInner s1 i1)
2646 step _ (InterposeFirstResume s1 i1 v) = do
2647 return $ Yield v (InterposeFirstInner s1 i1)
2650------------------------------------------------------------------------------
2652------------------------------------------------------------------------------
2654data GbracketState s1 s2 v
2656 | GBracketNormal s1 v
2657 | GBracketException s2
2659-- | The most general bracketing and exception combinator. All other
2660-- combinators can be expressed in terms of this combinator. This can also be
2661-- used for cases which are not covered by the standard combinators.
2665{-# INLINE_NORMAL gbracket #-}
2669 -> (forall s. m s -> m (Either e s)) -- ^ try (exception handling)
2670 -> (c -> m d) -- ^ after, on normal stop
2671 -> (c -> e -> Stream m b) -- ^ on exception
2672 -> (c -> Stream m b) -- ^ stream generator
2674gbracket bef exc aft fexc fnormal =
2675 Stream step GBracketInit
2679 {-# INLINE_LATE step #-}
2680 step _ GBracketInit = do
2682 return $ Skip $ GBracketNormal (fnormal r) r
2684 step gst (GBracketNormal (UnStream step1 st) v) = do
2685 res <- exc $ step1 gst st
2687 Right r -> case r of
2689 return $ Yield x (GBracketNormal (Stream step1 s) v)
2690 Skip s -> return $ Skip (GBracketNormal (Stream step1 s) v)
2691 Stop -> aft v >> return Stop
2692 Left e -> return $ Skip (GBracketException (fexc v e))
2693 step gst (GBracketException (UnStream step1 st)) = do
2696 Yield x s -> return $ Yield x (GBracketException (Stream step1 s))
2697 Skip s -> return $ Skip (GBracketException (Stream step1 s))
2700-- | Run a side effect before the stream yields its first element.
2701{-# INLINE_NORMAL before #-}
2702before :: Monad m => m b -> Stream m a -> Stream m a
2703before action (Stream step state) = Stream step' Nothing
2707 {-# INLINE_LATE step' #-}
2708 step' _ Nothing = action >> return (Skip (Just state))
2710 step' gst (Just st) = do
2713 Yield x s -> return $ Yield x (Just s)
2714 Skip s -> return $ Skip (Just s)
2717-- | Run a side effect whenever the stream stops normally.
2718{-# INLINE_NORMAL after #-}
2719after :: Monad m => m b -> Stream m a -> Stream m a
2720after action (Stream step state) = Stream step' state
2724 {-# INLINE_LATE step' #-}
2728 Yield x s -> return $ Yield x s
2729 Skip s -> return $ Skip s
2730 Stop -> action >> return Stop
2732-- XXX These combinators are expensive due to the call to
2733-- onException/handle/try on each step. Therefore, when possible, they should
2734-- be called in an outer loop where we perform less iterations. For example, we
2735-- cannot call them on each iteration in a char stream, instead we can call
2736-- them when doing an IO on an array.
2738-- XXX For high performance error checks in busy streams we may need another
2739-- Error constructor in step.
2741-- | Run a side effect whenever the stream aborts due to an exception. The
2742-- exception is not caught, simply rethrown.
2743{-# INLINE_NORMAL onException #-}
2744onException :: MonadCatch m => m b -> Stream m a -> Stream m a
2745onException action str =
2746 gbracket (return ()) MC.try return
2747 (\_ (_ :: MC.SomeException) -> nilM $ action)
2750{-# INLINE_NORMAL _onException #-}
2751_onException :: MonadCatch m => m b -> Stream m a -> Stream m a
2752_onException action (Stream step state) = Stream step' state
2756 {-# INLINE_LATE step' #-}
2758 res <- step gst st `MC.onException` action
2760 Yield x s -> return $ Yield x s
2761 Skip s -> return $ Skip s
2764-- XXX bracket is like concatMap, it generates a stream and then flattens it.
2765-- Like concatMap it has 10x worse performance compared to linear fused
2768-- | Run the first action before the stream starts and remember its output,
2769-- generate a stream using the output, run the second action providing the
2770-- remembered value as an argument whenever the stream ends normally or due to
2772{-# INLINE_NORMAL bracket #-}
2773bracket :: MonadCatch m => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a
2774bracket bef aft bet =
2775 gbracket bef MC.try aft (\a (_ :: SomeException) -> nilM $ aft a) bet
2777data BracketState s v = BracketInit | BracketRun s v
2779{-# INLINE_NORMAL _bracket #-}
2780_bracket :: MonadCatch m => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a
2781_bracket bef aft bet = Stream step' BracketInit
2785 {-# INLINE_LATE step' #-}
2786 step' _ BracketInit = bef >>= \x -> return (Skip (BracketRun (bet x) x))
2788 -- NOTE: It is important to use UnStream instead of the Stream pattern
2789 -- here, otherwise we get huge perf degradation, see note in concatMap.
2790 step' gst (BracketRun (UnStream step state) v) = do
2791 -- res <- step gst state `MC.onException` aft v
2792 res <- MC.try $ step gst state
2794 Left (_ :: SomeException) -> aft v >> return Stop
2795 Right r -> case r of
2796 Yield x s -> return $ Yield x (BracketRun (Stream step s) v)
2797 Skip s -> return $ Skip (BracketRun (Stream step s) v)
2798 Stop -> aft v >> return Stop
2800-- | Run a side effect whenever the stream stops normally or aborts due to an
2802{-# INLINE finally #-}
2803finally :: MonadCatch m => m b -> Stream m a -> Stream m a
2804-- finally action xs = after action $ onException action xs
2805finally action xs = bracket (return ()) (\_ -> action) (const xs)
2807-- | When evaluating a stream if an exception occurs, stream evaluation aborts
2808-- and the specified exception handler is run with the exception as argument.
2809{-# INLINE_NORMAL handle #-}
2810handle :: (MonadCatch m, Exception e)
2811 => (e -> Stream m a) -> Stream m a -> Stream m a
2813 gbracket (return ()) MC.try return (\_ e -> f e) (\_ -> str)
2815{-# INLINE_NORMAL _handle #-}
2816_handle :: (MonadCatch m, Exception e)
2817 => (e -> Stream m a) -> Stream m a -> Stream m a
2818_handle f (Stream step state) = Stream step' (Left state)
2822 {-# INLINE_LATE step' #-}
2823 step' gst (Left st) = do
2824 res <- MC.try $ step gst st
2826 Left e -> return $ Skip $ Right (f e)
2827 Right r -> case r of
2828 Yield x s -> return $ Yield x (Left s)
2829 Skip s -> return $ Skip (Left s)
2832 step' gst (Right (UnStream step1 st)) = do
2835 Yield x s -> return $ Yield x (Right (Stream step1 s))
2836 Skip s -> return $ Skip (Right (Stream step1 s))
2839-------------------------------------------------------------------------------
2840-- General transformation
2841-------------------------------------------------------------------------------
2843{-# INLINE_NORMAL transform #-}
2844transform :: Monad m => Pipe m a b -> Stream m a -> Stream m b
2845transform (Pipe pstep1 pstep2 pstate) (Stream step state) =
2846 Stream step' (Consume pstate, state)
2850 {-# INLINE_LATE step' #-}
2852 step' gst (Consume pst, st) = pst `seq` do
2853 r <- step (adaptState gst) st
2858 Pipe.Yield b pst' -> return $ Yield b (pst', s)
2859 Pipe.Continue pst' -> return $ Skip (pst', s)
2860 Skip s -> return $ Skip (Consume pst, s)
2863 step' _ (Produce pst, st) = pst `seq` do
2866 Pipe.Yield b pst' -> return $ Yield b (pst', st)
2867 Pipe.Continue pst' -> return $ Skip (pst', st)
2869------------------------------------------------------------------------------
2870-- Transformation by Folding (Scans)
2871------------------------------------------------------------------------------
2873------------------------------------------------------------------------------
2875------------------------------------------------------------------------------
2877-- XXX Is a prescan useful, discarding the last step does not sound useful? I
2878-- am not sure about the utility of this function, so this is implemented but
2879-- not exposed. We can expose it if someone provides good reasons why this is
2882-- XXX We have to execute the stream one step ahead to know that we are at the
2883-- last step. The vector implementation of prescan executes the last fold step
2884-- but does not yield the result. This means we have executed the effect but
2885-- discarded value. This does not sound right. In this implementation we are
2886-- not executing the last fold step.
2887{-# INLINE_NORMAL prescanlM' #-}
2888prescanlM' :: Monad m => (b -> a -> m b) -> m b -> Stream m a -> Stream m b
2889prescanlM' f mz (Stream step state) = Stream step' (state, mz)
2891 {-# INLINE_LATE step' #-}
2892 step' gst (st, prev) = do
2893 r <- step (adaptState gst) st
2897 return $ Yield acc (s, f acc x)
2898 Skip s -> return $ Skip (s, prev)
2901{-# INLINE prescanl' #-}
2902prescanl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b
2903prescanl' f z = prescanlM' (\a b -> return (f a b)) (return z)
2905------------------------------------------------------------------------------
2906-- Monolithic postscans (postscan followed by a map)
2907------------------------------------------------------------------------------
2909-- The performance of a modular postscan followed by a map seems to be
2910-- equivalent to this monolithic scan followed by map therefore we may not need
2911-- this implementation. We just have it for performance comparison and in case
2912-- modular version does not perform well in some situation.
2914{-# INLINE_NORMAL postscanlMx' #-}
2915postscanlMx' :: Monad m
2916 => (x -> a -> m x) -> m x -> (x -> m b) -> Stream m a -> Stream m b
2917postscanlMx' fstep begin done (Stream step state) = do
2918 Stream step' (state, begin)
2920 {-# INLINE_LATE step' #-}
2921 step' gst (st, acc) = do
2922 r <- step (adaptState gst) st
2928 v `seq` y `seq` return (Yield v (s, return y))
2929 Skip s -> return $ Skip (s, acc)
2932{-# INLINE_NORMAL postscanlx' #-}
2933postscanlx' :: Monad m
2934 => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> Stream m b
2935postscanlx' fstep begin done s =
2936 postscanlMx' (\b a -> return (fstep b a)) (return begin) (return . done) s
2938-- XXX do we need consM strict to evaluate the begin value?
2939{-# INLINE scanlMx' #-}
2941 => (x -> a -> m x) -> m x -> (x -> m b) -> Stream m a -> Stream m b
2942scanlMx' fstep begin done s =
2943 (begin >>= \x -> x `seq` done x) `consM` postscanlMx' fstep begin done s
2945{-# INLINE scanlx' #-}
2947 => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> Stream m b
2948scanlx' fstep begin done s =
2949 scanlMx' (\b a -> return (fstep b a)) (return begin) (return . done) s
2951------------------------------------------------------------------------------
2953------------------------------------------------------------------------------
2955{-# INLINE_NORMAL postscanlM' #-}
2956postscanlM' :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
2957postscanlM' fstep begin (Stream step state) =
2958 begin `seq` Stream step' (state, begin)
2960 {-# INLINE_LATE step' #-}
2961 step' gst (st, acc) = acc `seq` do
2962 r <- step (adaptState gst) st
2966 y `seq` return (Yield y (s, y))
2967 Skip s -> return $ Skip (s, acc)
2970{-# INLINE_NORMAL postscanl' #-}
2971postscanl' :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a
2972postscanl' f = postscanlM' (\a b -> return (f a b))
2974{-# INLINE_NORMAL postscanlM #-}
2975postscanlM :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
2976postscanlM fstep begin (Stream step state) = Stream step' (state, begin)
2978 {-# INLINE_LATE step' #-}
2979 step' gst (st, acc) = do
2980 r <- step (adaptState gst) st
2984 return (Yield y (s, y))
2985 Skip s -> return $ Skip (s, acc)
2988{-# INLINE_NORMAL postscanl #-}
2989postscanl :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a
2990postscanl f = postscanlM (\a b -> return (f a b))
2992{-# INLINE_NORMAL scanlM' #-}
2993scanlM' :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
2994scanlM' fstep begin s = begin `seq` (begin `cons` postscanlM' fstep begin s)
2996{-# INLINE scanl' #-}
2997scanl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b
2998scanl' f = scanlM' (\a b -> return (f a b))
3000{-# INLINE_NORMAL scanlM #-}
3001scanlM :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
3002scanlM fstep begin s = begin `cons` postscanlM fstep begin s
3005scanl :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b
3006scanl f = scanlM (\a b -> return (f a b))
3008{-# INLINE_NORMAL scanl1M #-}
3009scanl1M :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a
3010scanl1M fstep (Stream step state) = Stream step' (state, Nothing)
3012 {-# INLINE_LATE step' #-}
3013 step' gst (st, Nothing) = do
3016 Yield x s -> return $ Yield x (s, Just x)
3017 Skip s -> return $ Skip (s, Nothing)
3020 step' gst (st, Just acc) = do
3025 return $ Yield z (s, Just z)
3026 Skip s -> return $ Skip (s, Just acc)
3029{-# INLINE scanl1 #-}
3030scanl1 :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a
3031scanl1 f = scanl1M (\x y -> return (f x y))
3033{-# INLINE_NORMAL scanl1M' #-}
3034scanl1M' :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a
3035scanl1M' fstep (Stream step state) = Stream step' (state, Nothing)
3037 {-# INLINE_LATE step' #-}
3038 step' gst (st, Nothing) = do
3041 Yield x s -> x `seq` return $ Yield x (s, Just x)
3042 Skip s -> return $ Skip (s, Nothing)
3045 step' gst (st, Just acc) = acc `seq` do
3050 z `seq` return $ Yield z (s, Just z)
3051 Skip s -> return $ Skip (s, Just acc)
3054{-# INLINE scanl1' #-}
3055scanl1' :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a
3056scanl1' f = scanl1M' (\x y -> return (f x y))
3059tap :: Monad m => Fold m a b -> Stream m a -> Stream m a
3060tap (Fold fstep initial extract) (Stream step state) = Stream step' Nothing
3064 step' _ Nothing = do
3066 return $ Skip (Just (r, state))
3068 step' gst (Just (acc, st)) = do
3073 return $ Yield x (Just (acc', s))
3074 Skip s -> return $ Skip (Just (acc, s))
3079-------------------------------------------------------------------------------
3081-------------------------------------------------------------------------------
3083{-# INLINE_NORMAL takeWhileM #-}
3084takeWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a
3085takeWhileM f (Stream step state) = Stream step' state
3087 {-# INLINE_LATE step' #-}
3093 return $ if b then Yield x s else Stop
3094 Skip s -> return $ Skip s
3097{-# INLINE takeWhile #-}
3098takeWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
3099takeWhile f = takeWhileM (return . f)
3101{-# INLINE_NORMAL drop #-}
3102drop :: Monad m => Int -> Stream m a -> Stream m a
3103drop n (Stream step state) = Stream step' (state, Just n)
3105 {-# INLINE_LATE step' #-}
3106 step' gst (st, Just i)
3111 Yield _ s -> Skip (s, Just (i - 1))
3112 Skip s -> Skip (s, Just i)
3114 | otherwise = return $ Skip (st, Nothing)
3116 step' gst (st, Nothing) = do
3120 Yield x s -> Yield x (s, Nothing)
3121 Skip s -> Skip (s, Nothing)
3124data DropWhileState s a
3126 | DropWhileYield a s
3129{-# INLINE_NORMAL dropWhileM #-}
3130dropWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a
3131dropWhileM f (Stream step state) = Stream step' (DropWhileDrop state)
3133 {-# INLINE_LATE step' #-}
3134 step' gst (DropWhileDrop st) = do
3140 then return $ Skip (DropWhileDrop s)
3141 else return $ Skip (DropWhileYield x s)
3142 Skip s -> return $ Skip (DropWhileDrop s)
3145 step' gst (DropWhileNext st) = do
3148 Yield x s -> return $ Skip (DropWhileYield x s)
3149 Skip s -> return $ Skip (DropWhileNext s)
3152 step' _ (DropWhileYield x st) = return $ Yield x (DropWhileNext st)
3154{-# INLINE dropWhile #-}
3155dropWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
3156dropWhile f = dropWhileM (return . f)
3158{-# INLINE_NORMAL filterM #-}
3159filterM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a
3160filterM f (Stream step state) = Stream step' state
3162 {-# INLINE_LATE step' #-}
3171 Skip s -> return $ Skip s
3174{-# INLINE filter #-}
3175filter :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
3176filter f = filterM (return . f)
3178{-# INLINE_NORMAL uniq #-}
3179uniq :: (Eq a, Monad m) => Stream m a -> Stream m a
3180uniq (Stream step state) = Stream step' (Nothing, state)
3182 {-# INLINE_LATE step' #-}
3183 step' gst (Nothing, st) = do
3186 Yield x s -> return $ Yield x (Just x, s)
3187 Skip s -> return $ Skip (Nothing, s)
3189 step' gst (Just x, st) = do
3192 Yield y s | x == y -> return $ Skip (Just x, s)
3193 | otherwise -> return $ Yield y (Just y, s)
3194 Skip s -> return $ Skip (Just x, s)
3197------------------------------------------------------------------------------
3198-- Transformation by Mapping
3199------------------------------------------------------------------------------
3201{-# INLINE_NORMAL sequence #-}
3202sequence :: Monad m => Stream m (m a) -> Stream m a
3203sequence (Stream step state) = Stream step' state
3205 {-# INLINE_LATE step' #-}
3207 r <- step (adaptState gst) st
3209 Yield x s -> x >>= \a -> return (Yield a s)
3210 Skip s -> return $ Skip s
3213------------------------------------------------------------------------------
3215------------------------------------------------------------------------------
3217data LoopState x s = FirstYield s
3218 | InterspersingYield s
3221{-# INLINE_NORMAL intersperseM #-}
3222intersperseM :: Monad m => m a -> Stream m a -> Stream m a
3223intersperseM m (Stream step state) = Stream step' (FirstYield state)
3225 {-# INLINE_LATE step' #-}
3226 step' gst (FirstYield st) = do
3230 Yield x s -> Skip (YieldAndCarry x s)
3231 Skip s -> Skip (FirstYield s)
3234 step' gst (InterspersingYield st) = do
3239 return $ Yield a (YieldAndCarry x s)
3240 Skip s -> return $ Skip $ InterspersingYield s
3243 step' _ (YieldAndCarry x st) = return $ Yield x (InterspersingYield st)
3248 | SuffixYield a (SuffixState s a)
3250{-# INLINE_NORMAL intersperseSuffix #-}
3251intersperseSuffix :: forall m a. Monad m => m a -> Stream m a -> Stream m a
3252intersperseSuffix action (Stream step state) = Stream step' (SuffixElem state)
3254 {-# INLINE_LATE step' #-}
3255 step' gst (SuffixElem st) = do
3258 Yield x s -> Skip (SuffixYield x (SuffixSuffix s))
3259 Skip s -> Skip (SuffixElem s)
3262 step' _ (SuffixSuffix st) = do
3263 action >>= \r -> return $ Skip (SuffixYield r (SuffixElem st))
3265 step' _ (SuffixYield x next) = return $ Yield x next
3267{-# INLINE intersperse #-}
3268intersperse :: Monad m => a -> Stream m a -> Stream m a
3269intersperse a = intersperseM (return a)
3271{-# INLINE_NORMAL insertBy #-}
3272insertBy :: Monad m => (a -> a -> Ordering) -> a -> Stream m a -> Stream m a
3273insertBy cmp a (Stream step state) = Stream step' (state, False, Nothing)
3275 {-# INLINE_LATE step' #-}
3276 step' gst (st, False, _) = do
3279 Yield x s -> case cmp a x of
3280 GT -> return $ Yield x (s, False, Nothing)
3281 _ -> return $ Yield a (s, True, Just x)
3282 Skip s -> return $ Skip (s, False, Nothing)
3283 Stop -> return $ Yield a (st, True, Nothing)
3285 step' _ (_, True, Nothing) = return Stop
3287 step' gst (st, True, Just prev) = do
3290 Yield x s -> return $ Yield prev (s, True, Just x)
3291 Skip s -> return $ Skip (s, True, Just prev)
3292 Stop -> return $ Yield prev (st, True, Nothing)
3294------------------------------------------------------------------------------
3296------------------------------------------------------------------------------
3298{-# INLINE_NORMAL deleteBy #-}
3299deleteBy :: Monad m => (a -> a -> Bool) -> a -> Stream m a -> Stream m a
3300deleteBy eq x (Stream step state) = Stream step' (state, False)
3302 {-# INLINE_LATE step' #-}
3303 step' gst (st, False) = do
3306 Yield y s -> return $
3307 if eq x y then Skip (s, True) else Yield y (s, False)
3308 Skip s -> return $ Skip (s, False)
3311 step' gst (st, True) = do
3314 Yield y s -> return $ Yield y (s, True)
3315 Skip s -> return $ Skip (s, True)
3318------------------------------------------------------------------------------
3319-- Transformation by Map and Filter
3320------------------------------------------------------------------------------
3322-- XXX Will this always fuse properly?
3323{-# INLINE_NORMAL mapMaybe #-}
3324mapMaybe :: Monad m => (a -> Maybe b) -> Stream m a -> Stream m b
3325mapMaybe f = fmap fromJust . filter isJust . map f
3327{-# INLINE_NORMAL mapMaybeM #-}
3328mapMaybeM :: Monad m => (a -> m (Maybe b)) -> Stream m a -> Stream m b
3329mapMaybeM f = fmap fromJust . filter isJust . mapM f
3331------------------------------------------------------------------------------
3333------------------------------------------------------------------------------
3335{-# INLINE_NORMAL indexed #-}
3336indexed :: Monad m => Stream m a -> Stream m (Int, a)
3337indexed (Stream step state) = Stream step' (state, 0)
3339 {-# INLINE_LATE step' #-}
3340 step' gst (st, i) = i `seq` do
3341 r <- step (adaptState gst) st
3343 Yield x s -> return $ Yield (i, x) (s, i+1)
3344 Skip s -> return $ Skip (s, i)
3347{-# INLINE_NORMAL indexedR #-}
3348indexedR :: Monad m => Int -> Stream m a -> Stream m (Int, a)
3349indexedR m (Stream step state) = Stream step' (state, m)
3351 {-# INLINE_LATE step' #-}
3352 step' gst (st, i) = i `seq` do
3353 r <- step (adaptState gst) st
3355 Yield x s -> let i' = i - 1
3356 in return $ Yield (i, x) (s, i')
3357 Skip s -> return $ Skip (s, i)
3360{-# INLINE_NORMAL zipWithM #-}
3362 => (a -> b -> m c) -> Stream m a -> Stream m b -> Stream m c
3363zipWithM f (Stream stepa ta) (Stream stepb tb) = Stream step (ta, tb, Nothing)
3365 {-# INLINE_LATE step #-}
3366 step gst (sa, sb, Nothing) = do
3367 r <- stepa (adaptState gst) sa
3370 Yield x sa' -> Skip (sa', sb, Just x)
3371 Skip sa' -> Skip (sa', sb, Nothing)
3374 step gst (sa, sb, Just x) = do
3375 r <- stepb (adaptState gst) sb
3379 return $ Yield z (sa, sb', Nothing)
3380 Skip sb' -> return $ Skip (sa, sb', Just x)
3383#if __GLASGOW_HASKELL__ >= 801
3384{-# RULES "zipWithM xs xs"
3385 forall f xs. zipWithM @Identity f xs xs = mapM (\x -> f x x) xs #-}
3388{-# INLINE zipWith #-}
3389zipWith :: Monad m => (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c
3390zipWith f = zipWithM (\a b -> return (f a b))
3392------------------------------------------------------------------------------
3394------------------------------------------------------------------------------
3396{-# INLINE_NORMAL mergeByM #-}
3399 => (a -> a -> m Ordering) -> Stream m a -> Stream m a -> Stream m a
3400mergeByM cmp (Stream stepa ta) (Stream stepb tb) =
3401 Stream step (Just ta, Just tb, Nothing, Nothing)
3403 {-# INLINE_LATE step #-}
3405 -- one of the values is missing, and the corresponding stream is running
3406 step gst (Just sa, sb, Nothing, b) = do
3409 Yield a sa' -> Skip (Just sa', sb, Just a, b)
3410 Skip sa' -> Skip (Just sa', sb, Nothing, b)
3411 Stop -> Skip (Nothing, sb, Nothing, b)
3413 step gst (sa, Just sb, a, Nothing) = do
3416 Yield b sb' -> Skip (sa, Just sb', a, Just b)
3417 Skip sb' -> Skip (sa, Just sb', a, Nothing)
3418 Stop -> Skip (sa, Nothing, a, Nothing)
3420 -- both the values are available
3421 step _ (sa, sb, Just a, Just b) = do
3423 return $ case res of
3424 GT -> Yield b (sa, sb, Just a, Nothing)
3425 _ -> Yield a (sa, sb, Nothing, Just b)
3427 -- one of the values is missing, corresponding stream is done
3428 step _ (Nothing, sb, Nothing, Just b) =
3429 return $ Yield b (Nothing, sb, Nothing, Nothing)
3431 step _ (sa, Nothing, Just a, Nothing) =
3432 return $ Yield a (sa, Nothing, Nothing, Nothing)
3434 step _ (Nothing, Nothing, Nothing, Nothing) = return Stop
3436{-# INLINE mergeBy #-}
3439 => (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a
3440mergeBy cmp = mergeByM (\a b -> return $ cmp a b)
3442------------------------------------------------------------------------------
3443-- Transformation comprehensions
3444------------------------------------------------------------------------------
3446{-# INLINE_NORMAL the #-}
3447the :: (Eq a, Monad m) => Stream m a -> m (Maybe a)
3448the (Stream step state) = go state
3451 r <- step defState st
3453 Yield x s -> go' x s
3455 Stop -> return Nothing
3457 r <- step defState st
3459 Yield x s | x == n -> go' n s
3460 | otherwise -> return Nothing
3462 Stop -> return (Just n)
3464--------------------------------------------------------------------------------
3465-- UTF8 Encoding / Decoding
3466--------------------------------------------------------------------------------
3468-- UTF-8 primitives, Lifted from GHC.IO.Encoding.UTF8.
3471ord2 :: Char -> WList
3472ord2 c = assert (n >= 0x80 && n <= 0x07ff) (WCons x1 (WCons x2 WNil))
3475 x1 = fromIntegral $ (n `shiftR` 6) + 0xC0
3476 x2 = fromIntegral $ (n .&. 0x3F) + 0x80
3479ord3 :: Char -> WList
3480ord3 c = assert (n >= 0x0800 && n <= 0xffff) (WCons x1 (WCons x2 (WCons x3 WNil)))
3483 x1 = fromIntegral $ (n `shiftR` 12) + 0xE0
3484 x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
3485 x3 = fromIntegral $ (n .&. 0x3F) + 0x80
3488ord4 :: Char -> WList
3489ord4 c = assert (n >= 0x10000) (WCons x1 (WCons x2 (WCons x3 (WCons x4 WNil))))
3492 x1 = fromIntegral $ (n `shiftR` 18) + 0xF0
3493 x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80
3494 x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
3495 x4 = fromIntegral $ (n .&. 0x3F) + 0x80
3497data CodingFailureMode
3498 = TransliterateCodingFailure
3499 | ErrorOnCodingFailure
3502{-# INLINE replacementChar #-}
3503replacementChar :: Char
3504replacementChar = '\xFFFD'
3506-- Int helps in cheaper conversion from Int to Char
3508type DecodeState = Word8
3510-- See http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ for details.
3512{-# INLINE runFold #-}
3513runFold :: (Monad m) => Fold m a b -> Stream m a -> m b
3514runFold (Fold step begin done) = foldlMx' step begin done
3516-- XXX Use names decodeSuccess = 0, decodeFailure = 12
3518decodeTable :: [Word8]
3520 -- The first part of the table maps bytes to character classes that
3521 -- to reduce the size of the transition table and create bitmasks.
3522 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,
3523 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,
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 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,
3527 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,
3528 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,
3529 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,
3531 -- The second part is a transition table that maps a combination
3532 -- of a state of the automaton and a character class to a state.
3533 0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12,
3534 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,
3535 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,
3536 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,
3537 12,36,12,12,12,12,12,12,12,12,12,12
3540utf8d :: A.Array Word8
3543 -- Aligning to cacheline makes a barely noticeable difference
3544 -- XXX currently alignment is not implemented for unmanaged allocation
3545 $ runFold (A.writeNAlignedUnmanaged 64 (length decodeTable))
3546 (fromList decodeTable)
3548-- | Return element at the specified index without checking the bounds.
3549-- and without touching the foreign ptr.
3550{-# INLINE_NORMAL unsafePeekElemOff #-}
3551unsafePeekElemOff :: forall a. Storable a => Ptr a -> Int -> a
3552unsafePeekElemOff p i = let !x = A.unsafeInlineIO $ peekElemOff p i in x
3554-- decode is split into two separate cases to avoid branching instructions.
3555-- From the higher level flow we already know which case we are in so we can
3556-- call the appropriate decode function.
3558-- When the state is 0
3559{-# INLINE decode0 #-}
3560decode0 :: Ptr Word8 -> Word8 -> Tuple' DecodeState CodePoint
3562 let !t = table `unsafePeekElemOff` fromIntegral byte
3563 !codep' = (0xff `shiftR` (fromIntegral t)) .&. fromIntegral byte
3564 !state' = table `unsafePeekElemOff` (256 + fromIntegral t)
3565 in assert ((byte > 0x7f || error showByte)
3566 && (state' /= 0 || error (showByte ++ showTable)))
3567 (Tuple' state' codep')
3572 let !(Ptr addr) = table
3573 end = table `plusPtr` 364
3574 in A.Array (ForeignPtr addr undefined) end end :: A.Array Word8
3575 showByte = "Streamly: decode0: byte: " ++ show byte
3576 showTable = " table: " ++ show utf8table
3578-- When the state is not 0
3579{-# INLINE decode1 #-}
3585 -> Tuple' DecodeState CodePoint
3586decode1 table state codep byte =
3587 -- Remember codep is Int type!
3588 -- Can it be unsafe to convert the resulting Int to Char?
3589 let !t = table `unsafePeekElemOff` fromIntegral byte
3590 !codep' = (fromIntegral byte .&. 0x3f) .|. (codep `shiftL` 6)
3591 !state' = table `unsafePeekElemOff`
3592 (256 + fromIntegral state + fromIntegral t)
3593 in assert (codep' <= 0x10FFFF
3594 || error (showByte ++ showState state codep))
3595 (Tuple' state' codep')
3599 let !(Ptr addr) = table
3600 end = table `plusPtr` 364
3601 in A.Array (ForeignPtr addr undefined) end end :: A.Array Word8
3602 showByte = "Streamly: decode1: byte: " ++ show byte
3604 " state: " ++ show st ++
3605 " codepoint: " ++ show cp ++
3606 " table: " ++ show utf8table
3608-- We can divide the errors in three general categories:
3609-- * A non-starter was encountered in a begin state
3610-- * A starter was encountered without completing a codepoint
3611-- * The last codepoint was not complete (input underflow)
3613data DecodeError = DecodeError !DecodeState !CodePoint deriving Show
3616 = FreshPointDecodeInit s
3617 | FreshPointDecodeInit1 s Word8
3618 | FreshPointDecodeFirst s Word8
3619 | FreshPointDecoding s !DecodeState !CodePoint
3620 | YieldAndContinue a (FreshPoint s a)
3623-- XXX Add proper error messages
3624-- XXX Implement this in terms of decodeUtf8Either
3625{-# INLINE_NORMAL decodeUtf8With #-}
3626decodeUtf8With :: Monad m => CodingFailureMode -> Stream m Word8 -> Stream m Char
3627decodeUtf8With cfm (Stream step state) =
3628 let Array p _ _ = utf8d
3629 !ptr = (unsafeForeignPtrToPtr p)
3630 in Stream (step' ptr) (FreshPointDecodeInit state)
3632 {-# INLINE transliterateOrError #-}
3633 transliterateOrError e s =
3635 ErrorOnCodingFailure -> error e
3636 TransliterateCodingFailure -> YieldAndContinue replacementChar s
3637 {-# INLINE inputUnderflow #-}
3640 ErrorOnCodingFailure ->
3641 error "Streamly.Streams.StreamD.decodeUtf8With: Input Underflow"
3642 TransliterateCodingFailure -> YieldAndContinue replacementChar Done
3643 {-# INLINE_LATE step' #-}
3644 step' _ gst (FreshPointDecodeInit st) = do
3645 r <- step (adaptState gst) st
3647 Yield x s -> Skip (FreshPointDecodeInit1 s x)
3648 Skip s -> Skip (FreshPointDecodeInit s)
3651 step' _ _ (FreshPointDecodeInit1 st x) = do
3652 -- Note: It is important to use a ">" instead of a "<=" test
3653 -- here for GHC to generate code layout for default branch
3654 -- prediction for the common case. This is fragile and might
3655 -- change with the compiler versions, we need a more reliable
3656 -- "likely" primitive to control branch predication.
3659 return $ Skip $ YieldAndContinue
3660 (unsafeChr (fromIntegral x))
3661 (FreshPointDecodeInit st)
3662 -- Using a separate state here generates a jump to a
3663 -- separate code block in the core which seems to perform
3664 -- slightly better for the non-ascii case.
3665 True -> return $ Skip $ FreshPointDecodeFirst st x
3667 -- XXX should we merge it with FreshPointDecodeInit1?
3668 step' table _ (FreshPointDecodeFirst st x) = do
3669 let (Tuple' sv cp) = decode0 table x
3674 transliterateOrError
3675 "Streamly.Streams.StreamD.decodeUtf8With: Invalid UTF8 codepoint encountered"
3676 (FreshPointDecodeInit st)
3677 0 -> error "unreachable state"
3678 _ -> Skip (FreshPointDecoding st sv cp)
3680 -- We recover by trying the new byte x a starter of a new codepoint.
3681 -- XXX need to use the same recovery in array decoding routine as well
3682 step' table gst (FreshPointDecoding st statePtr codepointPtr) = do
3683 r <- step (adaptState gst) st
3686 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
3689 0 -> Skip $ YieldAndContinue (unsafeChr cp)
3690 (FreshPointDecodeInit s)
3693 transliterateOrError
3694 "Streamly.Streams.StreamD.decodeUtf8With: Invalid UTF8 codepoint encountered"
3695 (FreshPointDecodeInit1 s x)
3696 _ -> Skip (FreshPointDecoding s sv cp)
3697 Skip s -> return $ Skip (FreshPointDecoding s statePtr codepointPtr)
3698 Stop -> return $ Skip inputUnderflow
3700 step' _ _ (YieldAndContinue c s) = return $ Yield c s
3701 step' _ _ Done = return Stop
3703{-# INLINE decodeUtf8 #-}
3704decodeUtf8 :: Monad m => Stream m Word8 -> Stream m Char
3705decodeUtf8 = decodeUtf8With ErrorOnCodingFailure
3707{-# INLINE decodeUtf8Lenient #-}
3708decodeUtf8Lenient :: Monad m => Stream m Word8 -> Stream m Char
3709decodeUtf8Lenient = decodeUtf8With TransliterateCodingFailure
3711{-# INLINE_NORMAL resumeDecodeUtf8Either #-}
3712resumeDecodeUtf8Either
3717 -> Stream m (Either DecodeError Char)
3718resumeDecodeUtf8Either dst codep (Stream step state) =
3719 let Array p _ _ = utf8d
3720 !ptr = (unsafeForeignPtrToPtr p)
3723 then FreshPointDecodeInit state
3724 else FreshPointDecoding state dst codep
3725 in Stream (step' ptr) stt
3727 {-# INLINE_LATE step' #-}
3728 step' _ gst (FreshPointDecodeInit st) = do
3729 r <- step (adaptState gst) st
3731 Yield x s -> Skip (FreshPointDecodeInit1 s x)
3732 Skip s -> Skip (FreshPointDecodeInit s)
3735 step' _ _ (FreshPointDecodeInit1 st x) = do
3736 -- Note: It is important to use a ">" instead of a "<=" test
3737 -- here for GHC to generate code layout for default branch
3738 -- prediction for the common case. This is fragile and might
3739 -- change with the compiler versions, we need a more reliable
3740 -- "likely" primitive to control branch predication.
3743 return $ Skip $ YieldAndContinue
3744 (Right $ unsafeChr (fromIntegral x))
3745 (FreshPointDecodeInit st)
3746 -- Using a separate state here generates a jump to a
3747 -- separate code block in the core which seems to perform
3748 -- slightly better for the non-ascii case.
3749 True -> return $ Skip $ FreshPointDecodeFirst st x
3751 -- XXX should we merge it with FreshPointDecodeInit1?
3752 step' table _ (FreshPointDecodeFirst st x) = do
3753 let (Tuple' sv cp) = decode0 table x
3757 Skip $ YieldAndContinue (Left $ DecodeError 0 (fromIntegral x))
3758 (FreshPointDecodeInit st)
3759 0 -> error "unreachable state"
3760 _ -> Skip (FreshPointDecoding st sv cp)
3762 -- We recover by trying the new byte x a starter of a new codepoint.
3763 -- XXX need to use the same recovery in array decoding routine as well
3764 step' table gst (FreshPointDecoding st statePtr codepointPtr) = do
3765 r <- step (adaptState gst) st
3768 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
3771 0 -> Skip $ YieldAndContinue (Right $ unsafeChr cp)
3772 (FreshPointDecodeInit s)
3774 Skip $ YieldAndContinue (Left $ DecodeError statePtr codepointPtr)
3775 (FreshPointDecodeInit1 s x)
3776 _ -> Skip (FreshPointDecoding s sv cp)
3777 Skip s -> return $ Skip (FreshPointDecoding s statePtr codepointPtr)
3778 Stop -> return $ Skip $ YieldAndContinue (Left $ DecodeError statePtr codepointPtr) Done
3780 step' _ _ (YieldAndContinue c s) = return $ Yield c s
3781 step' _ _ Done = return Stop
3783{-# INLINE_NORMAL decodeUtf8Either #-}
3784decodeUtf8Either :: Monad m
3785 => Stream m Word8 -> Stream m (Either DecodeError Char)
3786decodeUtf8Either = resumeDecodeUtf8Either 0 0
3788data FlattenState s a
3789 = OuterLoop s !(Maybe (DecodeState, CodePoint))
3790 | InnerLoopDecodeInit s (ForeignPtr a) !(Ptr a) !(Ptr a)
3791 | InnerLoopDecodeFirst s (ForeignPtr a) !(Ptr a) !(Ptr a) Word8
3792 | InnerLoopDecoding s (ForeignPtr a) !(Ptr a) !(Ptr a)
3793 !DecodeState !CodePoint
3794 | YAndC !Char (FlattenState s a) -- These constructors can be
3795 -- encoded in the FreshPoint
3796 -- type, I prefer to keep these
3797 -- flat even though that means
3798 -- coming up with new names
3801-- The normal decodeUtf8 above should fuse with flattenArrays
3802-- to create this exact code but it doesn't for some reason, as of now this
3803-- remains the fastest way I could figure out to decodeUtf8.
3805-- XXX Add Proper error messages
3806{-# INLINE_NORMAL decodeUtf8ArraysWith #-}
3807decodeUtf8ArraysWith ::
3809 => CodingFailureMode
3810 -> Stream m (A.Array Word8)
3812decodeUtf8ArraysWith cfm (Stream step state) =
3813 let Array p _ _ = utf8d
3814 !ptr = (unsafeForeignPtrToPtr p)
3815 in Stream (step' ptr) (OuterLoop state Nothing)
3817 {-# INLINE transliterateOrError #-}
3818 transliterateOrError e s =
3820 ErrorOnCodingFailure -> error e
3821 TransliterateCodingFailure -> YAndC replacementChar s
3822 {-# INLINE inputUnderflow #-}
3825 ErrorOnCodingFailure ->
3827 "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Input Underflow"
3828 TransliterateCodingFailure -> YAndC replacementChar D
3829 {-# INLINE_LATE step' #-}
3830 step' _ gst (OuterLoop st Nothing) = do
3831 r <- step (adaptState gst) st
3834 Yield A.Array {..} s ->
3835 let p = unsafeForeignPtrToPtr aStart
3836 in Skip (InnerLoopDecodeInit s aStart p aEnd)
3837 Skip s -> Skip (OuterLoop s Nothing)
3839 step' _ gst (OuterLoop st dst@(Just (ds, cp))) = do
3840 r <- step (adaptState gst) st
3843 Yield A.Array {..} s ->
3844 let p = unsafeForeignPtrToPtr aStart
3845 in Skip (InnerLoopDecoding s aStart p aEnd ds cp)
3846 Skip s -> Skip (OuterLoop s dst)
3847 Stop -> Skip inputUnderflow
3848 step' _ _ (InnerLoopDecodeInit st startf p end)
3850 liftIO $ touchForeignPtr startf
3851 return $ Skip $ OuterLoop st Nothing
3852 step' _ _ (InnerLoopDecodeInit st startf p end) = do
3853 x <- liftIO $ peek p
3854 -- Note: It is important to use a ">" instead of a "<=" test here for
3855 -- GHC to generate code layout for default branch prediction for the
3856 -- common case. This is fragile and might change with the compiler
3857 -- versions, we need a more reliable "likely" primitive to control
3858 -- branch predication.
3861 return $ Skip $ YAndC
3862 (unsafeChr (fromIntegral x))
3863 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
3864 -- Using a separate state here generates a jump to a separate code
3865 -- block in the core which seems to perform slightly better for the
3867 True -> return $ Skip $ InnerLoopDecodeFirst st startf p end x
3869 step' table _ (InnerLoopDecodeFirst st startf p end x) = do
3870 let (Tuple' sv cp) = decode0 table x
3875 transliterateOrError
3876 "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered"
3877 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
3878 0 -> error "unreachable state"
3879 _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)
3880 step' _ _ (InnerLoopDecoding st startf p end sv cp)
3882 liftIO $ touchForeignPtr startf
3883 return $ Skip $ OuterLoop st (Just (sv, cp))
3884 step' table _ (InnerLoopDecoding st startf p end statePtr codepointPtr) = do
3885 x <- liftIO $ peek p
3886 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
3893 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
3896 transliterateOrError
3897 "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered"
3898 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
3899 _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)
3900 step' _ _ (YAndC c s) = return $ Yield c s
3901 step' _ _ D = return Stop
3903{-# INLINE decodeUtf8Arrays #-}
3906 => Stream m (A.Array Word8)
3908decodeUtf8Arrays = decodeUtf8ArraysWith ErrorOnCodingFailure
3910{-# INLINE decodeUtf8ArraysLenient #-}
3911decodeUtf8ArraysLenient ::
3913 => Stream m (A.Array Word8)
3915decodeUtf8ArraysLenient = decodeUtf8ArraysWith TransliterateCodingFailure
3917data WList = WCons !Word8 !WList | WNil
3919data EncodeState s = EncodeState s !WList
3921-- More yield points improve performance, but I am not sure if they can cause
3922-- too much code bloat or some trouble with fusion. So keeping only two yield
3923-- points for now, one for the ascii chars (fast path) and one for all other
3924-- paths (slow path).
3925{-# INLINE_NORMAL encodeUtf8 #-}
3926encodeUtf8 :: Monad m => Stream m Char -> Stream m Word8
3927encodeUtf8 (Stream step state) = Stream step' (EncodeState state WNil)
3929 {-# INLINE_LATE step' #-}
3930 step' gst (EncodeState st WNil) = do
3931 r <- step (adaptState gst) st
3938 Yield (fromIntegral x) (EncodeState s WNil)
3939 | x <= 0x7FF -> Skip (EncodeState s (ord2 c))
3943 "Streamly.Streams.StreamD.encodeUtf8: Encountered a surrogate"
3944 else Skip (EncodeState s (ord3 c))
3945 | otherwise -> Skip (EncodeState s (ord4 c))
3946 Skip s -> Skip (EncodeState s WNil)
3948 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