1{-# LANGUAGE BangPatterns #-}
3{-# LANGUAGE ConstraintKinds #-}
4{-# LANGUAGE ExistentialQuantification #-}
5{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE PatternSynonyms #-}
9{-# LANGUAGE RecordWildCards #-}
10{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE ViewPatterns #-}
12{-# LANGUAGE RankNTypes #-}
13{-# LANGUAGE MagicHash #-}
15#if __GLASGOW_HASKELL__ >= 801
16{-# LANGUAGE TypeApplications #-}
22-- Module : Streamly.Streams.StreamD
23-- Copyright : (c) 2018 Harendra Kumar
24-- Copyright : (c) Roman Leshchinskiy 2008-2010
25-- Copyright : (c) The University of Glasgow, 2009
26-- Copyright : (c) Bjoern Hoehrmann 2008-2009
29-- Maintainer : harendra.kumar@gmail.com
30-- Stability : experimental
33-- Direct style re-implementation of CPS style stream in StreamK module. The
34-- symbol or suffix 'D' in this module denotes the "Direct" style. GHC is able
35-- to INLINE and fuse direct style better, providing better performance than
39-- import qualified Streamly.Streams.StreamD as D
42-- Some of the functions in this file have been adapted from the vector
43-- library, https://hackage.haskell.org/package/vector.
45module Streamly.Streams.StreamD
65 -- ** Specialized Generation
66 -- | Generate a monadic stream from a seed.
76 , enumerateFromStepIntegral
77 , enumerateFromIntegral
78 , enumerateFromThenIntegral
79 , enumerateFromToIntegral
80 , enumerateFromThenToIntegral
82 , enumerateFromStepNum
85 , enumerateFromToFractional
86 , enumerateFromThenToFractional
89 -- | Transform an input structure into a stream.
90 -- | Direct style stream does not support @fromFoldable@.
117 -- ** Specialized Folds
138 -- ** Flattening nested streams
141 , ConcatMapUState (..)
143 , ConcatUnfoldInterleaveState (..)
144 , concatUnfoldInterleave
145 , concatUnfoldRoundrobin
148 , InterleaveState(..)
152 , roundRobin -- interleaveFair?/ParallelFair
153 , interleaveFstThenConcat
181 -- | Transform a stream into another type.
190 -- ** By folding (scans)
256 -- * Transformation comprehensions
268 -- * UTF8 Encoding / Decoding transformations.
273 , decodeUtf8ArraysLenient
277import Control.Exception (Exception, SomeException)
278import Control.Monad (void)
279import Control.Monad.Catch (MonadCatch)
280import Control.Monad.IO.Class (MonadIO(..))
281import Control.Monad.Trans (MonadTrans(lift))
282import Data.Bits (shiftR, shiftL, (.|.), (.&.))
283#if __GLASGOW_HASKELL__ >= 801
284import Data.Functor.Identity (Identity)
286import Data.Maybe (fromJust, isJust)
287import Data.Word (Word32)
288import Foreign.Ptr (Ptr)
289import Foreign.Storable (Storable(..))
290import GHC.Base (assert, Char(..), unsafeChr, ord)
291import GHC.IO.Encoding.Failure (isSurrogate)
292import GHC.Types (SPEC(..))
293import GHC.Word (Word8(..))
294import System.IO.Unsafe (unsafePerformIO)
296 hiding (map, mapM, mapM_, repeat, foldr, last, take, filter,
297 takeWhile, drop, dropWhile, all, any, maximum, minimum, elem,
298 notElem, null, head, tail, zipWith, lookup, foldr1, sequence,
299 (!!), scanl, scanl1, concatMap, replicate, enumFromTo, concat,
302import qualified Control.Monad.Catch as MC
304import Streamly.Internal.Memory.Array.Types (Array(..))
305import Streamly.Internal.Data.Fold.Types (Fold(..))
306import Streamly.Internal.Data.Pipe.Types (Pipe(..), PipeState(..))
307import Streamly.Internal.Data.SVar (MonadAsync, defState, adaptState)
308import Streamly.Internal.Data.Unfold.Types (Unfold(..))
309import Streamly.Internal.Data.Strict (Tuple'(..))
311import Streamly.Streams.StreamD.Type
313import qualified Streamly.Internal.Data.Pipe.Types as Pipe
314import qualified Streamly.Internal.Memory.Array.Types as A
315import qualified Streamly.Memory.Ring as RB
316import qualified Streamly.Streams.StreamK as K
318import Foreign.Ptr (plusPtr)
319import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
320import Foreign.ForeignPtr (ForeignPtr, touchForeignPtr)
322------------------------------------------------------------------------------
324------------------------------------------------------------------------------
326-- | An empty 'Stream'.
327{-# INLINE_NORMAL nil #-}
328nil :: Monad m => Stream m a
329nil = Stream (\_ _ -> return Stop) ()
331-- | An empty 'Stream' with a side effect.
332{-# INLINE_NORMAL nilM #-}
333nilM :: Monad m => m b -> Stream m a
334nilM m = Stream (\_ _ -> m >> return Stop) ()
336{-# INLINE_NORMAL consM #-}
337consM :: Monad m => m a -> Stream m a -> Stream m a
338consM m (Stream step state) = Stream step1 Nothing
340 {-# INLINE_LATE step1 #-}
341 step1 _ Nothing = m >>= \x -> return $ Yield x (Just state)
342 step1 gst (Just st) = do
346 Yield a s -> Yield a (Just s)
347 Skip s -> Skip (Just s)
350-- XXX implement in terms of consM?
351-- cons x = consM (return x)
353-- | Can fuse but has O(n^2) complexity.
354{-# INLINE_NORMAL cons #-}
355cons :: Monad m => a -> Stream m a -> Stream m a
356cons x (Stream step state) = Stream step1 Nothing
358 {-# INLINE_LATE step1 #-}
359 step1 _ Nothing = return $ Yield x (Just state)
360 step1 gst (Just st) = do
364 Yield a s -> Yield a (Just s)
365 Skip s -> Skip (Just s)
368-------------------------------------------------------------------------------
370-------------------------------------------------------------------------------
372-- Does not fuse, has the same performance as the StreamK version.
373{-# INLINE_NORMAL uncons #-}
374uncons :: Monad m => Stream m a -> m (Maybe (a, Stream m a))
375uncons (UnStream step state) = go state
378 r <- step defState st
380 Yield x s -> return $ Just (x, Stream step s)
382 Stop -> return Nothing
384------------------------------------------------------------------------------
385-- Generation by unfold
386------------------------------------------------------------------------------
388{-# INLINE_NORMAL unfoldrM #-}
389unfoldrM :: Monad m => (s -> m (Maybe (a, s))) -> s -> Stream m a
390unfoldrM next state = Stream step state
392 {-# INLINE_LATE step #-}
396 Just (x, s) -> Yield x s
399{-# INLINE_LATE unfoldr #-}
400unfoldr :: Monad m => (s -> Maybe (a, s)) -> s -> Stream m a
401unfoldr f = unfoldrM (return . f)
403-- | Convert an 'Unfold' into a 'Stream' by supplying it a seed.
405{-# INLINE_NORMAL unfold #-}
406unfold :: Monad m => Unfold m a b -> a -> Stream m b
407unfold (Unfold ustep inject) seed = Stream step Nothing
409 {-# INLINE_LATE step #-}
410 step _ Nothing = inject seed >>= return . Skip . Just
411 step _ (Just st) = do
414 Yield x s -> Yield x (Just s)
415 Skip s -> Skip (Just s)
418------------------------------------------------------------------------------
419-- Specialized Generation
420------------------------------------------------------------------------------
422repeat :: Monad m => a -> Stream m a
423repeat x = Stream (\_ _ -> return $ Yield x ()) ()
425{-# INLINE_NORMAL replicateM #-}
426replicateM :: forall m a. Monad m => Int -> m a -> Stream m a
427replicateM n p = Stream step n
429 {-# INLINE_LATE step #-}
431 | i <= 0 = return Stop
434 return $ Yield x (i - 1)
436{-# INLINE_NORMAL replicate #-}
437replicate :: Monad m => Int -> a -> Stream m a
438replicate n x = replicateM n (return x)
440-- This would not work properly for floats, therefore we put an Integral
442-- | Can be used to enumerate unbounded integrals. This does not check for
443-- overflow or underflow for bounded integrals.
444{-# INLINE_NORMAL enumerateFromStepIntegral #-}
445enumerateFromStepIntegral :: (Integral a, Monad m) => a -> a -> Stream m a
446enumerateFromStepIntegral from stride =
447 from `seq` stride `seq` Stream step from
449 {-# INLINE_LATE step #-}
450 step _ !x = return $ Yield x $! (x + stride)
452-- We are assuming that "to" is constrained by the type to be within
454{-# INLINE enumerateFromToIntegral #-}
455enumerateFromToIntegral :: (Monad m, Integral a) => a -> a -> Stream m a
456enumerateFromToIntegral from to =
457 takeWhile (<= to) $ enumerateFromStepIntegral from 1
459{-# INLINE enumerateFromIntegral #-}
460enumerateFromIntegral :: (Monad m, Integral a, Bounded a) => a -> Stream m a
461enumerateFromIntegral from = enumerateFromToIntegral from maxBound
463data EnumState a = EnumInit | EnumYield a a a | EnumStop
465{-# INLINE_NORMAL enumerateFromThenToIntegralUp #-}
466enumerateFromThenToIntegralUp
467 :: (Monad m, Integral a)
468 => a -> a -> a -> Stream m a
469enumerateFromThenToIntegralUp from next to = Stream step EnumInit
471 {-# INLINE_LATE step #-}
477 else Yield from EnumStop
478 else -- from <= next <= to
479 let stride = next - from
480 in Skip $ EnumYield from stride (to - stride)
482 step _ (EnumYield x stride toMinus) =
485 then Yield x EnumStop
486 else Yield x $ EnumYield (x + stride) stride toMinus
488 step _ EnumStop = return Stop
490{-# INLINE_NORMAL enumerateFromThenToIntegralDn #-}
491enumerateFromThenToIntegralDn
492 :: (Monad m, Integral a)
493 => a -> a -> a -> Stream m a
494enumerateFromThenToIntegralDn from next to = Stream step EnumInit
496 {-# INLINE_LATE step #-}
498 return $ if to > next
501 else Yield from EnumStop
502 else -- from >= next >= to
503 let stride = next - from
504 in Skip $ EnumYield from stride (to - stride)
506 step _ (EnumYield x stride toMinus) =
509 then Yield x EnumStop
510 else Yield x $ EnumYield (x + stride) stride toMinus
512 step _ EnumStop = return Stop
514{-# INLINE_NORMAL enumerateFromThenToIntegral #-}
515enumerateFromThenToIntegral
516 :: (Monad m, Integral a)
517 => a -> a -> a -> Stream m a
518enumerateFromThenToIntegral from next to
519 | next >= from = enumerateFromThenToIntegralUp from next to
520 | otherwise = enumerateFromThenToIntegralDn from next to
522{-# INLINE_NORMAL enumerateFromThenIntegral #-}
523enumerateFromThenIntegral
524 :: (Monad m, Integral a, Bounded a)
525 => a -> a -> Stream m a
526enumerateFromThenIntegral from next =
528 then enumerateFromThenToIntegralUp from next maxBound
529 else enumerateFromThenToIntegralDn from next minBound
531-- For floating point numbers if the increment is less than the precision then
532-- it just gets lost. Therefore we cannot always increment it correctly by just
534-- 9007199254740992 + 1 + 1 :: Double => 9.007199254740992e15
535-- 9007199254740992 + 2 :: Double => 9.007199254740994e15
537-- Instead we accumulate the increment counter and compute the increment
538-- everytime before adding it to the starting number.
540-- This works for Integrals as well as floating point numbers, but
541-- enumerateFromStepIntegral is faster for integrals.
542{-# INLINE_NORMAL enumerateFromStepNum #-}
543enumerateFromStepNum :: (Monad m, Num a) => a -> a -> Stream m a
544enumerateFromStepNum from stride = Stream step 0
546 {-# INLINE_LATE step #-}
547 step _ !i = return $ (Yield $! (from + i * stride)) $! (i + 1)
549{-# INLINE_NORMAL numFrom #-}
550numFrom :: (Monad m, Num a) => a -> Stream m a
551numFrom from = enumerateFromStepNum from 1
553{-# INLINE_NORMAL numFromThen #-}
554numFromThen :: (Monad m, Num a) => a -> a -> Stream m a
555numFromThen from next = enumerateFromStepNum from (next - from)
557-- We cannot write a general function for Num. The only way to write code
558-- portable between the two is to use a 'Real' constraint and convert between
559-- Fractional and Integral using fromRational which is horribly slow.
560{-# INLINE_NORMAL enumerateFromToFractional #-}
561enumerateFromToFractional
562 :: (Monad m, Fractional a, Ord a)
563 => a -> a -> Stream m a
564enumerateFromToFractional from to =
565 takeWhile (<= to + 1 / 2) $ enumerateFromStepNum from 1
567{-# INLINE_NORMAL enumerateFromThenToFractional #-}
568enumerateFromThenToFractional
569 :: (Monad m, Fractional a, Ord a)
570 => a -> a -> a -> Stream m a
571enumerateFromThenToFractional from next to =
572 takeWhile predicate $ numFromThen from next
574 mid = (next - from) / 2
575 predicate | next >= from = (<= to + mid)
576 | otherwise = (>= to + mid)
578-------------------------------------------------------------------------------
579-- Generation by Conversion
580-------------------------------------------------------------------------------
582{-# INLINE_NORMAL fromIndicesM #-}
583fromIndicesM :: Monad m => (Int -> m a) -> Stream m a
584fromIndicesM gen = Stream step 0
586 {-# INLINE_LATE step #-}
589 return $ Yield x (i + 1)
591{-# INLINE fromIndices #-}
592fromIndices :: Monad m => (Int -> a) -> Stream m a
593fromIndices gen = fromIndicesM (return . gen)
595{-# INLINE_NORMAL generateM #-}
596generateM :: Monad m => Int -> (Int -> m a) -> Stream m a
597generateM n gen = n `seq` Stream step 0
599 {-# INLINE_LATE step #-}
600 step _ i | i < n = do
602 return $ Yield x (i + 1)
603 | otherwise = return Stop
605{-# INLINE generate #-}
606generate :: Monad m => Int -> (Int -> a) -> Stream m a
607generate n gen = generateM n (return . gen)
609-- XXX we need the MonadAsync constraint because of a rewrite rule.
610-- | Convert a list of monadic actions to a 'Stream'
611{-# INLINE_LATE fromListM #-}
612fromListM :: MonadAsync m => [m a] -> Stream m a
613fromListM = Stream step
615 {-# INLINE_LATE step #-}
616 step _ (m:ms) = m >>= \x -> return $ Yield x ms
617 step _ [] = return Stop
619{-# INLINE toStreamD #-}
620toStreamD :: (K.IsStream t, Monad m) => t m a -> Stream m a
621toStreamD = fromStreamK . K.toStream
623------------------------------------------------------------------------------
624-- Elimination by Folds
625------------------------------------------------------------------------------
627------------------------------------------------------------------------------
629------------------------------------------------------------------------------
631{-# INLINE_NORMAL foldr1 #-}
632foldr1 :: Monad m => (a -> a -> a) -> Stream m a -> m (Maybe a)
636 Nothing -> return Nothing
637 Just (h, t) -> fmap Just (foldr f h t)
639------------------------------------------------------------------------------
641------------------------------------------------------------------------------
643{-# INLINE_NORMAL foldlT #-}
644foldlT :: (Monad m, Monad (s m), MonadTrans s)
645 => (s m b -> a -> s m b) -> s m b -> Stream m a -> s m b
646foldlT fstep begin (Stream step state) = go SPEC begin state
649 r <- lift $ step defState st
651 Yield x s -> go SPEC (fstep acc x) s
652 Skip s -> go SPEC acc s
655-- Note, this is going to have horrible performance, because of the nature of
656-- the stream type (i.e. direct stream vs CPS). Its only for reference, it is
657-- likely be practically unusable.
658{-# INLINE_NORMAL foldlS #-}
660 => (Stream m b -> a -> Stream m b) -> Stream m b -> Stream m a -> Stream m b
661foldlS fstep begin (Stream step state) = Stream step' (Left (state, begin))
663 step' gst (Left (st, acc)) = do
664 r <- step (adaptState gst) st
666 Yield x s -> Skip (Left (s, fstep acc x))
667 Skip s -> Skip (Left (s, acc))
668 Stop -> Skip (Right acc)
670 step' gst (Right (Stream stp stt)) = do
671 r <- stp (adaptState gst) stt
673 Yield x s -> Yield x (Right (Stream stp s))
674 Skip s -> Skip (Right (Stream stp s))
677------------------------------------------------------------------------------
679------------------------------------------------------------------------------
681-- | Run a streaming composition, discard the results.
682{-# INLINE_LATE drain #-}
683drain :: Monad m => Stream m a -> m ()
684-- drain = foldrM (\_ xs -> xs) (return ())
685drain (Stream step state) = go SPEC state
688 r <- step defState st
690 Yield _ s -> go SPEC s
694{-# INLINE_NORMAL null #-}
695null :: Monad m => Stream m a -> m Bool
696null m = foldrM (\_ _ -> return False) (return True) m
698{-# INLINE_NORMAL head #-}
699head :: Monad m => Stream m a -> m (Maybe a)
700head m = foldrM (\x _ -> return (Just x)) (return Nothing) m
702-- Does not fuse, has the same performance as the StreamK version.
703{-# INLINE_NORMAL tail #-}
704tail :: Monad m => Stream m a -> m (Maybe (Stream m a))
705tail (UnStream step state) = go state
708 r <- step defState st
710 Yield _ s -> return (Just $ Stream step s)
712 Stop -> return Nothing
714-- XXX will it fuse? need custom impl?
715{-# INLINE_NORMAL last #-}
716last :: Monad m => Stream m a -> m (Maybe a)
717last = foldl' (\_ y -> Just y) Nothing
719{-# INLINE_NORMAL elem #-}
720elem :: (Monad m, Eq a) => a -> Stream m a -> m Bool
721-- elem e m = foldrM (\x xs -> if x == e then return True else xs) (return False) m
722elem e (Stream step state) = go state
725 r <- step defState st
728 | x == e -> return True
733{-# INLINE_NORMAL notElem #-}
734notElem :: (Monad m, Eq a) => a -> Stream m a -> m Bool
735notElem e s = fmap not (elem e s)
737{-# INLINE_NORMAL all #-}
738all :: Monad m => (a -> Bool) -> Stream m a -> m Bool
739-- all p m = foldrM (\x xs -> if p x then xs else return False) (return True) m
740all p (Stream step state) = go state
743 r <- step defState st
747 | otherwise -> return False
751{-# INLINE_NORMAL any #-}
752any :: Monad m => (a -> Bool) -> Stream m a -> m Bool
753-- any p m = foldrM (\x xs -> if p x then return True else xs) (return False) m
754any p (Stream step state) = go state
757 r <- step defState st
765{-# INLINE_NORMAL maximum #-}
766maximum :: (Monad m, Ord a) => Stream m a -> m (Maybe a)
767maximum (Stream step state) = go Nothing state
770 r <- step defState st
772 Yield x s -> go (Just x) s
773 Skip s -> go Nothing s
774 Stop -> return Nothing
775 go (Just acc) st = do
776 r <- step defState st
779 | acc <= x -> go (Just x) s
780 | otherwise -> go (Just acc) s
781 Skip s -> go (Just acc) s
782 Stop -> return (Just acc)
784{-# INLINE_NORMAL maximumBy #-}
785maximumBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> m (Maybe a)
786maximumBy cmp (Stream step state) = go Nothing state
789 r <- step defState st
791 Yield x s -> go (Just x) s
792 Skip s -> go Nothing s
793 Stop -> return Nothing
794 go (Just acc) st = do
795 r <- step defState st
797 Yield x s -> case cmp acc x of
798 GT -> go (Just acc) s
800 Skip s -> go (Just acc) s
801 Stop -> return (Just acc)
803{-# INLINE_NORMAL minimum #-}
804minimum :: (Monad m, Ord a) => Stream m a -> m (Maybe a)
805minimum (Stream step state) = go Nothing state
808 r <- step defState st
810 Yield x s -> go (Just x) s
811 Skip s -> go Nothing s
812 Stop -> return Nothing
813 go (Just acc) st = do
814 r <- step defState st
817 | acc <= x -> go (Just acc) s
818 | otherwise -> go (Just x) s
819 Skip s -> go (Just acc) s
820 Stop -> return (Just acc)
822{-# INLINE_NORMAL minimumBy #-}
823minimumBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> m (Maybe a)
824minimumBy cmp (Stream step state) = go Nothing state
827 r <- step defState st
829 Yield x s -> go (Just x) s
830 Skip s -> go Nothing s
831 Stop -> return Nothing
832 go (Just acc) st = do
833 r <- step defState st
835 Yield x s -> case cmp acc x of
838 Skip s -> go (Just acc) s
839 Stop -> return (Just acc)
841{-# INLINE_NORMAL (!!) #-}
842(!!) :: (Monad m) => Stream m a -> Int -> m (Maybe a)
843(Stream step state) !! i = go i state
846 r <- step defState st
848 Yield x s | n < 0 -> return Nothing
849 | n == 0 -> return $ Just x
850 | otherwise -> go (n - 1) s
852 Stop -> return Nothing
854{-# INLINE_NORMAL lookup #-}
855lookup :: (Monad m, Eq a) => a -> Stream m (a, b) -> m (Maybe b)
856lookup e m = foldrM (\(a, b) xs -> if e == a then return (Just b) else xs)
859{-# INLINE_NORMAL findM #-}
860findM :: Monad m => (a -> m Bool) -> Stream m a -> m (Maybe a)
861findM p m = foldrM (\x xs -> p x >>= \r -> if r then return (Just x) else xs)
865find :: Monad m => (a -> Bool) -> Stream m a -> m (Maybe a)
866find p = findM (return . p)
868{-# INLINE_NORMAL findIndices #-}
869findIndices :: Monad m => (a -> Bool) -> Stream m a -> Stream m Int
870findIndices p (Stream step state) = Stream step' (state, 0)
872 {-# INLINE_LATE step' #-}
873 step' gst (st, i) = do
874 r <- step (adaptState gst) st
876 Yield x s -> if p x then Yield i (s, i+1) else Skip (s, i+1)
877 Skip s -> Skip (s, i+1)
880{-# INLINE toListRev #-}
881toListRev :: Monad m => Stream m a -> m [a]
882toListRev = foldl' (flip (:)) []
884-- We can implement reverse as:
886-- > reverse = foldlS (flip cons) nil
888-- However, this implementation is unusable because of the horrible performance
889-- of cons. So we just convert it to a list first and then stream from the
892-- XXX Maybe we can use an Array instead of a list here?
893{-# INLINE_NORMAL reverse #-}
894reverse :: Monad m => Stream m a -> Stream m a
895reverse m = Stream step Nothing
897 {-# INLINE_LATE step #-}
900 return $ Skip (Just xs)
901 step _ (Just (x:xs)) = return $ Yield x (Just xs)
902 step _ (Just []) = return Stop
904-- Much faster reverse for Storables
905{-# INLINE_NORMAL reverse' #-}
906reverse' :: forall m a. (MonadIO m, Storable a) => Stream m a -> Stream m a
908-- This commented implementation copies the whole stream into one single array
909-- and then streams from that array, this is 3-4x faster than the chunked code
910-- that follows. Though this could be problematic due to unbounded large
911-- allocations. We need to figure out why the chunked code is slower and if we
912-- can optimize the chunked code to work as fast as this one. It may be a
914import Foreign.ForeignPtr (touchForeignPtr)
915import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
916import Foreign.Ptr (Ptr, plusPtr)
917reverse' m = Stream step Nothing
919 {-# INLINE_LATE step #-}
921 arr <- A.fromStreamD m
922 let p = aEnd arr `plusPtr` negate (sizeOf (undefined :: a))
923 return $ Skip $ Just (aStart arr, p)
925 step _ (Just (start, p)) | p < unsafeForeignPtrToPtr start = return Stop
927 step _ (Just (start, p)) = do
928 let !x = A.unsafeInlineIO $ do
930 touchForeignPtr start
932 next = p `plusPtr` negate (sizeOf (undefined :: a))
933 return $ Yield x (Just (start, next))
940 $ A.fromStreamDArraysOf A.defaultChunkSize m
943------------------------------------------------------------------------------
945------------------------------------------------------------------------------
947{-# INLINE_NORMAL splitSuffixBy' #-}
948splitSuffixBy' :: Monad m
949 => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
950splitSuffixBy' predicate f (Stream step state) =
951 Stream (stepOuter f) (Just state)
955 {-# INLINE_LATE stepOuter #-}
956 stepOuter (Fold fstep initial done) gst (Just st) = do
957 res <- step (adaptState gst) st
963 then done acc' >>= \val -> return $ Yield val (Just s)
966 Skip s -> return $ Skip $ Just s
972 res <- step (adaptState gst) stt
977 then done acc' >>= \val -> return $ Yield val (Just s)
979 Skip s -> go SPEC s acc
980 Stop -> done acc >>= \val -> return $ Yield val Nothing
982 stepOuter _ _ Nothing = return Stop
984{-# INLINE_NORMAL groupsBy #-}
990groupsBy cmp f (Stream step state) = Stream (stepOuter f) (Just state, Nothing)
994 {-# INLINE_LATE stepOuter #-}
995 stepOuter (Fold fstep initial done) gst (Just st, Nothing) = do
996 res <- step (adaptState gst) st
1003 Skip s -> return $ Skip $ (Just s, Nothing)
1008 go !_ prev stt !acc = do
1009 res <- step (adaptState gst) stt
1016 else done acc >>= \r -> return $ Yield r (Just s, Just x)
1017 Skip s -> go SPEC prev s acc
1018 Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1020 stepOuter (Fold fstep initial done) gst (Just st, Just prev) = do
1022 acc' <- fstep acc prev
1027 -- XXX code duplicated from the previous equation
1029 res <- step (adaptState gst) stt
1036 else done acc >>= \r -> return $ Yield r (Just s, Just x)
1037 Skip s -> go SPEC s acc
1038 Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1040 stepOuter _ _ (Nothing,_) = return Stop
1042{-# INLINE_NORMAL groupsRollingBy #-}
1043groupsRollingBy :: Monad m
1048groupsRollingBy cmp f (Stream step state) =
1049 Stream (stepOuter f) (Just state, Nothing)
1052 {-# INLINE_LATE stepOuter #-}
1053 stepOuter (Fold fstep initial done) gst (Just st, Nothing) = do
1054 res <- step (adaptState gst) st
1061 Skip s -> return $ Skip $ (Just s, Nothing)
1065 go !_ prev stt !acc = do
1066 res <- step (adaptState gst) stt
1074 done acc >>= \r -> return $ Yield r (Just s, Just x)
1075 Skip s -> go SPEC prev s acc
1076 Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1078 stepOuter (Fold fstep initial done) gst (Just st, Just prev') = do
1080 acc' <- fstep acc prev'
1081 go SPEC prev' st acc'
1084 go !_ prevv stt !acc = do
1085 res <- step (adaptState gst) stt
1092 else done acc >>= \r -> return $ Yield r (Just s, Just x)
1093 Skip s -> go SPEC prevv s acc
1094 Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1096 stepOuter _ _ (Nothing, _) = return Stop
1098{-# INLINE_NORMAL splitBy #-}
1099splitBy :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
1100splitBy predicate f (Stream step state) = Stream (step' f) (Just state)
1104 {-# INLINE_LATE step' #-}
1105 step' (Fold fstep initial done) gst (Just st) = initial >>= go SPEC st
1110 res <- step (adaptState gst) stt
1114 then done acc >>= \r -> return $ Yield r (Just s)
1118 Skip s -> go SPEC s acc
1119 Stop -> done acc >>= \r -> return $ Yield r Nothing
1121 step' _ _ Nothing = return Stop
1123-- XXX requires -funfolding-use-threshold=150 in lines-unlines benchmark
1124{-# INLINE_NORMAL splitSuffixBy #-}
1125splitSuffixBy :: Monad m
1126 => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
1127splitSuffixBy predicate f (Stream step state) = Stream (step' f) (Just state)
1131 {-# INLINE_LATE step' #-}
1132 step' (Fold fstep initial done) gst (Just st) = do
1133 res <- step (adaptState gst) st
1138 then done acc >>= \val -> return $ Yield val (Just s)
1143 Skip s -> return $ Skip $ Just s
1149 res <- step (adaptState gst) stt
1153 then done acc >>= \r -> return $ Yield r (Just s)
1157 Skip s -> go SPEC s acc
1158 Stop -> done acc >>= \r -> return $ Yield r Nothing
1160 step' _ _ Nothing = return Stop
1162{-# INLINE_NORMAL wordsBy #-}
1163wordsBy :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
1164wordsBy predicate f (Stream step state) = Stream (stepOuter f) (Just state)
1168 {-# INLINE_LATE stepOuter #-}
1169 stepOuter (Fold fstep initial done) gst (Just st) = do
1170 res <- step (adaptState gst) st
1174 then return $ Skip (Just s)
1180 Skip s -> return $ Skip $ Just s
1186 res <- step (adaptState gst) stt
1190 then done acc >>= \r -> return $ Yield r (Just s)
1194 Skip s -> go SPEC s acc
1195 Stop -> done acc >>= \r -> return $ Yield r Nothing
1197 stepOuter _ _ Nothing = return Stop
1199-- String search algorithms:
1200-- http://www-igm.univ-mlv.fr/~lecroq/string/index.html
1203-- TODO can we unify the splitting operations using a splitting configuration
1204-- like in the split package.
1206data SplitStyle = Infix | Suffix | Prefix deriving (Eq, Show)
1208data SplitOptions = SplitOptions
1209 { style :: SplitStyle
1210 , withSep :: Bool -- ^ keep the separators in output
1211 -- , compact :: Bool -- ^ treat multiple consecutive separators as one
1212 -- , trimHead :: Bool -- ^ drop blank at head
1213 -- , trimTail :: Bool -- ^ drop blank at tail
1217data SplitOnState s a =
1222 | GO_KARP_RABIN s !(RB.Ring a) !(Ptr a)
1225{-# INLINE_NORMAL splitOn #-}
1227 :: forall m a b. (MonadIO m, Storable a, Enum a, Eq a)
1232splitOn patArr@Array{..} (Fold fstep initial done) (Stream step state) =
1233 Stream stepOuter GO_START
1237 patLen = A.length patArr
1238 maxIndex = patLen - 1
1239 elemBits = sizeOf (undefined :: a) * 8
1241 {-# INLINE_LATE stepOuter #-}
1242 stepOuter _ GO_START =
1244 then return $ Skip $ GO_EMPTY_PAT state
1247 r <- liftIO $ (A.unsafeIndexIO patArr 0)
1248 return $ Skip $ GO_SINGLE_PAT state r
1249 else if sizeOf (undefined :: a) * patLen
1250 <= sizeOf (undefined :: Word)
1251 then return $ Skip $ GO_SHORT_PAT state
1253 (rb, rhead) <- liftIO $ RB.new patLen
1254 return $ Skip $ GO_KARP_RABIN state rb rhead
1256 stepOuter gst (GO_SINGLE_PAT stt pat) = initial >>= go SPEC stt
1261 res <- step (adaptState gst) st
1267 return $ Yield r (GO_SINGLE_PAT s pat)
1268 else fstep acc x >>= go SPEC s
1269 Skip s -> go SPEC s acc
1270 Stop -> done acc >>= \r -> return $ Yield r GO_DONE
1272 stepOuter gst (GO_SHORT_PAT stt) = initial >>= go0 SPEC 0 (0 :: Word) stt
1277 mask = (1 `shiftL` (elemBits * patLen)) - 1
1279 addToWord wrd a = (wrd `shiftL` elemBits) .|. fromIntegral (fromEnum a)
1282 patWord = mask .&. A.foldl' addToWord 0 patArr
1284 go0 !_ !idx wrd st !acc = do
1285 res <- step (adaptState gst) st
1288 let wrd' = addToWord wrd x
1291 if wrd' .&. mask == patWord
1294 return $ Yield r (GO_SHORT_PAT s)
1295 else go1 SPEC wrd' s acc
1296 else go0 SPEC (idx + 1) wrd' s acc
1297 Skip s -> go0 SPEC idx wrd s acc
1300 then go2 wrd idx acc
1302 done acc' >>= \r -> return $ Yield r GO_DONE
1305 go1 !_ wrd st !acc = do
1306 res <- step (adaptState gst) st
1309 let wrd' = addToWord wrd x
1310 old = (mask .&. wrd) `shiftR` (elemBits * (patLen - 1))
1311 acc' <- fstep acc (toEnum $ fromIntegral old)
1312 if wrd' .&. mask == patWord
1313 then done acc' >>= \r -> return $ Yield r (GO_SHORT_PAT s)
1314 else go1 SPEC wrd' s acc'
1315 Skip s -> go1 SPEC wrd s acc
1317 acc' <- go2 wrd patLen acc
1318 done acc' >>= \r -> return $ Yield r GO_DONE
1320 go2 !wrd !n !acc | n > 0 = do
1321 let old = (mask .&. wrd) `shiftR` (elemBits * (n - 1))
1322 fstep acc (toEnum $ fromIntegral old) >>= go2 wrd (n - 1)
1323 go2 _ _ acc = return acc
1325 stepOuter gst (GO_KARP_RABIN stt rb rhead) = do
1326 initial >>= go0 SPEC 0 rhead stt
1330 k = 2891336453 :: Word32
1332 addCksum cksum a = cksum * k + fromIntegral (fromEnum a)
1333 deltaCksum cksum old new =
1334 addCksum cksum new - coeff * fromIntegral (fromEnum old)
1336 -- XXX shall we use a random starting hash or 1 instead of 0?
1337 patHash = A.foldl' addCksum 0 patArr
1340 go0 !_ !idx !rh st !acc = do
1341 res <- step (adaptState gst) st
1344 rh' <- liftIO $ RB.unsafeInsert rb rh x
1347 let fold = RB.unsafeFoldRing (RB.ringBound rb)
1348 let !ringHash = fold addCksum 0 rb
1349 if ringHash == patHash
1350 then go2 SPEC ringHash rh' s acc
1351 else go1 SPEC ringHash rh' s acc
1352 else go0 SPEC (idx + 1) rh' s acc
1353 Skip s -> go0 SPEC idx rh s acc
1355 !acc' <- if idx /= 0
1356 then RB.unsafeFoldRingM rh fstep acc rb
1358 done acc' >>= \r -> return $ Yield r GO_DONE
1360 -- XXX Theoretically this code can do 4 times faster if GHC generates
1361 -- optimal code. If we use just "(cksum' == patHash)" condition it goes
1362 -- 4x faster, as soon as we add the "RB.unsafeEqArray rb v" condition
1363 -- the generated code changes drastically and becomes 4x slower. Need
1364 -- to investigate what is going on with GHC.
1366 go1 !_ !cksum !rh st !acc = do
1367 res <- step (adaptState gst) st
1370 old <- liftIO $ peek rh
1371 let cksum' = deltaCksum cksum old x
1372 acc' <- fstep acc old
1374 if (cksum' == patHash)
1376 rh' <- liftIO (RB.unsafeInsert rb rh x)
1377 go2 SPEC cksum' rh' s acc'
1379 rh' <- liftIO (RB.unsafeInsert rb rh x)
1380 go1 SPEC cksum' rh' s acc'
1381 Skip s -> go1 SPEC cksum rh s acc
1383 acc' <- RB.unsafeFoldRingFullM rh fstep acc rb
1384 done acc' >>= \r -> return $ Yield r GO_DONE
1386 go2 !_ !cksum' !rh' s !acc' = do
1387 if RB.unsafeEqArray rb rh' patArr
1390 return $ Yield r (GO_KARP_RABIN s rb rhead)
1391 else go1 SPEC cksum' rh' s acc'
1393 stepOuter gst (GO_EMPTY_PAT st) = do
1394 res <- step (adaptState gst) st
1399 done acc' >>= \r -> return $ Yield r (GO_EMPTY_PAT s)
1400 Skip s -> return $ Skip (GO_EMPTY_PAT s)
1403 stepOuter _ GO_DONE = return Stop
1405{-# INLINE_NORMAL splitSuffixOn #-}
1407 :: forall m a b. (MonadIO m, Storable a, Enum a, Eq a)
1413splitSuffixOn withSep patArr@Array{..} (Fold fstep initial done)
1414 (Stream step state) =
1415 Stream stepOuter GO_START
1419 patLen = A.length patArr
1420 maxIndex = patLen - 1
1421 elemBits = sizeOf (undefined :: a) * 8
1423 {-# INLINE_LATE stepOuter #-}
1424 stepOuter _ GO_START =
1426 then return $ Skip $ GO_EMPTY_PAT state
1429 r <- liftIO $ (A.unsafeIndexIO patArr 0)
1430 return $ Skip $ GO_SINGLE_PAT state r
1431 else if sizeOf (undefined :: a) * patLen
1432 <= sizeOf (undefined :: Word)
1433 then return $ Skip $ GO_SHORT_PAT state
1435 (rb, rhead) <- liftIO $ RB.new patLen
1436 return $ Skip $ GO_KARP_RABIN state rb rhead
1438 stepOuter gst (GO_SINGLE_PAT stt pat) = do
1439 -- This first part is the only difference between splitOn and
1441 -- If the last element is a separator do not issue a blank segment.
1442 res <- step (adaptState gst) stt
1448 acc' <- if withSep then fstep acc x else return acc
1449 done acc' >>= \r -> return $ Yield r (GO_SINGLE_PAT s pat)
1450 else fstep acc x >>= go SPEC s
1451 Skip s -> return $ Skip $ (GO_SINGLE_PAT s pat)
1456 -- This is identical for splitOn and splitSuffixOn
1458 res <- step (adaptState gst) st
1463 acc' <- if withSep then fstep acc x else return acc
1465 return $ Yield r (GO_SINGLE_PAT s pat)
1466 else fstep acc x >>= go SPEC s
1467 Skip s -> go SPEC s acc
1468 Stop -> done acc >>= \r -> return $ Yield r GO_DONE
1470 stepOuter gst (GO_SHORT_PAT stt) = do
1472 -- Call "initial" only if the stream yields an element, otherwise we
1473 -- may call "initial" but never yield anything. initial may produce a
1474 -- side effect, therefore we will end up doing and discard a side
1479 res <- step (adaptState gst) stt
1483 let wrd' = addToWord wrd x
1484 acc' <- if withSep then fstep acc x else return acc
1487 if wrd' .&. mask == patWord
1488 then done acc' >>= \r -> return $ Yield r (GO_SHORT_PAT s)
1489 else go0 SPEC (idx + 1) wrd' s acc'
1490 else go0 SPEC (idx + 1) wrd' s acc'
1491 Skip s -> return $ Skip (GO_SHORT_PAT s)
1497 mask = (1 `shiftL` (elemBits * patLen)) - 1
1499 addToWord wrd a = (wrd `shiftL` elemBits) .|. fromIntegral (fromEnum a)
1502 patWord = mask .&. A.foldl' addToWord 0 patArr
1504 go0 !_ !idx wrd st !acc = do
1505 res <- step (adaptState gst) st
1508 let wrd' = addToWord wrd x
1509 acc' <- if withSep then fstep acc x else return acc
1512 if wrd' .&. mask == patWord
1515 return $ Yield r (GO_SHORT_PAT s)
1516 else go1 SPEC wrd' s acc'
1517 else go0 SPEC (idx + 1) wrd' s acc'
1518 Skip s -> go0 SPEC idx wrd s acc
1520 if (idx == maxIndex) && (wrd .&. mask == patWord)
1523 acc' <- if idx /= 0 && not withSep
1524 then go2 wrd idx acc
1526 done acc' >>= \r -> return $ Yield r GO_DONE
1529 go1 !_ wrd st !acc = do
1530 res <- step (adaptState gst) st
1533 let wrd' = addToWord wrd x
1534 old = (mask .&. wrd) `shiftR` (elemBits * (patLen - 1))
1537 else fstep acc (toEnum $ fromIntegral old)
1538 if wrd' .&. mask == patWord
1539 then done acc' >>= \r -> return $ Yield r (GO_SHORT_PAT s)
1540 else go1 SPEC wrd' s acc'
1541 Skip s -> go1 SPEC wrd s acc
1543 -- If the last sequence is a separator do not issue a blank
1545 if wrd .&. mask == patWord
1550 else go2 wrd patLen acc
1551 done acc' >>= \r -> return $ Yield r GO_DONE
1553 go2 !wrd !n !acc | n > 0 = do
1554 let old = (mask .&. wrd) `shiftR` (elemBits * (n - 1))
1555 fstep acc (toEnum $ fromIntegral old) >>= go2 wrd (n - 1)
1556 go2 _ _ acc = return acc
1558 stepOuter gst (GO_KARP_RABIN stt rb rhead) = do
1560 res <- step (adaptState gst) stt
1564 acc' <- if withSep then fstep acc x else return acc
1565 rh' <- liftIO (RB.unsafeInsert rb rhead x)
1568 let fold = RB.unsafeFoldRing (RB.ringBound rb)
1569 let !ringHash = fold addCksum 0 rb
1570 if ringHash == patHash
1571 then go2 SPEC ringHash rh' s acc'
1572 else go0 SPEC (idx + 1) rh' s acc'
1573 else go0 SPEC (idx + 1) rh' s acc'
1574 Skip s -> return $ Skip (GO_KARP_RABIN s rb rhead)
1579 k = 2891336453 :: Word32
1581 addCksum cksum a = cksum * k + fromIntegral (fromEnum a)
1582 deltaCksum cksum old new =
1583 addCksum cksum new - coeff * fromIntegral (fromEnum old)
1585 -- XXX shall we use a random starting hash or 1 instead of 0?
1586 patHash = A.foldl' addCksum 0 patArr
1589 go0 !_ !idx !rh st !acc = do
1590 res <- step (adaptState gst) st
1593 acc' <- if withSep then fstep acc x else return acc
1594 rh' <- liftIO (RB.unsafeInsert rb rh x)
1597 let fold = RB.unsafeFoldRing (RB.ringBound rb)
1598 let !ringHash = fold addCksum 0 rb
1599 if ringHash == patHash
1600 then go2 SPEC ringHash rh' s acc'
1601 else go1 SPEC ringHash rh' s acc'
1602 else go0 SPEC (idx + 1) rh' s acc'
1603 Skip s -> go0 SPEC idx rh s acc
1605 -- do not issue a blank segment when we end at pattern
1606 if (idx == maxIndex) && RB.unsafeEqArray rb rh patArr
1609 !acc' <- if idx /= 0 && not withSep
1610 then RB.unsafeFoldRingM rh fstep acc rb
1612 done acc' >>= \r -> return $ Yield r GO_DONE
1614 -- XXX Theoretically this code can do 4 times faster if GHC generates
1615 -- optimal code. If we use just "(cksum' == patHash)" condition it goes
1616 -- 4x faster, as soon as we add the "RB.unsafeEqArray rb v" condition
1617 -- the generated code changes drastically and becomes 4x slower. Need
1618 -- to investigate what is going on with GHC.
1620 go1 !_ !cksum !rh st !acc = do
1621 res <- step (adaptState gst) st
1624 old <- liftIO $ peek rh
1625 let cksum' = deltaCksum cksum old x
1630 if (cksum' == patHash)
1632 rh' <- liftIO (RB.unsafeInsert rb rh x)
1633 go2 SPEC cksum' rh' s acc'
1635 rh' <- liftIO (RB.unsafeInsert rb rh x)
1636 go1 SPEC cksum' rh' s acc'
1637 Skip s -> go1 SPEC cksum rh s acc
1639 if RB.unsafeEqArray rb rh patArr
1644 else RB.unsafeFoldRingFullM rh fstep acc rb
1645 done acc' >>= \r -> return $ Yield r GO_DONE
1647 go2 !_ !cksum' !rh' s !acc' = do
1648 if RB.unsafeEqArray rb rh' patArr
1651 return $ Yield r (GO_KARP_RABIN s rb rhead)
1652 else go1 SPEC cksum' rh' s acc'
1654 stepOuter gst (GO_EMPTY_PAT st) = do
1655 res <- step (adaptState gst) st
1660 done acc' >>= \r -> return $ Yield r (GO_EMPTY_PAT s)
1661 Skip s -> return $ Skip (GO_EMPTY_PAT s)
1664 stepOuter _ GO_DONE = return Stop
1666data SplitState s arr
1668 | SplitBuffering s arr
1669 | SplitSplitting s arr
1670 | SplitYielding arr (SplitState s arr)
1673-- XXX An alternative approach would be to use a partial fold (Fold m a b) to
1674-- split using a splitBy like combinator. The Fold would consume upto the
1675-- separator and return any leftover which can then be fed to the next fold.
1677-- We can revisit this once we have partial folds/parsers.
1679-- | Performs infix separator style splitting.
1680{-# INLINE_NORMAL splitInnerBy #-}
1683 => (f a -> m (f a, Maybe (f a))) -- splitter
1684 -> (f a -> f a -> m (f a)) -- joiner
1687splitInnerBy splitter joiner (Stream step1 state1) =
1688 (Stream step (SplitInitial state1))
1692 {-# INLINE_LATE step #-}
1693 step gst (SplitInitial st) = do
1697 (x1, mx2) <- splitter x
1698 return $ case mx2 of
1699 Nothing -> Skip (SplitBuffering s x1)
1700 Just x2 -> Skip (SplitYielding x1 (SplitSplitting s x2))
1701 Skip s -> return $ Skip (SplitInitial s)
1702 Stop -> return $ Stop
1704 step gst (SplitBuffering st buf) = do
1708 (x1, mx2) <- splitter x
1709 buf' <- joiner buf x1
1710 return $ case mx2 of
1711 Nothing -> Skip (SplitBuffering s buf')
1712 Just x2 -> Skip (SplitYielding buf' (SplitSplitting s x2))
1713 Skip s -> return $ Skip (SplitBuffering s buf)
1714 Stop -> return $ Skip (SplitYielding buf SplitFinishing)
1716 step _ (SplitSplitting st buf) = do
1717 (x1, mx2) <- splitter buf
1718 return $ case mx2 of
1719 Nothing -> Skip $ SplitBuffering st x1
1720 Just x2 -> Skip $ SplitYielding x1 (SplitSplitting st x2)
1722 step _ (SplitYielding x next) = return $ Yield x next
1723 step _ SplitFinishing = return $ Stop
1725-- | Performs infix separator style splitting.
1726{-# INLINE_NORMAL splitInnerBySuffix #-}
1728 :: (Monad m, Eq (f a), Monoid (f a))
1729 => (f a -> m (f a, Maybe (f a))) -- splitter
1730 -> (f a -> f a -> m (f a)) -- joiner
1733splitInnerBySuffix splitter joiner (Stream step1 state1) =
1734 (Stream step (SplitInitial state1))
1738 {-# INLINE_LATE step #-}
1739 step gst (SplitInitial st) = do
1743 (x1, mx2) <- splitter x
1744 return $ case mx2 of
1745 Nothing -> Skip (SplitBuffering s x1)
1746 Just x2 -> Skip (SplitYielding x1 (SplitSplitting s x2))
1747 Skip s -> return $ Skip (SplitInitial s)
1748 Stop -> return $ Stop
1750 step gst (SplitBuffering st buf) = do
1754 (x1, mx2) <- splitter x
1755 buf' <- joiner buf x1
1756 return $ case mx2 of
1757 Nothing -> Skip (SplitBuffering s buf')
1758 Just x2 -> Skip (SplitYielding buf' (SplitSplitting s x2))
1759 Skip s -> return $ Skip (SplitBuffering s buf)
1763 else Skip (SplitYielding buf SplitFinishing)
1765 step _ (SplitSplitting st buf) = do
1766 (x1, mx2) <- splitter buf
1767 return $ case mx2 of
1768 Nothing -> Skip $ SplitBuffering st x1
1769 Just x2 -> Skip $ SplitYielding x1 (SplitSplitting st x2)
1771 step _ (SplitYielding x next) = return $ Yield x next
1772 step _ SplitFinishing = return $ Stop
1774------------------------------------------------------------------------------
1776------------------------------------------------------------------------------
1778{-# INLINE_NORMAL isPrefixOf #-}
1779isPrefixOf :: (Eq a, Monad m) => Stream m a -> Stream m a -> m Bool
1780isPrefixOf (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)
1782 go (sa, sb, Nothing) = do
1783 r <- stepa defState sa
1785 Yield x sa' -> go (sa', sb, Just x)
1786 Skip sa' -> go (sa', sb, Nothing)
1789 go (sa, sb, Just x) = do
1790 r <- stepb defState sb
1794 then go (sa, sb', Nothing)
1796 Skip sb' -> go (sa, sb', Just x)
1797 Stop -> return False
1799{-# INLINE_NORMAL isSubsequenceOf #-}
1800isSubsequenceOf :: (Eq a, Monad m) => Stream m a -> Stream m a -> m Bool
1801isSubsequenceOf (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)
1803 go (sa, sb, Nothing) = do
1804 r <- stepa defState sa
1806 Yield x sa' -> go (sa', sb, Just x)
1807 Skip sa' -> go (sa', sb, Nothing)
1810 go (sa, sb, Just x) = do
1811 r <- stepb defState sb
1815 then go (sa, sb', Nothing)
1816 else go (sa, sb', Just x)
1817 Skip sb' -> go (sa, sb', Just x)
1818 Stop -> return False
1820{-# INLINE_NORMAL stripPrefix #-}
1823 => Stream m a -> Stream m a -> m (Maybe (Stream m a))
1824stripPrefix (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)
1826 go (sa, sb, Nothing) = do
1827 r <- stepa defState sa
1829 Yield x sa' -> go (sa', sb, Just x)
1830 Skip sa' -> go (sa', sb, Nothing)
1831 Stop -> return $ Just (Stream stepb sb)
1833 go (sa, sb, Just x) = do
1834 r <- stepb defState sb
1838 then go (sa, sb', Nothing)
1840 Skip sb' -> go (sa, sb', Just x)
1841 Stop -> return Nothing
1843------------------------------------------------------------------------------
1845------------------------------------------------------------------------------
1847-- | Execute a monadic action for each element of the 'Stream'
1848{-# INLINE_NORMAL mapM_ #-}
1849mapM_ :: Monad m => (a -> m b) -> Stream m a -> m ()
1850mapM_ m = drain . mapM m
1852-------------------------------------------------------------------------------
1853-- Stream transformations using Unfolds
1854-------------------------------------------------------------------------------
1856-- Define a unique structure to use in inspection testing
1857data ConcatMapUState o i =
1859 | ConcatMapUInner o i
1861-- | @concatMapU unfold stream@ uses @unfold@ to map the input stream elements
1862-- to streams and then flattens the generated streams into a single output
1865-- This is like 'concatMap' but uses an unfold with an explicit state to
1866-- generate the stream instead of a 'Stream' type generator. This allows better
1867-- optimization via fusion. This can be many times more efficient than
1870{-# INLINE_NORMAL concatMapU #-}
1871concatMapU :: Monad m => Unfold m a b -> Stream m a -> Stream m b
1872concatMapU (Unfold istep inject) (Stream ostep ost) =
1873 Stream step (ConcatMapUOuter ost)
1875 {-# INLINE_LATE step #-}
1876 step gst (ConcatMapUOuter o) = do
1877 r <- ostep (adaptState gst) o
1881 i `seq` return (Skip (ConcatMapUInner o' i))
1882 Skip o' -> return $ Skip (ConcatMapUOuter o')
1883 Stop -> return $ Stop
1885 step _ (ConcatMapUInner o i) = do
1888 Yield x i' -> Yield x (ConcatMapUInner o i')
1889 Skip i' -> Skip (ConcatMapUInner o i')
1890 Stop -> Skip (ConcatMapUOuter o)
1892data ConcatUnfoldInterleaveState o i =
1893 ConcatUnfoldInterleaveOuter o [i]
1894 | ConcatUnfoldInterleaveInner o [i]
1895 | ConcatUnfoldInterleaveInnerL [i] [i]
1896 | ConcatUnfoldInterleaveInnerR [i] [i]
1898-- XXX use arrays to store state instead of lists.
1899-- XXX In general we can use different scheduling strategies e.g. how to
1900-- schedule the outer vs inner loop or assigning weights to different streams
1901-- or outer and inner loops.
1903-- After a yield, switch to the next stream. Do not switch streams on Skip.
1904-- Yield from outer stream switches to the inner stream.
1906-- There are two choices here, (1) exhaust the outer stream first and then
1907-- start yielding from the inner streams, this is much simpler to implement,
1908-- (2) yield at least one element from an inner stream before going back to
1909-- outer stream and opening the next stream from it.
1911-- Ideally, we need some scheduling bias to inner streams vs outer stream.
1912-- Maybe we can configure the behavior.
1914{-# INLINE_NORMAL concatUnfoldInterleave #-}
1915concatUnfoldInterleave :: Monad m => Unfold m a b -> Stream m a -> Stream m b
1916concatUnfoldInterleave (Unfold istep inject) (Stream ostep ost) =
1917 Stream step (ConcatUnfoldInterleaveOuter ost [])
1919 {-# INLINE_LATE step #-}
1920 step gst (ConcatUnfoldInterleaveOuter o ls) = do
1921 r <- ostep (adaptState gst) o
1925 i `seq` return (Skip (ConcatUnfoldInterleaveInner o' (i : ls)))
1926 Skip o' -> return $ Skip (ConcatUnfoldInterleaveOuter o' ls)
1927 Stop -> return $ Skip (ConcatUnfoldInterleaveInnerL ls [])
1929 step _ (ConcatUnfoldInterleaveInner _ []) = undefined
1930 step _ (ConcatUnfoldInterleaveInner o (st:ls)) = do
1933 Yield x s -> Yield x (ConcatUnfoldInterleaveOuter o (s:ls))
1934 Skip s -> Skip (ConcatUnfoldInterleaveInner o (s:ls))
1935 Stop -> Skip (ConcatUnfoldInterleaveOuter o ls)
1937 step _ (ConcatUnfoldInterleaveInnerL [] []) = return Stop
1938 step _ (ConcatUnfoldInterleaveInnerL [] rs) =
1939 return $ Skip (ConcatUnfoldInterleaveInnerR [] rs)
1941 step _ (ConcatUnfoldInterleaveInnerL (st:ls) rs) = do
1944 Yield x s -> Yield x (ConcatUnfoldInterleaveInnerL ls (s:rs))
1945 Skip s -> Skip (ConcatUnfoldInterleaveInnerL (s:ls) rs)
1946 Stop -> Skip (ConcatUnfoldInterleaveInnerL ls rs)
1948 step _ (ConcatUnfoldInterleaveInnerR [] []) = return Stop
1949 step _ (ConcatUnfoldInterleaveInnerR ls []) =
1950 return $ Skip (ConcatUnfoldInterleaveInnerL ls [])
1952 step _ (ConcatUnfoldInterleaveInnerR ls (st:rs)) = do
1955 Yield x s -> Yield x (ConcatUnfoldInterleaveInnerR (s:ls) rs)
1956 Skip s -> Skip (ConcatUnfoldInterleaveInnerR ls (s:rs))
1957 Stop -> Skip (ConcatUnfoldInterleaveInnerR ls rs)
1959-- XXX In general we can use different scheduling strategies e.g. how to
1960-- schedule the outer vs inner loop or assigning weights to different streams
1961-- or outer and inner loops.
1963-- This could be inefficient if the tasks are too small.
1965-- Compared to concatUnfoldInterleave this one switches streams on Skips.
1967{-# INLINE_NORMAL concatUnfoldRoundrobin #-}
1968concatUnfoldRoundrobin :: Monad m => Unfold m a b -> Stream m a -> Stream m b
1969concatUnfoldRoundrobin (Unfold istep inject) (Stream ostep ost) =
1970 Stream step (ConcatUnfoldInterleaveOuter ost [])
1972 {-# INLINE_LATE step #-}
1973 step gst (ConcatUnfoldInterleaveOuter o ls) = do
1974 r <- ostep (adaptState gst) o
1978 i `seq` return (Skip (ConcatUnfoldInterleaveInner o' (i : ls)))
1979 Skip o' -> return $ Skip (ConcatUnfoldInterleaveInner o' ls)
1980 Stop -> return $ Skip (ConcatUnfoldInterleaveInnerL ls [])
1982 step _ (ConcatUnfoldInterleaveInner o []) =
1983 return $ Skip (ConcatUnfoldInterleaveOuter o [])
1985 step _ (ConcatUnfoldInterleaveInner o (st:ls)) = do
1988 Yield x s -> Yield x (ConcatUnfoldInterleaveOuter o (s:ls))
1989 Skip s -> Skip (ConcatUnfoldInterleaveOuter o (s:ls))
1990 Stop -> Skip (ConcatUnfoldInterleaveOuter o ls)
1992 step _ (ConcatUnfoldInterleaveInnerL [] []) = return Stop
1993 step _ (ConcatUnfoldInterleaveInnerL [] rs) =
1994 return $ Skip (ConcatUnfoldInterleaveInnerR [] rs)
1996 step _ (ConcatUnfoldInterleaveInnerL (st:ls) rs) = do
1999 Yield x s -> Yield x (ConcatUnfoldInterleaveInnerL ls (s:rs))
2000 Skip s -> Skip (ConcatUnfoldInterleaveInnerL ls (s:rs))
2001 Stop -> Skip (ConcatUnfoldInterleaveInnerL ls rs)
2003 step _ (ConcatUnfoldInterleaveInnerR [] []) = return Stop
2004 step _ (ConcatUnfoldInterleaveInnerR ls []) =
2005 return $ Skip (ConcatUnfoldInterleaveInnerL ls [])
2007 step _ (ConcatUnfoldInterleaveInnerR ls (st:rs)) = do
2010 Yield x s -> Yield x (ConcatUnfoldInterleaveInnerR (s:ls) rs)
2011 Skip s -> Skip (ConcatUnfoldInterleaveInnerR (s:ls) rs)
2012 Stop -> Skip (ConcatUnfoldInterleaveInnerR ls rs)
2014data AppendState s1 s2 = AppendFirst s1 | AppendSecond s2
2016-- Note that this could be much faster compared to the CPS stream. However, as
2017-- the number of streams being composed increases this may become expensive.
2018-- Need to see where the breaking point is between the two.
2020{-# INLINE_NORMAL append #-}
2021append :: Monad m => Stream m a -> Stream m a -> Stream m a
2022append (Stream step1 state1) (Stream step2 state2) =
2023 Stream step (AppendFirst state1)
2027 {-# INLINE_LATE step #-}
2028 step gst (AppendFirst st) = do
2031 Yield a s -> Yield a (AppendFirst s)
2032 Skip s -> Skip (AppendFirst s)
2033 Stop -> Skip (AppendSecond state2)
2035 step gst (AppendSecond st) = do
2038 Yield a s -> Yield a (AppendSecond s)
2039 Skip s -> Skip (AppendSecond s)
2042data InterleaveState s1 s2 = InterleaveFirst s1 s2 | InterleaveSecond s1 s2
2043 | InterleaveSecondOnly s2 | InterleaveFirstOnly s1
2045{-# INLINE_NORMAL interleave #-}
2046interleave :: Monad m => Stream m a -> Stream m a -> Stream m a
2047interleave (Stream step1 state1) (Stream step2 state2) =
2048 Stream step (InterleaveFirst state1 state2)
2052 {-# INLINE_LATE step #-}
2053 step gst (InterleaveFirst st1 st2) = do
2056 Yield a s -> Yield a (InterleaveSecond s st2)
2057 Skip s -> Skip (InterleaveFirst s st2)
2058 Stop -> Skip (InterleaveSecondOnly st2)
2060 step gst (InterleaveSecond st1 st2) = do
2063 Yield a s -> Yield a (InterleaveFirst st1 s)
2064 Skip s -> Skip (InterleaveSecond st1 s)
2065 Stop -> Skip (InterleaveFirstOnly st1)
2067 step gst (InterleaveFirstOnly st1) = do
2070 Yield a s -> Yield a (InterleaveFirstOnly s)
2071 Skip s -> Skip (InterleaveFirstOnly s)
2074 step gst (InterleaveSecondOnly st2) = do
2077 Yield a s -> Yield a (InterleaveSecondOnly s)
2078 Skip s -> Skip (InterleaveSecondOnly s)
2081{-# INLINE_NORMAL interleaveMin #-}
2082interleaveMin :: Monad m => Stream m a -> Stream m a -> Stream m a
2083interleaveMin (Stream step1 state1) (Stream step2 state2) =
2084 Stream step (InterleaveFirst state1 state2)
2088 {-# INLINE_LATE step #-}
2089 step gst (InterleaveFirst st1 st2) = do
2092 Yield a s -> Yield a (InterleaveSecond s st2)
2093 Skip s -> Skip (InterleaveFirst s st2)
2096 step gst (InterleaveSecond st1 st2) = do
2099 Yield a s -> Yield a (InterleaveFirst st1 s)
2100 Skip s -> Skip (InterleaveSecond st1 s)
2103 step _ (InterleaveFirstOnly _) = undefined
2104 step _ (InterleaveSecondOnly _) = undefined
2106{-# INLINE_NORMAL interleaveFst #-}
2107interleaveFst :: Monad m => Stream m a -> Stream m a -> Stream m a
2108interleaveFst (Stream step1 state1) (Stream step2 state2) =
2109 Stream step (InterleaveFirst state1 state2)
2113 {-# INLINE_LATE step #-}
2114 step gst (InterleaveFirst st1 st2) = do
2117 Yield a s -> Yield a (InterleaveSecond s st2)
2118 Skip s -> Skip (InterleaveFirst s st2)
2121 step gst (InterleaveSecond st1 st2) = do
2124 Yield a s -> Yield a (InterleaveFirst st1 s)
2125 Skip s -> Skip (InterleaveSecond st1 s)
2126 Stop -> Skip (InterleaveFirstOnly st1)
2128 step gst (InterleaveFirstOnly st1) = do
2131 Yield a s -> Yield a (InterleaveFirstOnly s)
2132 Skip s -> Skip (InterleaveFirstOnly s)
2135 step _ (InterleaveSecondOnly _) = undefined
2137{-# INLINE_NORMAL roundRobin #-}
2138roundRobin :: Monad m => Stream m a -> Stream m a -> Stream m a
2139roundRobin (Stream step1 state1) (Stream step2 state2) =
2140 Stream step (InterleaveFirst state1 state2)
2144 {-# INLINE_LATE step #-}
2145 step gst (InterleaveFirst st1 st2) = do
2148 Yield a s -> Yield a (InterleaveSecond s st2)
2149 Skip s -> Skip (InterleaveSecond s st2)
2150 Stop -> Skip (InterleaveSecondOnly st2)
2152 step gst (InterleaveSecond st1 st2) = do
2155 Yield a s -> Yield a (InterleaveFirst st1 s)
2156 Skip s -> Skip (InterleaveFirst st1 s)
2157 Stop -> Skip (InterleaveFirstOnly st1)
2159 step gst (InterleaveSecondOnly st2) = do
2162 Yield a s -> Yield a (InterleaveSecondOnly s)
2163 Skip s -> Skip (InterleaveSecondOnly s)
2166 step gst (InterleaveFirstOnly st1) = do
2169 Yield a s -> Yield a (InterleaveFirstOnly s)
2170 Skip s -> Skip (InterleaveFirstOnly s)
2173data ICUState s1 s2 i1 i2 =
2178 | ICUFirstInner s1 s2 i1
2179 | ICUSecondInner s1 s2 i2
2180 | ICUFirstOnlyInner s1 i1
2181 | ICUSecondOnlyInner s2 i2
2183-- | Interleave streams (full streams, not the elements) unfolded from two
2184-- input streams and concat. Stop when the first stream stops. If the second
2185-- stream ends before the first one then first stream still keeps running alone
2186-- without any interleaving with the second stream.
2188-- [a1, a2, ... an] [b1, b2 ...]
2189-- => [streamA1, streamA2, ... streamAn] [streamB1, streamB2, ...]
2190-- => [streamA1, streamB1, streamA2...StreamAn, streamBn]
2191-- => [a11, a12, ...a1j, b11, b12, ...b1k, a21, a22, ...]
2193{-# INLINE_NORMAL interleaveFstThenConcat #-}
2194interleaveFstThenConcat
2196 => Unfold m a c -> Stream m a -> Unfold m b c -> Stream m b -> Stream m c
2197interleaveFstThenConcat
2198 (Unfold istep1 inject1) (Stream step1 state1)
2199 (Unfold istep2 inject2) (Stream step2 state2) =
2200 Stream step (ICUFirst state1 state2)
2204 {-# INLINE_LATE step #-}
2205 step gst (ICUFirst s1 s2) = do
2206 r <- step1 (adaptState gst) s1
2210 i `seq` return (Skip (ICUFirstInner s s2 i))
2211 Skip s -> return $ Skip (ICUFirst s s2)
2214 step gst (ICUFirstOnly s1) = do
2215 r <- step1 (adaptState gst) s1
2219 i `seq` return (Skip (ICUFirstOnlyInner s i))
2220 Skip s -> return $ Skip (ICUFirstOnly s)
2223 step _ (ICUFirstInner s1 s2 i1) = do
2226 Yield x i' -> Yield x (ICUFirstInner s1 s2 i')
2227 Skip i' -> Skip (ICUFirstInner s1 s2 i')
2228 Stop -> Skip (ICUSecond s1 s2)
2230 step _ (ICUFirstOnlyInner s1 i1) = do
2233 Yield x i' -> Yield x (ICUFirstOnlyInner s1 i')
2234 Skip i' -> Skip (ICUFirstOnlyInner s1 i')
2235 Stop -> Skip (ICUFirstOnly s1)
2237 step gst (ICUSecond s1 s2) = do
2238 r <- step2 (adaptState gst) s2
2242 i `seq` return (Skip (ICUSecondInner s1 s i))
2243 Skip s -> return $ Skip (ICUSecond s1 s)
2244 Stop -> return $ Skip (ICUFirstOnly s1)
2246 step _ (ICUSecondInner s1 s2 i2) = do
2249 Yield x i' -> Yield x (ICUSecondInner s1 s2 i')
2250 Skip i' -> Skip (ICUSecondInner s1 s2 i')
2251 Stop -> Skip (ICUFirst s1 s2)
2253 step _ (ICUSecondOnly _s2) = undefined
2254 step _ (ICUSecondOnlyInner _s2 _i2) = undefined
2256------------------------------------------------------------------------------
2258------------------------------------------------------------------------------
2260data GbracketState s1 s2 v
2262 | GBracketNormal s1 v
2263 | GBracketException s2
2265-- | The most general bracketing and exception combinator. All other
2266-- combinators can be expressed in terms of this combinator. This can also be
2267-- used for cases which are not covered by the standard combinators.
2271{-# INLINE_NORMAL gbracket #-}
2275 -> (forall s. m s -> m (Either e s)) -- ^ try (exception handling)
2276 -> (c -> m d) -- ^ after, on normal stop
2277 -> (c -> e -> Stream m b) -- ^ on exception
2278 -> (c -> Stream m b) -- ^ stream generator
2280gbracket bef exc aft fexc fnormal =
2281 Stream step GBracketInit
2285 {-# INLINE_LATE step #-}
2286 step _ GBracketInit = do
2288 return $ Skip $ GBracketNormal (fnormal r) r
2290 step gst (GBracketNormal (UnStream step1 st) v) = do
2291 res <- exc $ step1 gst st
2293 Right r -> case r of
2295 return $ Yield x (GBracketNormal (Stream step1 s) v)
2296 Skip s -> return $ Skip (GBracketNormal (Stream step1 s) v)
2297 Stop -> aft v >> return Stop
2298 Left e -> return $ Skip (GBracketException (fexc v e))
2299 step gst (GBracketException (UnStream step1 st)) = do
2302 Yield x s -> return $ Yield x (GBracketException (Stream step1 s))
2303 Skip s -> return $ Skip (GBracketException (Stream step1 s))
2306-- | Run a side effect before the stream yields its first element.
2307{-# INLINE_NORMAL before #-}
2308before :: Monad m => m b -> Stream m a -> Stream m a
2309before action (Stream step state) = Stream step' Nothing
2313 {-# INLINE_LATE step' #-}
2314 step' _ Nothing = action >> return (Skip (Just state))
2316 step' gst (Just st) = do
2319 Yield x s -> return $ Yield x (Just s)
2320 Skip s -> return $ Skip (Just s)
2323-- | Run a side effect whenever the stream stops normally.
2324{-# INLINE_NORMAL after #-}
2325after :: Monad m => m b -> Stream m a -> Stream m a
2326after action (Stream step state) = Stream step' state
2330 {-# INLINE_LATE step' #-}
2334 Yield x s -> return $ Yield x s
2335 Skip s -> return $ Skip s
2336 Stop -> action >> return Stop
2338-- XXX These combinators are expensive due to the call to
2339-- onException/handle/try on each step. Therefore, when possible, they should
2340-- be called in an outer loop where we perform less iterations. For example, we
2341-- cannot call them on each iteration in a char stream, instead we can call
2342-- them when doing an IO on an array.
2344-- XXX For high performance error checks in busy streams we may need another
2345-- Error constructor in step.
2347-- | Run a side effect whenever the stream aborts due to an exception. The
2348-- exception is not caught, simply rethrown.
2349{-# INLINE_NORMAL onException #-}
2350onException :: MonadCatch m => m b -> Stream m a -> Stream m a
2351onException action str =
2352 gbracket (return ()) MC.try return
2353 (\_ (_ :: MC.SomeException) -> nilM $ action)
2356{-# INLINE_NORMAL _onException #-}
2357_onException :: MonadCatch m => m b -> Stream m a -> Stream m a
2358_onException action (Stream step state) = Stream step' state
2362 {-# INLINE_LATE step' #-}
2364 res <- step gst st `MC.onException` action
2366 Yield x s -> return $ Yield x s
2367 Skip s -> return $ Skip s
2370-- XXX bracket is like concatMap, it generates a stream and then flattens it.
2371-- Like concatMap it has 10x worse performance compared to linear fused
2374-- | Run the first action before the stream starts and remember its output,
2375-- generate a stream using the output, run the second action providing the
2376-- remembered value as an argument whenever the stream ends normally or due to
2378{-# INLINE_NORMAL bracket #-}
2379bracket :: MonadCatch m => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a
2380bracket bef aft bet =
2381 gbracket bef MC.try aft (\a (_ :: SomeException) -> nilM $ aft a) bet
2383data BracketState s v = BracketInit | BracketRun s v
2385{-# INLINE_NORMAL _bracket #-}
2386_bracket :: MonadCatch m => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a
2387_bracket bef aft bet = Stream step' BracketInit
2391 {-# INLINE_LATE step' #-}
2392 step' _ BracketInit = bef >>= \x -> return (Skip (BracketRun (bet x) x))
2394 -- NOTE: It is important to use UnStream instead of the Stream pattern
2395 -- here, otherwise we get huge perf degradation, see note in concatMap.
2396 step' gst (BracketRun (UnStream step state) v) = do
2397 -- res <- step gst state `MC.onException` aft v
2398 res <- MC.try $ step gst state
2400 Left (_ :: SomeException) -> aft v >> return Stop
2401 Right r -> case r of
2402 Yield x s -> return $ Yield x (BracketRun (Stream step s) v)
2403 Skip s -> return $ Skip (BracketRun (Stream step s) v)
2404 Stop -> aft v >> return Stop
2406-- | Run a side effect whenever the stream stops normally or aborts due to an
2408{-# INLINE finally #-}
2409finally :: MonadCatch m => m b -> Stream m a -> Stream m a
2410-- finally action xs = after action $ onException action xs
2411finally action xs = bracket (return ()) (\_ -> action) (const xs)
2413-- | When evaluating a stream if an exception occurs, stream evaluation aborts
2414-- and the specified exception handler is run with the exception as argument.
2415{-# INLINE_NORMAL handle #-}
2416handle :: (MonadCatch m, Exception e)
2417 => (e -> Stream m a) -> Stream m a -> Stream m a
2419 gbracket (return ()) MC.try return (\_ e -> f e) (\_ -> str)
2421{-# INLINE_NORMAL _handle #-}
2422_handle :: (MonadCatch m, Exception e)
2423 => (e -> Stream m a) -> Stream m a -> Stream m a
2424_handle f (Stream step state) = Stream step' (Left state)
2428 {-# INLINE_LATE step' #-}
2429 step' gst (Left st) = do
2430 res <- MC.try $ step gst st
2432 Left e -> return $ Skip $ Right (f e)
2433 Right r -> case r of
2434 Yield x s -> return $ Yield x (Left s)
2435 Skip s -> return $ Skip (Left s)
2438 step' gst (Right (UnStream step1 st)) = do
2441 Yield x s -> return $ Yield x (Right (Stream step1 s))
2442 Skip s -> return $ Skip (Right (Stream step1 s))
2445-------------------------------------------------------------------------------
2446-- General transformation
2447-------------------------------------------------------------------------------
2449{-# INLINE_NORMAL transform #-}
2450transform :: Monad m => Pipe m a b -> Stream m a -> Stream m b
2451transform (Pipe pstep1 pstep2 pstate) (Stream step state) =
2452 Stream step' (Consume pstate, state)
2456 {-# INLINE_LATE step' #-}
2458 step' gst (Consume pst, st) = pst `seq` do
2459 r <- step (adaptState gst) st
2464 Pipe.Yield b pst' -> return $ Yield b (pst', s)
2465 Pipe.Continue pst' -> return $ Skip (pst', s)
2466 Skip s -> return $ Skip (Consume pst, s)
2469 step' _ (Produce pst, st) = pst `seq` do
2472 Pipe.Yield b pst' -> return $ Yield b (pst', st)
2473 Pipe.Continue pst' -> return $ Skip (pst', st)
2475------------------------------------------------------------------------------
2476-- Transformation by Folding (Scans)
2477------------------------------------------------------------------------------
2479------------------------------------------------------------------------------
2481------------------------------------------------------------------------------
2483-- XXX Is a prescan useful, discarding the last step does not sound useful? I
2484-- am not sure about the utility of this function, so this is implemented but
2485-- not exposed. We can expose it if someone provides good reasons why this is
2488-- XXX We have to execute the stream one step ahead to know that we are at the
2489-- last step. The vector implementation of prescan executes the last fold step
2490-- but does not yield the result. This means we have executed the effect but
2491-- discarded value. This does not sound right. In this implementation we are
2492-- not executing the last fold step.
2493{-# INLINE_NORMAL prescanlM' #-}
2494prescanlM' :: Monad m => (b -> a -> m b) -> m b -> Stream m a -> Stream m b
2495prescanlM' f mz (Stream step state) = Stream step' (state, mz)
2497 {-# INLINE_LATE step' #-}
2498 step' gst (st, prev) = do
2499 r <- step (adaptState gst) st
2503 return $ Yield acc (s, f acc x)
2504 Skip s -> return $ Skip (s, prev)
2507{-# INLINE prescanl' #-}
2508prescanl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b
2509prescanl' f z = prescanlM' (\a b -> return (f a b)) (return z)
2511------------------------------------------------------------------------------
2512-- Monolithic postscans (postscan followed by a map)
2513------------------------------------------------------------------------------
2515-- The performance of a modular postscan followed by a map seems to be
2516-- equivalent to this monolithic scan followed by map therefore we may not need
2517-- this implementation. We just have it for performance comparison and in case
2518-- modular version does not perform well in some situation.
2520{-# INLINE_NORMAL postscanlMx' #-}
2521postscanlMx' :: Monad m
2522 => (x -> a -> m x) -> m x -> (x -> m b) -> Stream m a -> Stream m b
2523postscanlMx' fstep begin done (Stream step state) = do
2524 Stream step' (state, begin)
2526 {-# INLINE_LATE step' #-}
2527 step' gst (st, acc) = do
2528 r <- step (adaptState gst) st
2534 v `seq` y `seq` return (Yield v (s, return y))
2535 Skip s -> return $ Skip (s, acc)
2538{-# INLINE_NORMAL postscanlx' #-}
2539postscanlx' :: Monad m
2540 => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> Stream m b
2541postscanlx' fstep begin done s =
2542 postscanlMx' (\b a -> return (fstep b a)) (return begin) (return . done) s
2544-- XXX do we need consM strict to evaluate the begin value?
2545{-# INLINE scanlMx' #-}
2547 => (x -> a -> m x) -> m x -> (x -> m b) -> Stream m a -> Stream m b
2548scanlMx' fstep begin done s =
2549 (begin >>= \x -> x `seq` done x) `consM` postscanlMx' fstep begin done s
2551{-# INLINE scanlx' #-}
2553 => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> Stream m b
2554scanlx' fstep begin done s =
2555 scanlMx' (\b a -> return (fstep b a)) (return begin) (return . done) s
2557------------------------------------------------------------------------------
2559------------------------------------------------------------------------------
2561{-# INLINE_NORMAL postscanlM' #-}
2562postscanlM' :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
2563postscanlM' fstep begin (Stream step state) =
2564 begin `seq` Stream step' (state, begin)
2566 {-# INLINE_LATE step' #-}
2567 step' gst (st, acc) = acc `seq` do
2568 r <- step (adaptState gst) st
2572 y `seq` return (Yield y (s, y))
2573 Skip s -> return $ Skip (s, acc)
2576{-# INLINE_NORMAL postscanl' #-}
2577postscanl' :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a
2578postscanl' f = postscanlM' (\a b -> return (f a b))
2580{-# INLINE_NORMAL postscanlM #-}
2581postscanlM :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
2582postscanlM fstep begin (Stream step state) = Stream step' (state, begin)
2584 {-# INLINE_LATE step' #-}
2585 step' gst (st, acc) = do
2586 r <- step (adaptState gst) st
2590 return (Yield y (s, y))
2591 Skip s -> return $ Skip (s, acc)
2594{-# INLINE_NORMAL postscanl #-}
2595postscanl :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a
2596postscanl f = postscanlM (\a b -> return (f a b))
2598{-# INLINE_NORMAL scanlM' #-}
2599scanlM' :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
2600scanlM' fstep begin s = begin `seq` (begin `cons` postscanlM' fstep begin s)
2602{-# INLINE scanl' #-}
2603scanl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b
2604scanl' f = scanlM' (\a b -> return (f a b))
2606{-# INLINE_NORMAL scanlM #-}
2607scanlM :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
2608scanlM fstep begin s = begin `cons` postscanlM fstep begin s
2611scanl :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b
2612scanl f = scanlM (\a b -> return (f a b))
2614{-# INLINE_NORMAL scanl1M #-}
2615scanl1M :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a
2616scanl1M fstep (Stream step state) = Stream step' (state, Nothing)
2618 {-# INLINE_LATE step' #-}
2619 step' gst (st, Nothing) = do
2622 Yield x s -> return $ Yield x (s, Just x)
2623 Skip s -> return $ Skip (s, Nothing)
2626 step' gst (st, Just acc) = do
2631 return $ Yield z (s, Just z)
2632 Skip s -> return $ Skip (s, Just acc)
2635{-# INLINE scanl1 #-}
2636scanl1 :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a
2637scanl1 f = scanl1M (\x y -> return (f x y))
2639{-# INLINE_NORMAL scanl1M' #-}
2640scanl1M' :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a
2641scanl1M' fstep (Stream step state) = Stream step' (state, Nothing)
2643 {-# INLINE_LATE step' #-}
2644 step' gst (st, Nothing) = do
2647 Yield x s -> x `seq` return $ Yield x (s, Just x)
2648 Skip s -> return $ Skip (s, Nothing)
2651 step' gst (st, Just acc) = acc `seq` do
2656 z `seq` return $ Yield z (s, Just z)
2657 Skip s -> return $ Skip (s, Just acc)
2660{-# INLINE scanl1' #-}
2661scanl1' :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a
2662scanl1' f = scanl1M' (\x y -> return (f x y))
2665tap :: Monad m => Fold m a b -> Stream m a -> Stream m a
2666tap (Fold fstep initial extract) (Stream step state) = Stream step' Nothing
2670 step' _ Nothing = do
2672 return $ Skip (Just (r, state))
2674 step' gst (Just (acc, st)) = do
2679 return $ Yield x (Just (acc', s))
2680 Skip s -> return $ Skip (Just (acc, s))
2685-------------------------------------------------------------------------------
2687-------------------------------------------------------------------------------
2689{-# INLINE_NORMAL takeWhileM #-}
2690takeWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a
2691takeWhileM f (Stream step state) = Stream step' state
2693 {-# INLINE_LATE step' #-}
2699 return $ if b then Yield x s else Stop
2700 Skip s -> return $ Skip s
2703{-# INLINE takeWhile #-}
2704takeWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
2705takeWhile f = takeWhileM (return . f)
2707{-# INLINE_NORMAL drop #-}
2708drop :: Monad m => Int -> Stream m a -> Stream m a
2709drop n (Stream step state) = Stream step' (state, Just n)
2711 {-# INLINE_LATE step' #-}
2712 step' gst (st, Just i)
2717 Yield _ s -> Skip (s, Just (i - 1))
2718 Skip s -> Skip (s, Just i)
2720 | otherwise = return $ Skip (st, Nothing)
2722 step' gst (st, Nothing) = do
2726 Yield x s -> Yield x (s, Nothing)
2727 Skip s -> Skip (s, Nothing)
2730data DropWhileState s a
2732 | DropWhileYield a s
2735{-# INLINE_NORMAL dropWhileM #-}
2736dropWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a
2737dropWhileM f (Stream step state) = Stream step' (DropWhileDrop state)
2739 {-# INLINE_LATE step' #-}
2740 step' gst (DropWhileDrop st) = do
2746 then return $ Skip (DropWhileDrop s)
2747 else return $ Skip (DropWhileYield x s)
2748 Skip s -> return $ Skip (DropWhileDrop s)
2751 step' gst (DropWhileNext st) = do
2754 Yield x s -> return $ Skip (DropWhileYield x s)
2755 Skip s -> return $ Skip (DropWhileNext s)
2758 step' _ (DropWhileYield x st) = return $ Yield x (DropWhileNext st)
2760{-# INLINE dropWhile #-}
2761dropWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
2762dropWhile f = dropWhileM (return . f)
2764{-# INLINE_NORMAL filterM #-}
2765filterM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a
2766filterM f (Stream step state) = Stream step' state
2768 {-# INLINE_LATE step' #-}
2777 Skip s -> return $ Skip s
2780{-# INLINE filter #-}
2781filter :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
2782filter f = filterM (return . f)
2784{-# INLINE_NORMAL uniq #-}
2785uniq :: (Eq a, Monad m) => Stream m a -> Stream m a
2786uniq (Stream step state) = Stream step' (Nothing, state)
2788 {-# INLINE_LATE step' #-}
2789 step' gst (Nothing, st) = do
2792 Yield x s -> return $ Yield x (Just x, s)
2793 Skip s -> return $ Skip (Nothing, s)
2795 step' gst (Just x, st) = do
2798 Yield y s | x == y -> return $ Skip (Just x, s)
2799 | otherwise -> return $ Yield y (Just y, s)
2800 Skip s -> return $ Skip (Just x, s)
2803------------------------------------------------------------------------------
2804-- Transformation by Mapping
2805------------------------------------------------------------------------------
2807{-# INLINE_NORMAL sequence #-}
2808sequence :: Monad m => Stream m (m a) -> Stream m a
2809sequence (Stream step state) = Stream step' state
2811 {-# INLINE_LATE step' #-}
2813 r <- step (adaptState gst) st
2815 Yield x s -> x >>= \a -> return (Yield a s)
2816 Skip s -> return $ Skip s
2819------------------------------------------------------------------------------
2821------------------------------------------------------------------------------
2823data LoopState x s = FirstYield s
2824 | InterspersingYield s
2827{-# INLINE_NORMAL intersperseM #-}
2828intersperseM :: Monad m => m a -> Stream m a -> Stream m a
2829intersperseM m (Stream step state) = Stream step' (FirstYield state)
2831 {-# INLINE_LATE step' #-}
2832 step' gst (FirstYield st) = do
2836 Yield x s -> Skip (YieldAndCarry x s)
2837 Skip s -> Skip (FirstYield s)
2840 step' gst (InterspersingYield st) = do
2845 return $ Yield a (YieldAndCarry x s)
2846 Skip s -> return $ Skip $ InterspersingYield s
2849 step' _ (YieldAndCarry x st) = return $ Yield x (InterspersingYield st)
2854 | SuffixYield a (SuffixState s a)
2856{-# INLINE_NORMAL insertAfterEach #-}
2857insertAfterEach :: forall m a. Monad m => m a -> Stream m a -> Stream m a
2858insertAfterEach action (Stream step state) = Stream step' (SuffixElem state)
2860 {-# INLINE_LATE step' #-}
2861 step' gst (SuffixElem st) = do
2864 Yield x s -> Skip (SuffixYield x (SuffixSuffix s))
2865 Skip s -> Skip (SuffixElem s)
2868 step' _ (SuffixSuffix st) = do
2869 action >>= \r -> return $ Skip (SuffixYield r (SuffixElem st))
2871 step' _ (SuffixYield x next) = return $ Yield x next
2873{-# INLINE intersperse #-}
2874intersperse :: Monad m => a -> Stream m a -> Stream m a
2875intersperse a = intersperseM (return a)
2877{-# INLINE_NORMAL insertBy #-}
2878insertBy :: Monad m => (a -> a -> Ordering) -> a -> Stream m a -> Stream m a
2879insertBy cmp a (Stream step state) = Stream step' (state, False, Nothing)
2881 {-# INLINE_LATE step' #-}
2882 step' gst (st, False, _) = do
2885 Yield x s -> case cmp a x of
2886 GT -> return $ Yield x (s, False, Nothing)
2887 _ -> return $ Yield a (s, True, Just x)
2888 Skip s -> return $ Skip (s, False, Nothing)
2889 Stop -> return $ Yield a (st, True, Nothing)
2891 step' _ (_, True, Nothing) = return Stop
2893 step' gst (st, True, Just prev) = do
2896 Yield x s -> return $ Yield prev (s, True, Just x)
2897 Skip s -> return $ Skip (s, True, Just prev)
2898 Stop -> return $ Yield prev (st, True, Nothing)
2900------------------------------------------------------------------------------
2902------------------------------------------------------------------------------
2904{-# INLINE_NORMAL deleteBy #-}
2905deleteBy :: Monad m => (a -> a -> Bool) -> a -> Stream m a -> Stream m a
2906deleteBy eq x (Stream step state) = Stream step' (state, False)
2908 {-# INLINE_LATE step' #-}
2909 step' gst (st, False) = do
2912 Yield y s -> return $
2913 if eq x y then Skip (s, True) else Yield y (s, False)
2914 Skip s -> return $ Skip (s, False)
2917 step' gst (st, True) = do
2920 Yield y s -> return $ Yield y (s, True)
2921 Skip s -> return $ Skip (s, True)
2924------------------------------------------------------------------------------
2925-- Transformation by Map and Filter
2926------------------------------------------------------------------------------
2928-- XXX Will this always fuse properly?
2929{-# INLINE_NORMAL mapMaybe #-}
2930mapMaybe :: Monad m => (a -> Maybe b) -> Stream m a -> Stream m b
2931mapMaybe f = fmap fromJust . filter isJust . map f
2933{-# INLINE_NORMAL mapMaybeM #-}
2934mapMaybeM :: Monad m => (a -> m (Maybe b)) -> Stream m a -> Stream m b
2935mapMaybeM f = fmap fromJust . filter isJust . mapM f
2937------------------------------------------------------------------------------
2939------------------------------------------------------------------------------
2941{-# INLINE_NORMAL indexed #-}
2942indexed :: Monad m => Stream m a -> Stream m (Int, a)
2943indexed (Stream step state) = Stream step' (state, 0)
2945 {-# INLINE_LATE step' #-}
2946 step' gst (st, i) = i `seq` do
2947 r <- step (adaptState gst) st
2949 Yield x s -> return $ Yield (i, x) (s, i+1)
2950 Skip s -> return $ Skip (s, i)
2953{-# INLINE_NORMAL indexedR #-}
2954indexedR :: Monad m => Int -> Stream m a -> Stream m (Int, a)
2955indexedR m (Stream step state) = Stream step' (state, m)
2957 {-# INLINE_LATE step' #-}
2958 step' gst (st, i) = i `seq` do
2959 r <- step (adaptState gst) st
2961 Yield x s -> let i' = i - 1
2962 in return $ Yield (i, x) (s, i')
2963 Skip s -> return $ Skip (s, i)
2966{-# INLINE_NORMAL zipWithM #-}
2968 => (a -> b -> m c) -> Stream m a -> Stream m b -> Stream m c
2969zipWithM f (Stream stepa ta) (Stream stepb tb) = Stream step (ta, tb, Nothing)
2971 {-# INLINE_LATE step #-}
2972 step gst (sa, sb, Nothing) = do
2973 r <- stepa (adaptState gst) sa
2976 Yield x sa' -> Skip (sa', sb, Just x)
2977 Skip sa' -> Skip (sa', sb, Nothing)
2980 step gst (sa, sb, Just x) = do
2981 r <- stepb (adaptState gst) sb
2985 return $ Yield z (sa, sb', Nothing)
2986 Skip sb' -> return $ Skip (sa, sb', Just x)
2989#if __GLASGOW_HASKELL__ >= 801
2990{-# RULES "zipWithM xs xs"
2991 forall f xs. zipWithM @Identity f xs xs = mapM (\x -> f x x) xs #-}
2994{-# INLINE zipWith #-}
2995zipWith :: Monad m => (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c
2996zipWith f = zipWithM (\a b -> return (f a b))
2998------------------------------------------------------------------------------
3000------------------------------------------------------------------------------
3002{-# INLINE_NORMAL mergeByM #-}
3005 => (a -> a -> m Ordering) -> Stream m a -> Stream m a -> Stream m a
3006mergeByM cmp (Stream stepa ta) (Stream stepb tb) =
3007 Stream step (Just ta, Just tb, Nothing, Nothing)
3009 {-# INLINE_LATE step #-}
3011 -- one of the values is missing, and the corresponding stream is running
3012 step gst (Just sa, sb, Nothing, b) = do
3015 Yield a sa' -> Skip (Just sa', sb, Just a, b)
3016 Skip sa' -> Skip (Just sa', sb, Nothing, b)
3017 Stop -> Skip (Nothing, sb, Nothing, b)
3019 step gst (sa, Just sb, a, Nothing) = do
3022 Yield b sb' -> Skip (sa, Just sb', a, Just b)
3023 Skip sb' -> Skip (sa, Just sb', a, Nothing)
3024 Stop -> Skip (sa, Nothing, a, Nothing)
3026 -- both the values are available
3027 step _ (sa, sb, Just a, Just b) = do
3029 return $ case res of
3030 GT -> Yield b (sa, sb, Just a, Nothing)
3031 _ -> Yield a (sa, sb, Nothing, Just b)
3033 -- one of the values is missing, corresponding stream is done
3034 step _ (Nothing, sb, Nothing, Just b) =
3035 return $ Yield b (Nothing, sb, Nothing, Nothing)
3037 step _ (sa, Nothing, Just a, Nothing) =
3038 return $ Yield a (sa, Nothing, Nothing, Nothing)
3040 step _ (Nothing, Nothing, Nothing, Nothing) = return Stop
3042{-# INLINE mergeBy #-}
3045 => (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a
3046mergeBy cmp = mergeByM (\a b -> return $ cmp a b)
3048------------------------------------------------------------------------------
3049-- Transformation comprehensions
3050------------------------------------------------------------------------------
3052{-# INLINE_NORMAL the #-}
3053the :: (Eq a, Monad m) => Stream m a -> m (Maybe a)
3054the (Stream step state) = go state
3057 r <- step defState st
3059 Yield x s -> go' x s
3061 Stop -> return Nothing
3063 r <- step defState st
3065 Yield x s | x == n -> go' n s
3066 | otherwise -> return Nothing
3068 Stop -> return (Just n)
3070--------------------------------------------------------------------------------
3071-- UTF8 Encoding / Decoding
3072--------------------------------------------------------------------------------
3074-- UTF-8 primitives, Lifted from GHC.IO.Encoding.UTF8.
3077ord2 :: Char -> WList
3078ord2 c = assert (n >= 0x80 && n <= 0x07ff) (WCons x1 (WCons x2 WNil))
3081 x1 = fromIntegral $ (n `shiftR` 6) + 0xC0
3082 x2 = fromIntegral $ (n .&. 0x3F) + 0x80
3085ord3 :: Char -> WList
3086ord3 c = assert (n >= 0x0800 && n <= 0xffff) (WCons x1 (WCons x2 (WCons x3 WNil)))
3089 x1 = fromIntegral $ (n `shiftR` 12) + 0xE0
3090 x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
3091 x3 = fromIntegral $ (n .&. 0x3F) + 0x80
3094ord4 :: Char -> WList
3095ord4 c = assert (n >= 0x10000) (WCons x1 (WCons x2 (WCons x3 (WCons x4 WNil))))
3098 x1 = fromIntegral $ (n `shiftR` 18) + 0xF0
3099 x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80
3100 x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
3101 x4 = fromIntegral $ (n .&. 0x3F) + 0x80
3103data CodingFailureMode
3104 = TransliterateCodingFailure
3105 | ErrorOnCodingFailure
3108{-# INLINE replacementChar #-}
3109replacementChar :: Char
3110replacementChar = '\xFFFD'
3112-- Int helps in cheaper conversion from Int to Char
3114type DecoderState = Word8
3116-- See http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ for details.
3118{-# INLINE runFold #-}
3119runFold :: (Monad m) => Fold m a b -> Stream m a -> m b
3120runFold (Fold step begin done) = foldlMx' step begin done
3122-- Aligning to cacheline makes a barely noticeable difference
3123utf8d :: A.Array Word8
3124utf8d = unsafePerformIO $ runFold (A.writeAligned 64) $ fromList [
3125 -- The first part of the table maps bytes to character classes that
3126 -- to reduce the size of the transition table and create bitmasks.
3127 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,
3128 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,
3129 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,
3130 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,
3131 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,
3132 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,
3133 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,
3134 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,
3136 -- The second part is a transition table that maps a combination
3137 -- of a state of the automaton and a character class to a state.
3138 0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12,
3139 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,
3140 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,
3141 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,
3142 12,36,12,12,12,12,12,12,12,12,12,12
3145-- | Return element at the specified index without checking the bounds.
3146-- and without touching the foreign ptr.
3147{-# INLINE_NORMAL unsafePeekElemOff #-}
3148unsafePeekElemOff :: forall a. Storable a => Ptr a -> Int -> a
3149unsafePeekElemOff p i = let !x = A.unsafeInlineIO $ peekElemOff p i in x
3151-- decode is split into two separate cases to avoid branching instructions.
3152-- From the higher level flow we already know which case we are in so we can
3153-- call the appropriate decode function.
3155-- When the state is 0
3156{-# INLINE decode0 #-}
3157decode0 :: Ptr Word8 -> Word8 -> Tuple' DecoderState CodePoint
3159 let !t = table `unsafePeekElemOff` fromIntegral byte
3160 !codep' = (0xff `shiftR` (fromIntegral t)) .&. fromIntegral byte
3161 !state' = table `unsafePeekElemOff` (256 + fromIntegral t)
3162 in (Tuple' state' codep')
3164-- When the state is not 0
3165{-# INLINE decode1 #-}
3171 -> Tuple' DecoderState CodePoint
3172decode1 table state codep byte =
3173 -- Remember codep is Int type!
3174 -- Can it be unsafe to convert the resulting to Char?
3175 let !t = table `unsafePeekElemOff` fromIntegral byte
3176 !codep' = (fromIntegral byte .&. 0x3f) .|. (codep `shiftL` 6)
3177 !state' = table `unsafePeekElemOff`
3178 (256 + fromIntegral state + fromIntegral t)
3179 in (Tuple' state' codep')
3183 = FreshPointDecodeInit s
3184 | FreshPointDecodeFirst s Word8
3185 | FreshPointDecoding s !DecoderState !CodePoint
3186 | YieldAndContinue !Char (FreshPoint s)
3189-- XXX Add proper error messages
3190{-# INLINE_NORMAL decodeUtf8With #-}
3191decodeUtf8With :: Monad m => CodingFailureMode -> Stream m Word8 -> Stream m Char
3192decodeUtf8With cfm (Stream step state) =
3193 let Array p _ _ = utf8d
3194 !ptr = (unsafeForeignPtrToPtr p)
3195 in Stream (step' ptr) (FreshPointDecodeInit state)
3197 {-# INLINE transliterateOrError #-}
3198 transliterateOrError e s =
3200 ErrorOnCodingFailure -> error e
3201 TransliterateCodingFailure -> YieldAndContinue replacementChar s
3202 {-# INLINE inputUnderflow #-}
3205 ErrorOnCodingFailure ->
3206 error "Streamly.Streams.StreamD.decodeUtf8With: Input Underflow"
3207 TransliterateCodingFailure -> YieldAndContinue replacementChar Done
3208 {-# INLINE_LATE step' #-}
3209 step' _ gst (FreshPointDecodeInit st) = do
3210 r <- step (adaptState gst) st
3213 -- Note: It is important to use a ">" instead of a "<=" test
3214 -- here for GHC to generate code layout for default branch
3215 -- prediction for the common case. This is fragile and might
3216 -- change with the compiler versions, we need a more reliable
3217 -- "likely" primitive to control branch predication.
3220 return $ Skip $ YieldAndContinue
3221 (unsafeChr (fromIntegral x))
3222 (FreshPointDecodeInit s)
3223 -- Using a separate state here generates a jump to a
3224 -- separate code block in the core which seems to perform
3225 -- slightly better for the non-ascii case.
3226 True -> return $ Skip $ FreshPointDecodeFirst s x
3227 Skip s -> return $ Skip (FreshPointDecodeInit s)
3228 Stop -> return $ Skip Done
3230 step' table _ (FreshPointDecodeFirst st x) = do
3231 let (Tuple' sv cp) = decode0 table x
3236 transliterateOrError
3237 "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered"
3238 (FreshPointDecodeInit st)
3239 0 -> error "unreachable state"
3240 _ -> Skip (FreshPointDecoding st sv cp)
3242 step' table gst (FreshPointDecoding st statePtr codepointPtr) = do
3243 r <- step (adaptState gst) st
3246 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
3249 0 -> Skip $ YieldAndContinue (unsafeChr cp)
3250 (FreshPointDecodeInit s)
3253 transliterateOrError
3254 "Streamly.Streams.StreamD.decodeUtf8With: Invalid UTF8 codepoint encountered"
3255 (FreshPointDecodeInit s)
3256 _ -> Skip (FreshPointDecoding s sv cp)
3257 Skip s -> return $ Skip (FreshPointDecoding s statePtr codepointPtr)
3258 Stop -> return $ Skip inputUnderflow
3260 step' _ _ (YieldAndContinue c s) = return $ Yield c s
3261 step' _ _ Done = return Stop
3263{-# INLINE decodeUtf8 #-}
3264decodeUtf8 :: Monad m => Stream m Word8 -> Stream m Char
3265decodeUtf8 = decodeUtf8With ErrorOnCodingFailure
3267{-# INLINE decodeUtf8Lenient #-}
3268decodeUtf8Lenient :: Monad m => Stream m Word8 -> Stream m Char
3269decodeUtf8Lenient = decodeUtf8With TransliterateCodingFailure
3271data FlattenState s a
3272 = OuterLoop s !(Maybe (DecoderState, CodePoint))
3273 | InnerLoopDecodeInit s (ForeignPtr a) !(Ptr a) !(Ptr a)
3274 | InnerLoopDecodeFirst s (ForeignPtr a) !(Ptr a) !(Ptr a) Word8
3275 | InnerLoopDecoding s (ForeignPtr a) !(Ptr a) !(Ptr a)
3276 !DecoderState !CodePoint
3277 | YAndC !Char (FlattenState s a) -- These constructors can be
3278 -- encoded in the FreshPoint
3279 -- type, I prefer to keep these
3280 -- flat even though that means
3281 -- coming up with new names
3284-- The normal decodeUtf8 above should fuse with flattenArrays
3285-- to create this exact code but it doesn't for some reason, as of now this
3286-- remains the fastest way I could figure out to decodeUtf8.
3288-- XXX Add Proper error messages
3289{-# INLINE_NORMAL decodeUtf8ArraysWith #-}
3290decodeUtf8ArraysWith ::
3292 => CodingFailureMode
3293 -> Stream m (A.Array Word8)
3295decodeUtf8ArraysWith cfm (Stream step state) =
3296 let Array p _ _ = utf8d
3297 !ptr = (unsafeForeignPtrToPtr p)
3298 in Stream (step' ptr) (OuterLoop state Nothing)
3300 {-# INLINE transliterateOrError #-}
3301 transliterateOrError e s =
3303 ErrorOnCodingFailure -> error e
3304 TransliterateCodingFailure -> YAndC replacementChar s
3305 {-# INLINE inputUnderflow #-}
3308 ErrorOnCodingFailure ->
3310 "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Input Underflow"
3311 TransliterateCodingFailure -> YAndC replacementChar D
3312 {-# INLINE_LATE step' #-}
3313 step' _ gst (OuterLoop st Nothing) = do
3314 r <- step (adaptState gst) st
3317 Yield A.Array {..} s ->
3318 let p = unsafeForeignPtrToPtr aStart
3319 in Skip (InnerLoopDecodeInit s aStart p aEnd)
3320 Skip s -> Skip (OuterLoop s Nothing)
3322 step' _ gst (OuterLoop st dst@(Just (ds, cp))) = do
3323 r <- step (adaptState gst) st
3326 Yield A.Array {..} s ->
3327 let p = unsafeForeignPtrToPtr aStart
3328 in Skip (InnerLoopDecoding s aStart p aEnd ds cp)
3329 Skip s -> Skip (OuterLoop s dst)
3330 Stop -> Skip inputUnderflow
3331 step' _ _ (InnerLoopDecodeInit st startf p end)
3333 liftIO $ touchForeignPtr startf
3334 return $ Skip $ OuterLoop st Nothing
3335 step' _ _ (InnerLoopDecodeInit st startf p end) = do
3336 x <- liftIO $ peek p
3337 -- Note: It is important to use a ">" instead of a "<=" test here for
3338 -- GHC to generate code layout for default branch prediction for the
3339 -- common case. This is fragile and might change with the compiler
3340 -- versions, we need a more reliable "likely" primitive to control
3341 -- branch predication.
3344 return $ Skip $ YAndC
3345 (unsafeChr (fromIntegral x))
3346 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
3347 -- Using a separate state here generates a jump to a separate code
3348 -- block in the core which seems to perform slightly better for the
3350 True -> return $ Skip $ InnerLoopDecodeFirst st startf p end x
3352 step' table _ (InnerLoopDecodeFirst st startf p end x) = do
3353 let (Tuple' sv cp) = decode0 table x
3358 transliterateOrError
3359 "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered"
3360 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
3361 0 -> error "unreachable state"
3362 _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)
3363 step' _ _ (InnerLoopDecoding st startf p end sv cp)
3365 liftIO $ touchForeignPtr startf
3366 return $ Skip $ OuterLoop st (Just (sv, cp))
3367 step' table _ (InnerLoopDecoding st startf p end statePtr codepointPtr) = do
3368 x <- liftIO $ peek p
3369 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
3376 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
3379 transliterateOrError
3380 "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered"
3381 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
3382 _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)
3383 step' _ _ (YAndC c s) = return $ Yield c s
3384 step' _ _ D = return Stop
3386{-# INLINE decodeUtf8Arrays #-}
3389 => Stream m (A.Array Word8)
3391decodeUtf8Arrays = decodeUtf8ArraysWith ErrorOnCodingFailure
3393{-# INLINE decodeUtf8ArraysLenient #-}
3394decodeUtf8ArraysLenient ::
3396 => Stream m (A.Array Word8)
3398decodeUtf8ArraysLenient = decodeUtf8ArraysWith TransliterateCodingFailure
3400data WList = WCons !Word8 !WList | WNil
3402data EncodeState s = EncodeState s !WList
3404{-# INLINE_NORMAL encodeUtf8 #-}
3405encodeUtf8 :: Monad m => Stream m Char -> Stream m Word8
3406encodeUtf8 (Stream step state) = Stream step' (EncodeState state WNil)
3408 {-# INLINE_LATE step' #-}
3409 step' gst (EncodeState st WNil) = do
3410 r <- step (adaptState gst) st
3418 (EncodeState s (WCons (fromIntegral x) WNil))
3419 | x <= 0x7FF -> Skip (EncodeState s (ord2 c))
3423 "Streamly.Streams.StreamD.encodeUtf8: Encountered a surrogate"
3424 else Skip (EncodeState s (ord3 c))
3425 | otherwise -> Skip (EncodeState s (ord4 c))
3426 Skip s -> Skip (EncodeState s WNil)
3428 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