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
64 -- ** Specialized Generation
65 -- | Generate a monadic stream from a seed.
75 , enumerateFromStepIntegral
76 , enumerateFromIntegral
77 , enumerateFromThenIntegral
78 , enumerateFromToIntegral
79 , enumerateFromThenToIntegral
81 , enumerateFromStepNum
84 , enumerateFromToFractional
85 , enumerateFromThenToFractional
88 -- | Transform an input structure into a stream.
89 -- | Direct style stream does not support @fromFoldable@.
116 -- ** Specialized Folds
137 -- ** Flattening nested streams
140 , ConcatMapUState (..)
142 , ConcatUnfoldInterleaveState (..)
143 , concatUnfoldInterleave
144 , concatUnfoldRoundrobin
147 , InterleaveState(..)
151 , roundRobin -- interleaveFair?/ParallelFair
152 , interleaveFstThenConcat
180 -- | Transform a stream into another type.
189 -- ** By folding (scans)
255 -- * Transformation comprehensions
266 -- * UTF8 Encoding / Decoding transformations.
271 , decodeUtf8ArraysLenient
275import Control.Exception (Exception)
276import Control.Monad (void)
277import Control.Monad.Catch (MonadCatch)
278import Control.Monad.IO.Class (MonadIO(..))
279import Control.Monad.Trans (MonadTrans(lift))
280import Data.Bits (shiftR, shiftL, (.|.), (.&.))
281#if __GLASGOW_HASKELL__ >= 801
282import Data.Functor.Identity (Identity)
284import Data.Maybe (fromJust, isJust)
285import Data.Word (Word32)
286import Foreign.Ptr (Ptr)
287import Foreign.Storable (Storable(..))
288import GHC.Base (assert, Char(..), unsafeChr, ord)
289import GHC.IO.Encoding.Failure (isSurrogate)
290import GHC.Types (SPEC(..))
291import GHC.Word (Word8(..))
292import System.IO.Unsafe (unsafePerformIO)
294 hiding (map, mapM, mapM_, repeat, foldr, last, take, filter,
295 takeWhile, drop, dropWhile, all, any, maximum, minimum, elem,
296 notElem, null, head, tail, zipWith, lookup, foldr1, sequence,
297 (!!), scanl, scanl1, concatMap, replicate, enumFromTo, concat,
300import qualified Control.Monad.Catch as MC
302import Streamly.Internal.Memory.Array.Types (Array(..))
303import Streamly.Internal.Data.Fold.Types (Fold(..))
304import Streamly.Internal.Data.Pipe.Types (Pipe(..), PipeState(..))
305import Streamly.Internal.Data.SVar (MonadAsync, defState, adaptState)
306import Streamly.Internal.Data.Unfold.Types (Unfold(..))
307import Streamly.Internal.Data.Strict (Tuple'(..))
309import Streamly.Streams.StreamD.Type
311import qualified Streamly.Internal.Data.Pipe.Types as Pipe
312import qualified Streamly.Internal.Memory.Array.Types as A
313import qualified Streamly.Memory.Ring as RB
314import qualified Streamly.Streams.StreamK as K
316import Foreign.Ptr (plusPtr)
317import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
318import Foreign.ForeignPtr (ForeignPtr, touchForeignPtr)
320------------------------------------------------------------------------------
322------------------------------------------------------------------------------
324-- | An empty 'Stream'.
325{-# INLINE_NORMAL nil #-}
326nil :: Monad m => Stream m a
327nil = Stream (\_ _ -> return Stop) ()
329{-# INLINE_NORMAL consM #-}
330consM :: Monad m => m a -> Stream m a -> Stream m a
331consM m (Stream step state) = Stream step1 Nothing
333 {-# INLINE_LATE step1 #-}
334 step1 _ Nothing = m >>= \x -> return $ Yield x (Just state)
335 step1 gst (Just st) = do
339 Yield a s -> Yield a (Just s)
340 Skip s -> Skip (Just s)
343-- XXX implement in terms of consM?
344-- cons x = consM (return x)
346-- | Can fuse but has O(n^2) complexity.
347{-# INLINE_NORMAL cons #-}
348cons :: Monad m => a -> Stream m a -> Stream m a
349cons x (Stream step state) = Stream step1 Nothing
351 {-# INLINE_LATE step1 #-}
352 step1 _ Nothing = return $ Yield x (Just state)
353 step1 gst (Just st) = do
357 Yield a s -> Yield a (Just s)
358 Skip s -> Skip (Just s)
361-------------------------------------------------------------------------------
363-------------------------------------------------------------------------------
365-- Does not fuse, has the same performance as the StreamK version.
366{-# INLINE_NORMAL uncons #-}
367uncons :: Monad m => Stream m a -> m (Maybe (a, Stream m a))
368uncons (UnStream step state) = go state
371 r <- step defState st
373 Yield x s -> return $ Just (x, Stream step s)
375 Stop -> return Nothing
377------------------------------------------------------------------------------
378-- Generation by unfold
379------------------------------------------------------------------------------
381{-# INLINE_NORMAL unfoldrM #-}
382unfoldrM :: Monad m => (s -> m (Maybe (a, s))) -> s -> Stream m a
383unfoldrM next state = Stream step state
385 {-# INLINE_LATE step #-}
389 Just (x, s) -> Yield x s
392{-# INLINE_LATE unfoldr #-}
393unfoldr :: Monad m => (s -> Maybe (a, s)) -> s -> Stream m a
394unfoldr f = unfoldrM (return . f)
396-- | Convert an 'Unfold' into a 'Stream' by supplying it a seed.
398{-# INLINE_NORMAL unfold #-}
399unfold :: Monad m => Unfold m a b -> a -> Stream m b
400unfold (Unfold ustep inject) seed = Stream step Nothing
402 {-# INLINE_LATE step #-}
403 step _ Nothing = inject seed >>= return . Skip . Just
404 step _ (Just st) = do
407 Yield x s -> Yield x (Just s)
408 Skip s -> Skip (Just s)
411------------------------------------------------------------------------------
412-- Specialized Generation
413------------------------------------------------------------------------------
415repeat :: Monad m => a -> Stream m a
416repeat x = Stream (\_ _ -> return $ Yield x ()) ()
418{-# INLINE_NORMAL replicateM #-}
419replicateM :: forall m a. Monad m => Int -> m a -> Stream m a
420replicateM n p = Stream step n
422 {-# INLINE_LATE step #-}
424 | i <= 0 = return Stop
427 return $ Yield x (i - 1)
429{-# INLINE_NORMAL replicate #-}
430replicate :: Monad m => Int -> a -> Stream m a
431replicate n x = replicateM n (return x)
433-- This would not work properly for floats, therefore we put an Integral
435-- | Can be used to enumerate unbounded integrals. This does not check for
436-- overflow or underflow for bounded integrals.
437{-# INLINE_NORMAL enumerateFromStepIntegral #-}
438enumerateFromStepIntegral :: (Integral a, Monad m) => a -> a -> Stream m a
439enumerateFromStepIntegral from stride =
440 from `seq` stride `seq` Stream step from
442 {-# INLINE_LATE step #-}
443 step _ !x = return $ Yield x $! (x + stride)
445-- We are assuming that "to" is constrained by the type to be within
447{-# INLINE enumerateFromToIntegral #-}
448enumerateFromToIntegral :: (Monad m, Integral a) => a -> a -> Stream m a
449enumerateFromToIntegral from to =
450 takeWhile (<= to) $ enumerateFromStepIntegral from 1
452{-# INLINE enumerateFromIntegral #-}
453enumerateFromIntegral :: (Monad m, Integral a, Bounded a) => a -> Stream m a
454enumerateFromIntegral from = enumerateFromToIntegral from maxBound
456data EnumState a = EnumInit | EnumYield a a a | EnumStop
458{-# INLINE_NORMAL enumerateFromThenToIntegralUp #-}
459enumerateFromThenToIntegralUp
460 :: (Monad m, Integral a)
461 => a -> a -> a -> Stream m a
462enumerateFromThenToIntegralUp from next to = Stream step EnumInit
464 {-# INLINE_LATE step #-}
470 else Yield from EnumStop
471 else -- from <= next <= to
472 let stride = next - from
473 in Skip $ EnumYield from stride (to - stride)
475 step _ (EnumYield x stride toMinus) =
478 then Yield x EnumStop
479 else Yield x $ EnumYield (x + stride) stride toMinus
481 step _ EnumStop = return Stop
483{-# INLINE_NORMAL enumerateFromThenToIntegralDn #-}
484enumerateFromThenToIntegralDn
485 :: (Monad m, Integral a)
486 => a -> a -> a -> Stream m a
487enumerateFromThenToIntegralDn from next to = Stream step EnumInit
489 {-# INLINE_LATE step #-}
491 return $ if to > next
494 else Yield from EnumStop
495 else -- from >= next >= to
496 let stride = next - from
497 in Skip $ EnumYield from stride (to - stride)
499 step _ (EnumYield x stride toMinus) =
502 then Yield x EnumStop
503 else Yield x $ EnumYield (x + stride) stride toMinus
505 step _ EnumStop = return Stop
507{-# INLINE_NORMAL enumerateFromThenToIntegral #-}
508enumerateFromThenToIntegral
509 :: (Monad m, Integral a)
510 => a -> a -> a -> Stream m a
511enumerateFromThenToIntegral from next to
512 | next >= from = enumerateFromThenToIntegralUp from next to
513 | otherwise = enumerateFromThenToIntegralDn from next to
515{-# INLINE_NORMAL enumerateFromThenIntegral #-}
516enumerateFromThenIntegral
517 :: (Monad m, Integral a, Bounded a)
518 => a -> a -> Stream m a
519enumerateFromThenIntegral from next =
521 then enumerateFromThenToIntegralUp from next maxBound
522 else enumerateFromThenToIntegralDn from next minBound
524-- For floating point numbers if the increment is less than the precision then
525-- it just gets lost. Therefore we cannot always increment it correctly by just
527-- 9007199254740992 + 1 + 1 :: Double => 9.007199254740992e15
528-- 9007199254740992 + 2 :: Double => 9.007199254740994e15
530-- Instead we accumulate the increment counter and compute the increment
531-- everytime before adding it to the starting number.
533-- This works for Integrals as well as floating point numbers, but
534-- enumerateFromStepIntegral is faster for integrals.
535{-# INLINE_NORMAL enumerateFromStepNum #-}
536enumerateFromStepNum :: (Monad m, Num a) => a -> a -> Stream m a
537enumerateFromStepNum from stride = Stream step 0
539 {-# INLINE_LATE step #-}
540 step _ !i = return $ (Yield $! (from + i * stride)) $! (i + 1)
542{-# INLINE_NORMAL numFrom #-}
543numFrom :: (Monad m, Num a) => a -> Stream m a
544numFrom from = enumerateFromStepNum from 1
546{-# INLINE_NORMAL numFromThen #-}
547numFromThen :: (Monad m, Num a) => a -> a -> Stream m a
548numFromThen from next = enumerateFromStepNum from (next - from)
550-- We cannot write a general function for Num. The only way to write code
551-- portable between the two is to use a 'Real' constraint and convert between
552-- Fractional and Integral using fromRational which is horribly slow.
553{-# INLINE_NORMAL enumerateFromToFractional #-}
554enumerateFromToFractional
555 :: (Monad m, Fractional a, Ord a)
556 => a -> a -> Stream m a
557enumerateFromToFractional from to =
558 takeWhile (<= to + 1 / 2) $ enumerateFromStepNum from 1
560{-# INLINE_NORMAL enumerateFromThenToFractional #-}
561enumerateFromThenToFractional
562 :: (Monad m, Fractional a, Ord a)
563 => a -> a -> a -> Stream m a
564enumerateFromThenToFractional from next to =
565 takeWhile predicate $ numFromThen from next
567 mid = (next - from) / 2
568 predicate | next >= from = (<= to + mid)
569 | otherwise = (>= to + mid)
571-------------------------------------------------------------------------------
572-- Generation by Conversion
573-------------------------------------------------------------------------------
575{-# INLINE_NORMAL fromIndicesM #-}
576fromIndicesM :: Monad m => (Int -> m a) -> Stream m a
577fromIndicesM gen = Stream step 0
579 {-# INLINE_LATE step #-}
582 return $ Yield x (i + 1)
584{-# INLINE fromIndices #-}
585fromIndices :: Monad m => (Int -> a) -> Stream m a
586fromIndices gen = fromIndicesM (return . gen)
588{-# INLINE_NORMAL generateM #-}
589generateM :: Monad m => Int -> (Int -> m a) -> Stream m a
590generateM n gen = n `seq` Stream step 0
592 {-# INLINE_LATE step #-}
593 step _ i | i < n = do
595 return $ Yield x (i + 1)
596 | otherwise = return Stop
598{-# INLINE generate #-}
599generate :: Monad m => Int -> (Int -> a) -> Stream m a
600generate n gen = generateM n (return . gen)
602-- XXX we need the MonadAsync constraint because of a rewrite rule.
603-- | Convert a list of monadic actions to a 'Stream'
604{-# INLINE_LATE fromListM #-}
605fromListM :: MonadAsync m => [m a] -> Stream m a
606fromListM = Stream step
608 {-# INLINE_LATE step #-}
609 step _ (m:ms) = m >>= \x -> return $ Yield x ms
610 step _ [] = return Stop
612{-# INLINE toStreamD #-}
613toStreamD :: (K.IsStream t, Monad m) => t m a -> Stream m a
614toStreamD = fromStreamK . K.toStream
616------------------------------------------------------------------------------
617-- Elimination by Folds
618------------------------------------------------------------------------------
620------------------------------------------------------------------------------
622------------------------------------------------------------------------------
624{-# INLINE_NORMAL foldr1 #-}
625foldr1 :: Monad m => (a -> a -> a) -> Stream m a -> m (Maybe a)
629 Nothing -> return Nothing
630 Just (h, t) -> fmap Just (foldr f h t)
632------------------------------------------------------------------------------
634------------------------------------------------------------------------------
636{-# INLINE_NORMAL foldlT #-}
637foldlT :: (Monad m, Monad (s m), MonadTrans s)
638 => (s m b -> a -> s m b) -> s m b -> Stream m a -> s m b
639foldlT fstep begin (Stream step state) = go SPEC begin state
642 r <- lift $ step defState st
644 Yield x s -> go SPEC (fstep acc x) s
645 Skip s -> go SPEC acc s
648-- Note, this is going to have horrible performance, because of the nature of
649-- the stream type (i.e. direct stream vs CPS). Its only for reference, it is
650-- likely be practically unusable.
651{-# INLINE_NORMAL foldlS #-}
653 => (Stream m b -> a -> Stream m b) -> Stream m b -> Stream m a -> Stream m b
654foldlS fstep begin (Stream step state) = Stream step' (Left (state, begin))
656 step' gst (Left (st, acc)) = do
657 r <- step (adaptState gst) st
659 Yield x s -> Skip (Left (s, fstep acc x))
660 Skip s -> Skip (Left (s, acc))
661 Stop -> Skip (Right acc)
663 step' gst (Right (Stream stp stt)) = do
664 r <- stp (adaptState gst) stt
666 Yield x s -> Yield x (Right (Stream stp s))
667 Skip s -> Skip (Right (Stream stp s))
670------------------------------------------------------------------------------
672------------------------------------------------------------------------------
674-- | Run a streaming composition, discard the results.
675{-# INLINE_LATE drain #-}
676drain :: Monad m => Stream m a -> m ()
677-- drain = foldrM (\_ xs -> xs) (return ())
678drain (Stream step state) = go SPEC state
681 r <- step defState st
683 Yield _ s -> go SPEC s
687{-# INLINE_NORMAL null #-}
688null :: Monad m => Stream m a -> m Bool
689null m = foldrM (\_ _ -> return False) (return True) m
691{-# INLINE_NORMAL head #-}
692head :: Monad m => Stream m a -> m (Maybe a)
693head m = foldrM (\x _ -> return (Just x)) (return Nothing) m
695-- Does not fuse, has the same performance as the StreamK version.
696{-# INLINE_NORMAL tail #-}
697tail :: Monad m => Stream m a -> m (Maybe (Stream m a))
698tail (UnStream step state) = go state
701 r <- step defState st
703 Yield _ s -> return (Just $ Stream step s)
705 Stop -> return Nothing
707-- XXX will it fuse? need custom impl?
708{-# INLINE_NORMAL last #-}
709last :: Monad m => Stream m a -> m (Maybe a)
710last = foldl' (\_ y -> Just y) Nothing
712{-# INLINE_NORMAL elem #-}
713elem :: (Monad m, Eq a) => a -> Stream m a -> m Bool
714-- elem e m = foldrM (\x xs -> if x == e then return True else xs) (return False) m
715elem e (Stream step state) = go state
718 r <- step defState st
721 | x == e -> return True
726{-# INLINE_NORMAL notElem #-}
727notElem :: (Monad m, Eq a) => a -> Stream m a -> m Bool
728notElem e s = fmap not (elem e s)
730{-# INLINE_NORMAL all #-}
731all :: Monad m => (a -> Bool) -> Stream m a -> m Bool
732-- all p m = foldrM (\x xs -> if p x then xs else return False) (return True) m
733all p (Stream step state) = go state
736 r <- step defState st
740 | otherwise -> return False
744{-# INLINE_NORMAL any #-}
745any :: Monad m => (a -> Bool) -> Stream m a -> m Bool
746-- any p m = foldrM (\x xs -> if p x then return True else xs) (return False) m
747any p (Stream step state) = go state
750 r <- step defState st
758{-# INLINE_NORMAL maximum #-}
759maximum :: (Monad m, Ord a) => Stream m a -> m (Maybe a)
760maximum (Stream step state) = go Nothing state
763 r <- step defState st
765 Yield x s -> go (Just x) s
766 Skip s -> go Nothing s
767 Stop -> return Nothing
768 go (Just acc) st = do
769 r <- step defState st
772 | acc <= x -> go (Just x) s
773 | otherwise -> go (Just acc) s
774 Skip s -> go (Just acc) s
775 Stop -> return (Just acc)
777{-# INLINE_NORMAL maximumBy #-}
778maximumBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> m (Maybe a)
779maximumBy cmp (Stream step state) = go Nothing state
782 r <- step defState st
784 Yield x s -> go (Just x) s
785 Skip s -> go Nothing s
786 Stop -> return Nothing
787 go (Just acc) st = do
788 r <- step defState st
790 Yield x s -> case cmp acc x of
791 GT -> go (Just acc) s
793 Skip s -> go (Just acc) s
794 Stop -> return (Just acc)
796{-# INLINE_NORMAL minimum #-}
797minimum :: (Monad m, Ord a) => Stream m a -> m (Maybe a)
798minimum (Stream step state) = go Nothing state
801 r <- step defState st
803 Yield x s -> go (Just x) s
804 Skip s -> go Nothing s
805 Stop -> return Nothing
806 go (Just acc) st = do
807 r <- step defState st
810 | acc <= x -> go (Just acc) s
811 | otherwise -> go (Just x) s
812 Skip s -> go (Just acc) s
813 Stop -> return (Just acc)
815{-# INLINE_NORMAL minimumBy #-}
816minimumBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> m (Maybe a)
817minimumBy cmp (Stream step state) = go Nothing state
820 r <- step defState st
822 Yield x s -> go (Just x) s
823 Skip s -> go Nothing s
824 Stop -> return Nothing
825 go (Just acc) st = do
826 r <- step defState st
828 Yield x s -> case cmp acc x of
831 Skip s -> go (Just acc) s
832 Stop -> return (Just acc)
834{-# INLINE_NORMAL (!!) #-}
835(!!) :: (Monad m) => Stream m a -> Int -> m (Maybe a)
836(Stream step state) !! i = go i state
839 r <- step defState st
841 Yield x s | n < 0 -> return Nothing
842 | n == 0 -> return $ Just x
843 | otherwise -> go (n - 1) s
845 Stop -> return Nothing
847{-# INLINE_NORMAL lookup #-}
848lookup :: (Monad m, Eq a) => a -> Stream m (a, b) -> m (Maybe b)
849lookup e m = foldrM (\(a, b) xs -> if e == a then return (Just b) else xs)
852{-# INLINE_NORMAL findM #-}
853findM :: Monad m => (a -> m Bool) -> Stream m a -> m (Maybe a)
854findM p m = foldrM (\x xs -> p x >>= \r -> if r then return (Just x) else xs)
858find :: Monad m => (a -> Bool) -> Stream m a -> m (Maybe a)
859find p = findM (return . p)
861{-# INLINE_NORMAL findIndices #-}
862findIndices :: Monad m => (a -> Bool) -> Stream m a -> Stream m Int
863findIndices p (Stream step state) = Stream step' (state, 0)
865 {-# INLINE_LATE step' #-}
866 step' gst (st, i) = do
867 r <- step (adaptState gst) st
869 Yield x s -> if p x then Yield i (s, i+1) else Skip (s, i+1)
870 Skip s -> Skip (s, i+1)
873{-# INLINE toListRev #-}
874toListRev :: Monad m => Stream m a -> m [a]
875toListRev = foldl' (flip (:)) []
877-- We can implement reverse as:
879-- > reverse = foldlS (flip cons) nil
881-- However, this implementation is unusable because of the horrible performance
882-- of cons. So we just convert it to a list first and then stream from the
885-- XXX Maybe we can use an Array instead of a list here?
886{-# INLINE_NORMAL reverse #-}
887reverse :: Monad m => Stream m a -> Stream m a
888reverse m = Stream step Nothing
890 {-# INLINE_LATE step #-}
893 return $ Skip (Just xs)
894 step _ (Just (x:xs)) = return $ Yield x (Just xs)
895 step _ (Just []) = return Stop
897-- Much faster reverse for Storables
898{-# INLINE_NORMAL reverse' #-}
899reverse' :: forall m a. (MonadIO m, Storable a) => Stream m a -> Stream m a
901-- This commented implementation copies the whole stream into one single array
902-- and then streams from that array, this is 3-4x faster than the chunked code
903-- that follows. Though this could be problematic due to unbounded large
904-- allocations. We need to figure out why the chunked code is slower and if we
905-- can optimize the chunked code to work as fast as this one. It may be a
907import Foreign.ForeignPtr (touchForeignPtr)
908import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
909import Foreign.Ptr (Ptr, plusPtr)
910reverse' m = Stream step Nothing
912 {-# INLINE_LATE step #-}
914 arr <- A.fromStreamD m
915 let p = aEnd arr `plusPtr` negate (sizeOf (undefined :: a))
916 return $ Skip $ Just (aStart arr, p)
918 step _ (Just (start, p)) | p < unsafeForeignPtrToPtr start = return Stop
920 step _ (Just (start, p)) = do
921 let !x = A.unsafeInlineIO $ do
923 touchForeignPtr start
925 next = p `plusPtr` negate (sizeOf (undefined :: a))
926 return $ Yield x (Just (start, next))
933 $ A.fromStreamDArraysOf A.defaultChunkSize m
936------------------------------------------------------------------------------
938------------------------------------------------------------------------------
940{-# INLINE_NORMAL splitSuffixBy' #-}
941splitSuffixBy' :: Monad m
942 => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
943splitSuffixBy' predicate f (Stream step state) =
944 Stream (stepOuter f) (Just state)
948 {-# INLINE_LATE stepOuter #-}
949 stepOuter (Fold fstep initial done) gst (Just st) = do
950 res <- step (adaptState gst) st
956 then done acc' >>= \val -> return $ Yield val (Just s)
959 Skip s -> return $ Skip $ Just s
965 res <- step (adaptState gst) stt
970 then done acc' >>= \val -> return $ Yield val (Just s)
972 Skip s -> go SPEC s acc
973 Stop -> done acc >>= \val -> return $ Yield val Nothing
975 stepOuter _ _ Nothing = return Stop
977{-# INLINE_NORMAL groupsBy #-}
983groupsBy cmp f (Stream step state) = Stream (stepOuter f) (Just state, Nothing)
987 {-# INLINE_LATE stepOuter #-}
988 stepOuter (Fold fstep initial done) gst (Just st, Nothing) = do
989 res <- step (adaptState gst) st
996 Skip s -> return $ Skip $ (Just s, Nothing)
1001 go !_ prev stt !acc = do
1002 res <- step (adaptState gst) stt
1009 else done acc >>= \r -> return $ Yield r (Just s, Just x)
1010 Skip s -> go SPEC prev s acc
1011 Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1013 stepOuter (Fold fstep initial done) gst (Just st, Just prev) = do
1015 acc' <- fstep acc prev
1020 -- XXX code duplicated from the previous equation
1022 res <- step (adaptState gst) stt
1029 else done acc >>= \r -> return $ Yield r (Just s, Just x)
1030 Skip s -> go SPEC s acc
1031 Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1033 stepOuter _ _ (Nothing,_) = return Stop
1035{-# INLINE_NORMAL groupsRollingBy #-}
1036groupsRollingBy :: Monad m
1041groupsRollingBy cmp f (Stream step state) =
1042 Stream (stepOuter f) (Just state, Nothing)
1045 {-# INLINE_LATE stepOuter #-}
1046 stepOuter (Fold fstep initial done) gst (Just st, Nothing) = do
1047 res <- step (adaptState gst) st
1054 Skip s -> return $ Skip $ (Just s, Nothing)
1058 go !_ prev stt !acc = do
1059 res <- step (adaptState gst) stt
1067 done acc >>= \r -> return $ Yield r (Just s, Just x)
1068 Skip s -> go SPEC prev s acc
1069 Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1071 stepOuter (Fold fstep initial done) gst (Just st, Just prev') = do
1073 acc' <- fstep acc prev'
1074 go SPEC prev' st acc'
1077 go !_ prevv stt !acc = do
1078 res <- step (adaptState gst) stt
1085 else done acc >>= \r -> return $ Yield r (Just s, Just x)
1086 Skip s -> go SPEC prevv s acc
1087 Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1089 stepOuter _ _ (Nothing, _) = return Stop
1091{-# INLINE_NORMAL splitBy #-}
1092splitBy :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
1093splitBy predicate f (Stream step state) = Stream (step' f) (Just state)
1097 {-# INLINE_LATE step' #-}
1098 step' (Fold fstep initial done) gst (Just st) = initial >>= go SPEC st
1103 res <- step (adaptState gst) stt
1107 then done acc >>= \r -> return $ Yield r (Just s)
1111 Skip s -> go SPEC s acc
1112 Stop -> done acc >>= \r -> return $ Yield r Nothing
1114 step' _ _ Nothing = return Stop
1116-- XXX requires -funfolding-use-threshold=150 in lines-unlines benchmark
1117{-# INLINE_NORMAL splitSuffixBy #-}
1118splitSuffixBy :: Monad m
1119 => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
1120splitSuffixBy predicate f (Stream step state) = Stream (step' f) (Just state)
1124 {-# INLINE_LATE step' #-}
1125 step' (Fold fstep initial done) gst (Just st) = do
1126 res <- step (adaptState gst) st
1131 then done acc >>= \val -> return $ Yield val (Just s)
1136 Skip s -> return $ Skip $ Just s
1142 res <- step (adaptState gst) stt
1146 then done acc >>= \r -> return $ Yield r (Just s)
1150 Skip s -> go SPEC s acc
1151 Stop -> done acc >>= \r -> return $ Yield r Nothing
1153 step' _ _ Nothing = return Stop
1155{-# INLINE_NORMAL wordsBy #-}
1156wordsBy :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
1157wordsBy predicate f (Stream step state) = Stream (stepOuter f) (Just state)
1161 {-# INLINE_LATE stepOuter #-}
1162 stepOuter (Fold fstep initial done) gst (Just st) = do
1163 res <- step (adaptState gst) st
1167 then return $ Skip (Just s)
1173 Skip s -> return $ Skip $ Just s
1179 res <- step (adaptState gst) stt
1183 then done acc >>= \r -> return $ Yield r (Just s)
1187 Skip s -> go SPEC s acc
1188 Stop -> done acc >>= \r -> return $ Yield r Nothing
1190 stepOuter _ _ Nothing = return Stop
1192-- String search algorithms:
1193-- http://www-igm.univ-mlv.fr/~lecroq/string/index.html
1196-- TODO can we unify the splitting operations using a splitting configuration
1197-- like in the split package.
1199data SplitStyle = Infix | Suffix | Prefix deriving (Eq, Show)
1201data SplitOptions = SplitOptions
1202 { style :: SplitStyle
1203 , withSep :: Bool -- ^ keep the separators in output
1204 -- , compact :: Bool -- ^ treat multiple consecutive separators as one
1205 -- , trimHead :: Bool -- ^ drop blank at head
1206 -- , trimTail :: Bool -- ^ drop blank at tail
1210data SplitOnState s a =
1215 | GO_KARP_RABIN s !(RB.Ring a) !(Ptr a)
1218{-# INLINE_NORMAL splitOn #-}
1220 :: forall m a b. (MonadIO m, Storable a, Enum a, Eq a)
1225splitOn patArr@Array{..} (Fold fstep initial done) (Stream step state) =
1226 Stream stepOuter GO_START
1230 patLen = A.length patArr
1231 maxIndex = patLen - 1
1232 elemBits = sizeOf (undefined :: a) * 8
1234 {-# INLINE_LATE stepOuter #-}
1235 stepOuter _ GO_START =
1237 then return $ Skip $ GO_EMPTY_PAT state
1240 r <- liftIO $ (A.unsafeIndexIO patArr 0)
1241 return $ Skip $ GO_SINGLE_PAT state r
1242 else if sizeOf (undefined :: a) * patLen
1243 <= sizeOf (undefined :: Word)
1244 then return $ Skip $ GO_SHORT_PAT state
1246 (rb, rhead) <- liftIO $ RB.new patLen
1247 return $ Skip $ GO_KARP_RABIN state rb rhead
1249 stepOuter gst (GO_SINGLE_PAT stt pat) = initial >>= go SPEC stt
1254 res <- step (adaptState gst) st
1260 return $ Yield r (GO_SINGLE_PAT s pat)
1261 else fstep acc x >>= go SPEC s
1262 Skip s -> go SPEC s acc
1263 Stop -> done acc >>= \r -> return $ Yield r GO_DONE
1265 stepOuter gst (GO_SHORT_PAT stt) = initial >>= go0 SPEC 0 (0 :: Word) stt
1270 mask = (1 `shiftL` (elemBits * patLen)) - 1
1272 addToWord wrd a = (wrd `shiftL` elemBits) .|. fromIntegral (fromEnum a)
1275 patWord = mask .&. A.foldl' addToWord 0 patArr
1277 go0 !_ !idx wrd st !acc = do
1278 res <- step (adaptState gst) st
1281 let wrd' = addToWord wrd x
1284 if wrd' .&. mask == patWord
1287 return $ Yield r (GO_SHORT_PAT s)
1288 else go1 SPEC wrd' s acc
1289 else go0 SPEC (idx + 1) wrd' s acc
1290 Skip s -> go0 SPEC idx wrd s acc
1293 then go2 wrd idx acc
1295 done acc' >>= \r -> return $ Yield r GO_DONE
1298 go1 !_ wrd st !acc = do
1299 res <- step (adaptState gst) st
1302 let wrd' = addToWord wrd x
1303 old = (mask .&. wrd) `shiftR` (elemBits * (patLen - 1))
1304 acc' <- fstep acc (toEnum $ fromIntegral old)
1305 if wrd' .&. mask == patWord
1306 then done acc' >>= \r -> return $ Yield r (GO_SHORT_PAT s)
1307 else go1 SPEC wrd' s acc'
1308 Skip s -> go1 SPEC wrd s acc
1310 acc' <- go2 wrd patLen acc
1311 done acc' >>= \r -> return $ Yield r GO_DONE
1313 go2 !wrd !n !acc | n > 0 = do
1314 let old = (mask .&. wrd) `shiftR` (elemBits * (n - 1))
1315 fstep acc (toEnum $ fromIntegral old) >>= go2 wrd (n - 1)
1316 go2 _ _ acc = return acc
1318 stepOuter gst (GO_KARP_RABIN stt rb rhead) = do
1319 initial >>= go0 SPEC 0 rhead stt
1323 k = 2891336453 :: Word32
1325 addCksum cksum a = cksum * k + fromIntegral (fromEnum a)
1326 deltaCksum cksum old new =
1327 addCksum cksum new - coeff * fromIntegral (fromEnum old)
1329 -- XXX shall we use a random starting hash or 1 instead of 0?
1330 patHash = A.foldl' addCksum 0 patArr
1333 go0 !_ !idx !rh st !acc = do
1334 res <- step (adaptState gst) st
1337 rh' <- liftIO $ RB.unsafeInsert rb rh x
1340 let fold = RB.unsafeFoldRing (RB.ringBound rb)
1341 let !ringHash = fold addCksum 0 rb
1342 if ringHash == patHash
1343 then go2 SPEC ringHash rh' s acc
1344 else go1 SPEC ringHash rh' s acc
1345 else go0 SPEC (idx + 1) rh' s acc
1346 Skip s -> go0 SPEC idx rh s acc
1348 !acc' <- if idx /= 0
1349 then RB.unsafeFoldRingM rh fstep acc rb
1351 done acc' >>= \r -> return $ Yield r GO_DONE
1353 -- XXX Theoretically this code can do 4 times faster if GHC generates
1354 -- optimal code. If we use just "(cksum' == patHash)" condition it goes
1355 -- 4x faster, as soon as we add the "RB.unsafeEqArray rb v" condition
1356 -- the generated code changes drastically and becomes 4x slower. Need
1357 -- to investigate what is going on with GHC.
1359 go1 !_ !cksum !rh st !acc = do
1360 res <- step (adaptState gst) st
1363 old <- liftIO $ peek rh
1364 let cksum' = deltaCksum cksum old x
1365 acc' <- fstep acc old
1367 if (cksum' == patHash)
1369 rh' <- liftIO (RB.unsafeInsert rb rh x)
1370 go2 SPEC cksum' rh' s acc'
1372 rh' <- liftIO (RB.unsafeInsert rb rh x)
1373 go1 SPEC cksum' rh' s acc'
1374 Skip s -> go1 SPEC cksum rh s acc
1376 acc' <- RB.unsafeFoldRingFullM rh fstep acc rb
1377 done acc' >>= \r -> return $ Yield r GO_DONE
1379 go2 !_ !cksum' !rh' s !acc' = do
1380 if RB.unsafeEqArray rb rh' patArr
1383 return $ Yield r (GO_KARP_RABIN s rb rhead)
1384 else go1 SPEC cksum' rh' s acc'
1386 stepOuter gst (GO_EMPTY_PAT st) = do
1387 res <- step (adaptState gst) st
1392 done acc' >>= \r -> return $ Yield r (GO_EMPTY_PAT s)
1393 Skip s -> return $ Skip (GO_EMPTY_PAT s)
1396 stepOuter _ GO_DONE = return Stop
1398{-# INLINE_NORMAL splitSuffixOn #-}
1400 :: forall m a b. (MonadIO m, Storable a, Enum a, Eq a)
1406splitSuffixOn withSep patArr@Array{..} (Fold fstep initial done)
1407 (Stream step state) =
1408 Stream stepOuter GO_START
1412 patLen = A.length patArr
1413 maxIndex = patLen - 1
1414 elemBits = sizeOf (undefined :: a) * 8
1416 {-# INLINE_LATE stepOuter #-}
1417 stepOuter _ GO_START =
1419 then return $ Skip $ GO_EMPTY_PAT state
1422 r <- liftIO $ (A.unsafeIndexIO patArr 0)
1423 return $ Skip $ GO_SINGLE_PAT state r
1424 else if sizeOf (undefined :: a) * patLen
1425 <= sizeOf (undefined :: Word)
1426 then return $ Skip $ GO_SHORT_PAT state
1428 (rb, rhead) <- liftIO $ RB.new patLen
1429 return $ Skip $ GO_KARP_RABIN state rb rhead
1431 stepOuter gst (GO_SINGLE_PAT stt pat) = do
1432 -- This first part is the only difference between splitOn and
1434 -- If the last element is a separator do not issue a blank segment.
1435 res <- step (adaptState gst) stt
1441 acc' <- if withSep then fstep acc x else return acc
1442 done acc' >>= \r -> return $ Yield r (GO_SINGLE_PAT s pat)
1443 else fstep acc x >>= go SPEC s
1444 Skip s -> return $ Skip $ (GO_SINGLE_PAT s pat)
1449 -- This is identical for splitOn and splitSuffixOn
1451 res <- step (adaptState gst) st
1456 acc' <- if withSep then fstep acc x else return acc
1458 return $ Yield r (GO_SINGLE_PAT s pat)
1459 else fstep acc x >>= go SPEC s
1460 Skip s -> go SPEC s acc
1461 Stop -> done acc >>= \r -> return $ Yield r GO_DONE
1463 stepOuter gst (GO_SHORT_PAT stt) = do
1465 -- Call "initial" only if the stream yields an element, otherwise we
1466 -- may call "initial" but never yield anything. initial may produce a
1467 -- side effect, therefore we will end up doing and discard a side
1472 res <- step (adaptState gst) stt
1476 let wrd' = addToWord wrd x
1477 acc' <- if withSep then fstep acc x else return acc
1480 if wrd' .&. mask == patWord
1481 then done acc' >>= \r -> return $ Yield r (GO_SHORT_PAT s)
1482 else go0 SPEC (idx + 1) wrd' s acc'
1483 else go0 SPEC (idx + 1) wrd' s acc'
1484 Skip s -> return $ Skip (GO_SHORT_PAT s)
1490 mask = (1 `shiftL` (elemBits * patLen)) - 1
1492 addToWord wrd a = (wrd `shiftL` elemBits) .|. fromIntegral (fromEnum a)
1495 patWord = mask .&. A.foldl' addToWord 0 patArr
1497 go0 !_ !idx wrd st !acc = do
1498 res <- step (adaptState gst) st
1501 let wrd' = addToWord wrd x
1502 acc' <- if withSep then fstep acc x else return acc
1505 if wrd' .&. mask == patWord
1508 return $ Yield r (GO_SHORT_PAT s)
1509 else go1 SPEC wrd' s acc'
1510 else go0 SPEC (idx + 1) wrd' s acc'
1511 Skip s -> go0 SPEC idx wrd s acc
1513 if (idx == maxIndex) && (wrd .&. mask == patWord)
1516 acc' <- if idx /= 0 && not withSep
1517 then go2 wrd idx acc
1519 done acc' >>= \r -> return $ Yield r GO_DONE
1522 go1 !_ wrd st !acc = do
1523 res <- step (adaptState gst) st
1526 let wrd' = addToWord wrd x
1527 old = (mask .&. wrd) `shiftR` (elemBits * (patLen - 1))
1530 else fstep acc (toEnum $ fromIntegral old)
1531 if wrd' .&. mask == patWord
1532 then done acc' >>= \r -> return $ Yield r (GO_SHORT_PAT s)
1533 else go1 SPEC wrd' s acc'
1534 Skip s -> go1 SPEC wrd s acc
1536 -- If the last sequence is a separator do not issue a blank
1538 if wrd .&. mask == patWord
1543 else go2 wrd patLen acc
1544 done acc' >>= \r -> return $ Yield r GO_DONE
1546 go2 !wrd !n !acc | n > 0 = do
1547 let old = (mask .&. wrd) `shiftR` (elemBits * (n - 1))
1548 fstep acc (toEnum $ fromIntegral old) >>= go2 wrd (n - 1)
1549 go2 _ _ acc = return acc
1551 stepOuter gst (GO_KARP_RABIN stt rb rhead) = do
1553 res <- step (adaptState gst) stt
1557 acc' <- if withSep then fstep acc x else return acc
1558 rh' <- liftIO (RB.unsafeInsert rb rhead x)
1561 let fold = RB.unsafeFoldRing (RB.ringBound rb)
1562 let !ringHash = fold addCksum 0 rb
1563 if ringHash == patHash
1564 then go2 SPEC ringHash rh' s acc'
1565 else go0 SPEC (idx + 1) rh' s acc'
1566 else go0 SPEC (idx + 1) rh' s acc'
1567 Skip s -> return $ Skip (GO_KARP_RABIN s rb rhead)
1572 k = 2891336453 :: Word32
1574 addCksum cksum a = cksum * k + fromIntegral (fromEnum a)
1575 deltaCksum cksum old new =
1576 addCksum cksum new - coeff * fromIntegral (fromEnum old)
1578 -- XXX shall we use a random starting hash or 1 instead of 0?
1579 patHash = A.foldl' addCksum 0 patArr
1582 go0 !_ !idx !rh st !acc = do
1583 res <- step (adaptState gst) st
1586 acc' <- if withSep then fstep acc x else return acc
1587 rh' <- liftIO (RB.unsafeInsert rb rh x)
1590 let fold = RB.unsafeFoldRing (RB.ringBound rb)
1591 let !ringHash = fold addCksum 0 rb
1592 if ringHash == patHash
1593 then go2 SPEC ringHash rh' s acc'
1594 else go1 SPEC ringHash rh' s acc'
1595 else go0 SPEC (idx + 1) rh' s acc'
1596 Skip s -> go0 SPEC idx rh s acc
1598 -- do not issue a blank segment when we end at pattern
1599 if (idx == maxIndex) && RB.unsafeEqArray rb rh patArr
1602 !acc' <- if idx /= 0 && not withSep
1603 then RB.unsafeFoldRingM rh fstep acc rb
1605 done acc' >>= \r -> return $ Yield r GO_DONE
1607 -- XXX Theoretically this code can do 4 times faster if GHC generates
1608 -- optimal code. If we use just "(cksum' == patHash)" condition it goes
1609 -- 4x faster, as soon as we add the "RB.unsafeEqArray rb v" condition
1610 -- the generated code changes drastically and becomes 4x slower. Need
1611 -- to investigate what is going on with GHC.
1613 go1 !_ !cksum !rh st !acc = do
1614 res <- step (adaptState gst) st
1617 old <- liftIO $ peek rh
1618 let cksum' = deltaCksum cksum old x
1623 if (cksum' == patHash)
1625 rh' <- liftIO (RB.unsafeInsert rb rh x)
1626 go2 SPEC cksum' rh' s acc'
1628 rh' <- liftIO (RB.unsafeInsert rb rh x)
1629 go1 SPEC cksum' rh' s acc'
1630 Skip s -> go1 SPEC cksum rh s acc
1632 if RB.unsafeEqArray rb rh patArr
1637 else RB.unsafeFoldRingFullM rh fstep acc rb
1638 done acc' >>= \r -> return $ Yield r GO_DONE
1640 go2 !_ !cksum' !rh' s !acc' = do
1641 if RB.unsafeEqArray rb rh' patArr
1644 return $ Yield r (GO_KARP_RABIN s rb rhead)
1645 else go1 SPEC cksum' rh' s acc'
1647 stepOuter gst (GO_EMPTY_PAT st) = do
1648 res <- step (adaptState gst) st
1653 done acc' >>= \r -> return $ Yield r (GO_EMPTY_PAT s)
1654 Skip s -> return $ Skip (GO_EMPTY_PAT s)
1657 stepOuter _ GO_DONE = return Stop
1659data SplitState s arr
1661 | SplitBuffering s arr
1662 | SplitSplitting s arr
1663 | SplitYielding arr (SplitState s arr)
1666-- XXX An alternative approach would be to use a partial fold (Fold m a b) to
1667-- split using a splitBy like combinator. The Fold would consume upto the
1668-- separator and return any leftover which can then be fed to the next fold.
1670-- We can revisit this once we have partial folds/parsers.
1672-- | Performs infix separator style splitting.
1673{-# INLINE_NORMAL splitInnerBy #-}
1676 => (f a -> m (f a, Maybe (f a))) -- splitter
1677 -> (f a -> f a -> m (f a)) -- joiner
1680splitInnerBy splitter joiner (Stream step1 state1) =
1681 (Stream step (SplitInitial state1))
1685 {-# INLINE_LATE step #-}
1686 step gst (SplitInitial st) = do
1690 (x1, mx2) <- splitter x
1691 return $ case mx2 of
1692 Nothing -> Skip (SplitBuffering s x1)
1693 Just x2 -> Skip (SplitYielding x1 (SplitSplitting s x2))
1694 Skip s -> return $ Skip (SplitInitial s)
1695 Stop -> return $ Stop
1697 step gst (SplitBuffering st buf) = do
1701 (x1, mx2) <- splitter x
1702 buf' <- joiner buf x1
1703 return $ case mx2 of
1704 Nothing -> Skip (SplitBuffering s buf')
1705 Just x2 -> Skip (SplitYielding buf' (SplitSplitting s x2))
1706 Skip s -> return $ Skip (SplitBuffering s buf)
1707 Stop -> return $ Skip (SplitYielding buf SplitFinishing)
1709 step _ (SplitSplitting st buf) = do
1710 (x1, mx2) <- splitter buf
1711 return $ case mx2 of
1712 Nothing -> Skip $ SplitBuffering st x1
1713 Just x2 -> Skip $ SplitYielding x1 (SplitSplitting st x2)
1715 step _ (SplitYielding x next) = return $ Yield x next
1716 step _ SplitFinishing = return $ Stop
1718-- | Performs infix separator style splitting.
1719{-# INLINE_NORMAL splitInnerBySuffix #-}
1721 :: (Monad m, Eq (f a), Monoid (f a))
1722 => (f a -> m (f a, Maybe (f a))) -- splitter
1723 -> (f a -> f a -> m (f a)) -- joiner
1726splitInnerBySuffix splitter joiner (Stream step1 state1) =
1727 (Stream step (SplitInitial state1))
1731 {-# INLINE_LATE step #-}
1732 step gst (SplitInitial st) = do
1736 (x1, mx2) <- splitter x
1737 return $ case mx2 of
1738 Nothing -> Skip (SplitBuffering s x1)
1739 Just x2 -> Skip (SplitYielding x1 (SplitSplitting s x2))
1740 Skip s -> return $ Skip (SplitInitial s)
1741 Stop -> return $ Stop
1743 step gst (SplitBuffering st buf) = do
1747 (x1, mx2) <- splitter x
1748 buf' <- joiner buf x1
1749 return $ case mx2 of
1750 Nothing -> Skip (SplitBuffering s buf')
1751 Just x2 -> Skip (SplitYielding buf' (SplitSplitting s x2))
1752 Skip s -> return $ Skip (SplitBuffering s buf)
1756 else Skip (SplitYielding buf SplitFinishing)
1758 step _ (SplitSplitting st buf) = do
1759 (x1, mx2) <- splitter buf
1760 return $ case mx2 of
1761 Nothing -> Skip $ SplitBuffering st x1
1762 Just x2 -> Skip $ SplitYielding x1 (SplitSplitting st x2)
1764 step _ (SplitYielding x next) = return $ Yield x next
1765 step _ SplitFinishing = return $ Stop
1767------------------------------------------------------------------------------
1769------------------------------------------------------------------------------
1771{-# INLINE_NORMAL isPrefixOf #-}
1772isPrefixOf :: (Eq a, Monad m) => Stream m a -> Stream m a -> m Bool
1773isPrefixOf (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)
1775 go (sa, sb, Nothing) = do
1776 r <- stepa defState sa
1778 Yield x sa' -> go (sa', sb, Just x)
1779 Skip sa' -> go (sa', sb, Nothing)
1782 go (sa, sb, Just x) = do
1783 r <- stepb defState sb
1787 then go (sa, sb', Nothing)
1789 Skip sb' -> go (sa, sb', Just x)
1790 Stop -> return False
1792{-# INLINE_NORMAL isSubsequenceOf #-}
1793isSubsequenceOf :: (Eq a, Monad m) => Stream m a -> Stream m a -> m Bool
1794isSubsequenceOf (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)
1796 go (sa, sb, Nothing) = do
1797 r <- stepa defState sa
1799 Yield x sa' -> go (sa', sb, Just x)
1800 Skip sa' -> go (sa', sb, Nothing)
1803 go (sa, sb, Just x) = do
1804 r <- stepb defState sb
1808 then go (sa, sb', Nothing)
1809 else go (sa, sb', Just x)
1810 Skip sb' -> go (sa, sb', Just x)
1811 Stop -> return False
1813{-# INLINE_NORMAL stripPrefix #-}
1816 => Stream m a -> Stream m a -> m (Maybe (Stream m a))
1817stripPrefix (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)
1819 go (sa, sb, Nothing) = do
1820 r <- stepa defState sa
1822 Yield x sa' -> go (sa', sb, Just x)
1823 Skip sa' -> go (sa', sb, Nothing)
1824 Stop -> return $ Just (Stream stepb sb)
1826 go (sa, sb, Just x) = do
1827 r <- stepb defState sb
1831 then go (sa, sb', Nothing)
1833 Skip sb' -> go (sa, sb', Just x)
1834 Stop -> return Nothing
1836------------------------------------------------------------------------------
1838------------------------------------------------------------------------------
1840-- | Execute a monadic action for each element of the 'Stream'
1841{-# INLINE_NORMAL mapM_ #-}
1842mapM_ :: Monad m => (a -> m b) -> Stream m a -> m ()
1843mapM_ m = drain . mapM m
1845-------------------------------------------------------------------------------
1846-- Stream transformations using Unfolds
1847-------------------------------------------------------------------------------
1849-- Define a unique structure to use in inspection testing
1850data ConcatMapUState o i =
1852 | ConcatMapUInner o i
1854-- | @concatMapU unfold stream@ uses @unfold@ to map the input stream elements
1855-- to streams and then flattens the generated streams into a single output
1858-- This is like 'concatMap' but uses an unfold with an explicit state to
1859-- generate the stream instead of a 'Stream' type generator. This allows better
1860-- optimization via fusion. This can be many times more efficient than
1863{-# INLINE_NORMAL concatMapU #-}
1864concatMapU :: Monad m => Unfold m a b -> Stream m a -> Stream m b
1865concatMapU (Unfold istep inject) (Stream ostep ost) =
1866 Stream step (ConcatMapUOuter ost)
1868 {-# INLINE_LATE step #-}
1869 step gst (ConcatMapUOuter o) = do
1870 r <- ostep (adaptState gst) o
1874 i `seq` return (Skip (ConcatMapUInner o' i))
1875 Skip o' -> return $ Skip (ConcatMapUOuter o')
1876 Stop -> return $ Stop
1878 step _ (ConcatMapUInner o i) = do
1881 Yield x i' -> Yield x (ConcatMapUInner o i')
1882 Skip i' -> Skip (ConcatMapUInner o i')
1883 Stop -> Skip (ConcatMapUOuter o)
1885data ConcatUnfoldInterleaveState o i =
1886 ConcatUnfoldInterleaveOuter o [i]
1887 | ConcatUnfoldInterleaveInner o [i]
1888 | ConcatUnfoldInterleaveInnerL [i] [i]
1889 | ConcatUnfoldInterleaveInnerR [i] [i]
1891-- XXX use arrays to store state instead of lists.
1892-- XXX In general we can use different scheduling strategies e.g. how to
1893-- schedule the outer vs inner loop or assigning weights to different streams
1894-- or outer and inner loops.
1896-- After a yield, switch to the next stream. Do not switch streams on Skip.
1897-- Yield from outer stream switches to the inner stream.
1899-- There are two choices here, (1) exhaust the outer stream first and then
1900-- start yielding from the inner streams, this is much simpler to implement,
1901-- (2) yield at least one element from an inner stream before going back to
1902-- outer stream and opening the next stream from it.
1904-- Ideally, we need some scheduling bias to inner streams vs outer stream.
1905-- Maybe we can configure the behavior.
1907{-# INLINE_NORMAL concatUnfoldInterleave #-}
1908concatUnfoldInterleave :: Monad m => Unfold m a b -> Stream m a -> Stream m b
1909concatUnfoldInterleave (Unfold istep inject) (Stream ostep ost) =
1910 Stream step (ConcatUnfoldInterleaveOuter ost [])
1912 {-# INLINE_LATE step #-}
1913 step gst (ConcatUnfoldInterleaveOuter o ls) = do
1914 r <- ostep (adaptState gst) o
1918 i `seq` return (Skip (ConcatUnfoldInterleaveInner o' (i : ls)))
1919 Skip o' -> return $ Skip (ConcatUnfoldInterleaveOuter o' ls)
1920 Stop -> return $ Skip (ConcatUnfoldInterleaveInnerL ls [])
1922 step _ (ConcatUnfoldInterleaveInner _ []) = undefined
1923 step _ (ConcatUnfoldInterleaveInner o (st:ls)) = do
1926 Yield x s -> Yield x (ConcatUnfoldInterleaveOuter o (s:ls))
1927 Skip s -> Skip (ConcatUnfoldInterleaveInner o (s:ls))
1928 Stop -> Skip (ConcatUnfoldInterleaveOuter o ls)
1930 step _ (ConcatUnfoldInterleaveInnerL [] []) = return Stop
1931 step _ (ConcatUnfoldInterleaveInnerL [] rs) =
1932 return $ Skip (ConcatUnfoldInterleaveInnerR [] rs)
1934 step _ (ConcatUnfoldInterleaveInnerL (st:ls) rs) = do
1937 Yield x s -> Yield x (ConcatUnfoldInterleaveInnerL ls (s:rs))
1938 Skip s -> Skip (ConcatUnfoldInterleaveInnerL (s:ls) rs)
1939 Stop -> Skip (ConcatUnfoldInterleaveInnerL ls rs)
1941 step _ (ConcatUnfoldInterleaveInnerR [] []) = return Stop
1942 step _ (ConcatUnfoldInterleaveInnerR ls []) =
1943 return $ Skip (ConcatUnfoldInterleaveInnerL ls [])
1945 step _ (ConcatUnfoldInterleaveInnerR ls (st:rs)) = do
1948 Yield x s -> Yield x (ConcatUnfoldInterleaveInnerR (s:ls) rs)
1949 Skip s -> Skip (ConcatUnfoldInterleaveInnerR ls (s:rs))
1950 Stop -> Skip (ConcatUnfoldInterleaveInnerR ls rs)
1952-- XXX In general we can use different scheduling strategies e.g. how to
1953-- schedule the outer vs inner loop or assigning weights to different streams
1954-- or outer and inner loops.
1956-- This could be inefficient if the tasks are too small.
1958-- Compared to concatUnfoldInterleave this one switches streams on Skips.
1960{-# INLINE_NORMAL concatUnfoldRoundrobin #-}
1961concatUnfoldRoundrobin :: Monad m => Unfold m a b -> Stream m a -> Stream m b
1962concatUnfoldRoundrobin (Unfold istep inject) (Stream ostep ost) =
1963 Stream step (ConcatUnfoldInterleaveOuter ost [])
1965 {-# INLINE_LATE step #-}
1966 step gst (ConcatUnfoldInterleaveOuter o ls) = do
1967 r <- ostep (adaptState gst) o
1971 i `seq` return (Skip (ConcatUnfoldInterleaveInner o' (i : ls)))
1972 Skip o' -> return $ Skip (ConcatUnfoldInterleaveInner o' ls)
1973 Stop -> return $ Skip (ConcatUnfoldInterleaveInnerL ls [])
1975 step _ (ConcatUnfoldInterleaveInner o []) =
1976 return $ Skip (ConcatUnfoldInterleaveOuter o [])
1978 step _ (ConcatUnfoldInterleaveInner o (st:ls)) = do
1981 Yield x s -> Yield x (ConcatUnfoldInterleaveOuter o (s:ls))
1982 Skip s -> Skip (ConcatUnfoldInterleaveOuter o (s:ls))
1983 Stop -> Skip (ConcatUnfoldInterleaveOuter o ls)
1985 step _ (ConcatUnfoldInterleaveInnerL [] []) = return Stop
1986 step _ (ConcatUnfoldInterleaveInnerL [] rs) =
1987 return $ Skip (ConcatUnfoldInterleaveInnerR [] rs)
1989 step _ (ConcatUnfoldInterleaveInnerL (st:ls) rs) = do
1992 Yield x s -> Yield x (ConcatUnfoldInterleaveInnerL ls (s:rs))
1993 Skip s -> Skip (ConcatUnfoldInterleaveInnerL ls (s:rs))
1994 Stop -> Skip (ConcatUnfoldInterleaveInnerL ls rs)
1996 step _ (ConcatUnfoldInterleaveInnerR [] []) = return Stop
1997 step _ (ConcatUnfoldInterleaveInnerR ls []) =
1998 return $ Skip (ConcatUnfoldInterleaveInnerL ls [])
2000 step _ (ConcatUnfoldInterleaveInnerR ls (st:rs)) = do
2003 Yield x s -> Yield x (ConcatUnfoldInterleaveInnerR (s:ls) rs)
2004 Skip s -> Skip (ConcatUnfoldInterleaveInnerR (s:ls) rs)
2005 Stop -> Skip (ConcatUnfoldInterleaveInnerR ls rs)
2007data AppendState s1 s2 = AppendFirst s1 | AppendSecond s2
2009-- Note that this could be much faster compared to the CPS stream. However, as
2010-- the number of streams being composed increases this may become expensive.
2011-- Need to see where the breaking point is between the two.
2013{-# INLINE_NORMAL append #-}
2014append :: Monad m => Stream m a -> Stream m a -> Stream m a
2015append (Stream step1 state1) (Stream step2 state2) =
2016 Stream step (AppendFirst state1)
2020 {-# INLINE_LATE step #-}
2021 step gst (AppendFirst st) = do
2024 Yield a s -> Yield a (AppendFirst s)
2025 Skip s -> Skip (AppendFirst s)
2026 Stop -> Skip (AppendSecond state2)
2028 step gst (AppendSecond st) = do
2031 Yield a s -> Yield a (AppendSecond s)
2032 Skip s -> Skip (AppendSecond s)
2035data InterleaveState s1 s2 = InterleaveFirst s1 s2 | InterleaveSecond s1 s2
2036 | InterleaveSecondOnly s2 | InterleaveFirstOnly s1
2038{-# INLINE_NORMAL interleave #-}
2039interleave :: Monad m => Stream m a -> Stream m a -> Stream m a
2040interleave (Stream step1 state1) (Stream step2 state2) =
2041 Stream step (InterleaveFirst state1 state2)
2045 {-# INLINE_LATE step #-}
2046 step gst (InterleaveFirst st1 st2) = do
2049 Yield a s -> Yield a (InterleaveSecond s st2)
2050 Skip s -> Skip (InterleaveFirst s st2)
2051 Stop -> Skip (InterleaveSecondOnly st2)
2053 step gst (InterleaveSecond st1 st2) = do
2056 Yield a s -> Yield a (InterleaveFirst st1 s)
2057 Skip s -> Skip (InterleaveSecond st1 s)
2058 Stop -> Skip (InterleaveFirstOnly st1)
2060 step gst (InterleaveFirstOnly st1) = do
2063 Yield a s -> Yield a (InterleaveFirstOnly s)
2064 Skip s -> Skip (InterleaveFirstOnly s)
2067 step gst (InterleaveSecondOnly st2) = do
2070 Yield a s -> Yield a (InterleaveSecondOnly s)
2071 Skip s -> Skip (InterleaveSecondOnly s)
2074{-# INLINE_NORMAL interleaveMin #-}
2075interleaveMin :: Monad m => Stream m a -> Stream m a -> Stream m a
2076interleaveMin (Stream step1 state1) (Stream step2 state2) =
2077 Stream step (InterleaveFirst state1 state2)
2081 {-# INLINE_LATE step #-}
2082 step gst (InterleaveFirst st1 st2) = do
2085 Yield a s -> Yield a (InterleaveSecond s st2)
2086 Skip s -> Skip (InterleaveFirst s st2)
2089 step gst (InterleaveSecond st1 st2) = do
2092 Yield a s -> Yield a (InterleaveFirst st1 s)
2093 Skip s -> Skip (InterleaveSecond st1 s)
2096 step _ (InterleaveFirstOnly _) = undefined
2097 step _ (InterleaveSecondOnly _) = undefined
2099{-# INLINE_NORMAL interleaveFst #-}
2100interleaveFst :: Monad m => Stream m a -> Stream m a -> Stream m a
2101interleaveFst (Stream step1 state1) (Stream step2 state2) =
2102 Stream step (InterleaveFirst state1 state2)
2106 {-# INLINE_LATE step #-}
2107 step gst (InterleaveFirst st1 st2) = do
2110 Yield a s -> Yield a (InterleaveSecond s st2)
2111 Skip s -> Skip (InterleaveFirst s st2)
2114 step gst (InterleaveSecond st1 st2) = do
2117 Yield a s -> Yield a (InterleaveFirst st1 s)
2118 Skip s -> Skip (InterleaveSecond st1 s)
2119 Stop -> Skip (InterleaveFirstOnly st1)
2121 step gst (InterleaveFirstOnly st1) = do
2124 Yield a s -> Yield a (InterleaveFirstOnly s)
2125 Skip s -> Skip (InterleaveFirstOnly s)
2128 step _ (InterleaveSecondOnly _) = undefined
2130{-# INLINE_NORMAL roundRobin #-}
2131roundRobin :: Monad m => Stream m a -> Stream m a -> Stream m a
2132roundRobin (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 (InterleaveSecond 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 (InterleaveFirst st1 s)
2150 Stop -> Skip (InterleaveFirstOnly st1)
2152 step gst (InterleaveSecondOnly st2) = do
2155 Yield a s -> Yield a (InterleaveSecondOnly s)
2156 Skip s -> Skip (InterleaveSecondOnly s)
2159 step gst (InterleaveFirstOnly st1) = do
2162 Yield a s -> Yield a (InterleaveFirstOnly s)
2163 Skip s -> Skip (InterleaveFirstOnly s)
2166data ICUState s1 s2 i1 i2 =
2171 | ICUFirstInner s1 s2 i1
2172 | ICUSecondInner s1 s2 i2
2173 | ICUFirstOnlyInner s1 i1
2174 | ICUSecondOnlyInner s2 i2
2176-- | Interleave streams (full streams, not the elements) unfolded from two
2177-- input streams and concat. Stop when the first stream stops. If the second
2178-- stream ends before the first one then first stream still keeps running alone
2179-- without any interleaving with the second stream.
2181-- [a1, a2, ... an] [b1, b2 ...]
2182-- => [streamA1, streamA2, ... streamAn] [streamB1, streamB2, ...]
2183-- => [streamA1, streamB1, streamA2...StreamAn, streamBn]
2184-- => [a11, a12, ...a1j, b11, b12, ...b1k, a21, a22, ...]
2186{-# INLINE_NORMAL interleaveFstThenConcat #-}
2187interleaveFstThenConcat
2189 => Unfold m a c -> Stream m a -> Unfold m b c -> Stream m b -> Stream m c
2190interleaveFstThenConcat
2191 (Unfold istep1 inject1) (Stream step1 state1)
2192 (Unfold istep2 inject2) (Stream step2 state2) =
2193 Stream step (ICUFirst state1 state2)
2197 {-# INLINE_LATE step #-}
2198 step gst (ICUFirst s1 s2) = do
2199 r <- step1 (adaptState gst) s1
2203 i `seq` return (Skip (ICUFirstInner s s2 i))
2204 Skip s -> return $ Skip (ICUFirst s s2)
2207 step gst (ICUFirstOnly s1) = do
2208 r <- step1 (adaptState gst) s1
2212 i `seq` return (Skip (ICUFirstOnlyInner s i))
2213 Skip s -> return $ Skip (ICUFirstOnly s)
2216 step _ (ICUFirstInner s1 s2 i1) = do
2219 Yield x i' -> Yield x (ICUFirstInner s1 s2 i')
2220 Skip i' -> Skip (ICUFirstInner s1 s2 i')
2221 Stop -> Skip (ICUSecond s1 s2)
2223 step _ (ICUFirstOnlyInner s1 i1) = do
2226 Yield x i' -> Yield x (ICUFirstOnlyInner s1 i')
2227 Skip i' -> Skip (ICUFirstOnlyInner s1 i')
2228 Stop -> Skip (ICUFirstOnly s1)
2230 step gst (ICUSecond s1 s2) = do
2231 r <- step2 (adaptState gst) s2
2235 i `seq` return (Skip (ICUSecondInner s1 s i))
2236 Skip s -> return $ Skip (ICUSecond s1 s)
2237 Stop -> return $ Skip (ICUFirstOnly s1)
2239 step _ (ICUSecondInner s1 s2 i2) = do
2242 Yield x i' -> Yield x (ICUSecondInner s1 s2 i')
2243 Skip i' -> Skip (ICUSecondInner s1 s2 i')
2244 Stop -> Skip (ICUFirst s1 s2)
2246 step _ (ICUSecondOnly _s2) = undefined
2247 step _ (ICUSecondOnlyInner _s2 _i2) = undefined
2249------------------------------------------------------------------------------
2251------------------------------------------------------------------------------
2253-- | Run a side effect before the stream yields its first element.
2254{-# INLINE_NORMAL before #-}
2255before :: Monad m => m b -> Stream m a -> Stream m a
2256before action (Stream step state) = Stream step' Nothing
2260 {-# INLINE_LATE step' #-}
2261 step' _ Nothing = action >> return (Skip (Just state))
2263 step' gst (Just st) = do
2266 Yield x s -> return $ Yield x (Just s)
2267 Skip s -> return $ Skip (Just s)
2270-- | Run a side effect whenever the stream stops normally.
2271{-# INLINE_NORMAL after #-}
2272after :: Monad m => m b -> Stream m a -> Stream m a
2273after action (Stream step state) = Stream step' state
2277 {-# INLINE_LATE step' #-}
2281 Yield x s -> return $ Yield x s
2282 Skip s -> return $ Skip s
2283 Stop -> action >> return Stop
2285-- XXX These combinators are expensive due to the call to
2286-- onException/handle/try on each step. Therefore, when possible, they should
2287-- be called in an outer loop where we perform less iterations. For example, we
2288-- cannot call them on each iteration in a char stream, instead we can call
2289-- them when doing an IO on an array.
2291-- XXX For high performance error checks in busy streams we may need another
2292-- Error constructor in step.
2294-- | Run a side effect whenever the stream aborts due to an exception. The
2295-- exception is not caught, simply rethrown.
2296{-# INLINE_NORMAL onException #-}
2297onException :: MonadCatch m => m b -> Stream m a -> Stream m a
2298onException action (Stream step state) = Stream step' state
2302 {-# INLINE_LATE step' #-}
2304 res <- step gst st `MC.onException` action
2306 Yield x s -> return $ Yield x s
2307 Skip s -> return $ Skip s
2310-- | Run a side effect whenever the stream stops normally or aborts due to an
2312{-# INLINE finally #-}
2313finally :: MonadCatch m => m b -> Stream m a -> Stream m a
2314-- finally action xs = after action $ onException action xs
2315finally action xs = bracket (return ()) (\_ -> action) (const xs)
2317-- XXX bracket is like concatMap, it generates a stream and then flattens it.
2318-- Like concatMap it has 10x worse performance compared to linear fused
2321-- | Run the first action before the stream starts and remember its output,
2322-- generate a stream using the output, run the second action providing the
2323-- remembered value as an argument whenever the stream ends normally or due to
2325{-# INLINE_NORMAL bracket #-}
2326bracket :: MonadCatch m => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a
2327bracket bef aft bet = Stream step' Nothing
2331 {-# INLINE_LATE step' #-}
2332 step' _ Nothing = bef >>= \x -> return (Skip (Just (bet x, x)))
2334 -- NOTE: It is important to use UnStream instead of the Stream pattern
2335 -- here, otherwise we get huge perf degradation, see note in concatMap.
2336 step' gst (Just (UnStream step state, v)) = do
2337 res <- step gst state `MC.onException` aft v
2339 Yield x s -> return $ Yield x (Just (Stream step s, v))
2340 Skip s -> return $ Skip (Just (Stream step s, v))
2341 Stop -> aft v >> return Stop
2343-- | When evaluating a stream if an exception occurs, stream evaluation aborts
2344-- and the specified exception handler is run with the exception as argument.
2345{-# INLINE_NORMAL handle #-}
2346handle :: (MonadCatch m, Exception e) => (e -> m a) -> Stream m a -> Stream m a
2347handle f (Stream step state) = Stream step' (Just state)
2351 {-# INLINE_LATE step' #-}
2352 step' gst (Just st) = do
2353 res <- MC.try $ step gst st
2355 Left e -> f e >>= \x -> return (Yield x Nothing)
2356 Right r -> case r of
2357 Yield x s -> return $ Yield x (Just s)
2358 Skip s -> return $ Skip (Just s)
2361 step' _ Nothing = return Stop
2363-------------------------------------------------------------------------------
2364-- General transformation
2365-------------------------------------------------------------------------------
2367{-# INLINE_NORMAL transform #-}
2368transform :: Monad m => Pipe m a b -> Stream m a -> Stream m b
2369transform (Pipe pstep1 pstep2 pstate) (Stream step state) =
2370 Stream step' (Consume pstate, state)
2374 {-# INLINE_LATE step' #-}
2376 step' gst (Consume pst, st) = pst `seq` do
2377 r <- step (adaptState gst) st
2382 Pipe.Yield b pst' -> return $ Yield b (pst', s)
2383 Pipe.Continue pst' -> return $ Skip (pst', s)
2384 Skip s -> return $ Skip (Consume pst, s)
2387 step' _ (Produce pst, st) = pst `seq` do
2390 Pipe.Yield b pst' -> return $ Yield b (pst', st)
2391 Pipe.Continue pst' -> return $ Skip (pst', st)
2393------------------------------------------------------------------------------
2394-- Transformation by Folding (Scans)
2395------------------------------------------------------------------------------
2397------------------------------------------------------------------------------
2399------------------------------------------------------------------------------
2401-- XXX Is a prescan useful, discarding the last step does not sound useful? I
2402-- am not sure about the utility of this function, so this is implemented but
2403-- not exposed. We can expose it if someone provides good reasons why this is
2406-- XXX We have to execute the stream one step ahead to know that we are at the
2407-- last step. The vector implementation of prescan executes the last fold step
2408-- but does not yield the result. This means we have executed the effect but
2409-- discarded value. This does not sound right. In this implementation we are
2410-- not executing the last fold step.
2411{-# INLINE_NORMAL prescanlM' #-}
2412prescanlM' :: Monad m => (b -> a -> m b) -> m b -> Stream m a -> Stream m b
2413prescanlM' f mz (Stream step state) = Stream step' (state, mz)
2415 {-# INLINE_LATE step' #-}
2416 step' gst (st, prev) = do
2417 r <- step (adaptState gst) st
2421 return $ Yield acc (s, f acc x)
2422 Skip s -> return $ Skip (s, prev)
2425{-# INLINE prescanl' #-}
2426prescanl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b
2427prescanl' f z = prescanlM' (\a b -> return (f a b)) (return z)
2429------------------------------------------------------------------------------
2430-- Monolithic postscans (postscan followed by a map)
2431------------------------------------------------------------------------------
2433-- The performance of a modular postscan followed by a map seems to be
2434-- equivalent to this monolithic scan followed by map therefore we may not need
2435-- this implementation. We just have it for performance comparison and in case
2436-- modular version does not perform well in some situation.
2438{-# INLINE_NORMAL postscanlMx' #-}
2439postscanlMx' :: Monad m
2440 => (x -> a -> m x) -> m x -> (x -> m b) -> Stream m a -> Stream m b
2441postscanlMx' fstep begin done (Stream step state) = do
2442 Stream step' (state, begin)
2444 {-# INLINE_LATE step' #-}
2445 step' gst (st, acc) = do
2446 r <- step (adaptState gst) st
2452 v `seq` y `seq` return (Yield v (s, return y))
2453 Skip s -> return $ Skip (s, acc)
2456{-# INLINE_NORMAL postscanlx' #-}
2457postscanlx' :: Monad m
2458 => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> Stream m b
2459postscanlx' fstep begin done s =
2460 postscanlMx' (\b a -> return (fstep b a)) (return begin) (return . done) s
2462-- XXX do we need consM strict to evaluate the begin value?
2463{-# INLINE scanlMx' #-}
2465 => (x -> a -> m x) -> m x -> (x -> m b) -> Stream m a -> Stream m b
2466scanlMx' fstep begin done s =
2467 (begin >>= \x -> x `seq` done x) `consM` postscanlMx' fstep begin done s
2469{-# INLINE scanlx' #-}
2471 => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> Stream m b
2472scanlx' fstep begin done s =
2473 scanlMx' (\b a -> return (fstep b a)) (return begin) (return . done) s
2475------------------------------------------------------------------------------
2477------------------------------------------------------------------------------
2479{-# INLINE_NORMAL postscanlM' #-}
2480postscanlM' :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
2481postscanlM' fstep begin (Stream step state) =
2482 begin `seq` Stream step' (state, begin)
2484 {-# INLINE_LATE step' #-}
2485 step' gst (st, acc) = acc `seq` do
2486 r <- step (adaptState gst) st
2490 y `seq` return (Yield y (s, y))
2491 Skip s -> return $ Skip (s, acc)
2494{-# INLINE_NORMAL postscanl' #-}
2495postscanl' :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a
2496postscanl' f = postscanlM' (\a b -> return (f a b))
2498{-# INLINE_NORMAL postscanlM #-}
2499postscanlM :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
2500postscanlM fstep begin (Stream step state) = Stream step' (state, begin)
2502 {-# INLINE_LATE step' #-}
2503 step' gst (st, acc) = do
2504 r <- step (adaptState gst) st
2508 return (Yield y (s, y))
2509 Skip s -> return $ Skip (s, acc)
2512{-# INLINE_NORMAL postscanl #-}
2513postscanl :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a
2514postscanl f = postscanlM (\a b -> return (f a b))
2516{-# INLINE_NORMAL scanlM' #-}
2517scanlM' :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
2518scanlM' fstep begin s = begin `seq` (begin `cons` postscanlM' fstep begin s)
2520{-# INLINE scanl' #-}
2521scanl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b
2522scanl' f = scanlM' (\a b -> return (f a b))
2524{-# INLINE_NORMAL scanlM #-}
2525scanlM :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
2526scanlM fstep begin s = begin `cons` postscanlM fstep begin s
2529scanl :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b
2530scanl f = scanlM (\a b -> return (f a b))
2532{-# INLINE_NORMAL scanl1M #-}
2533scanl1M :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a
2534scanl1M fstep (Stream step state) = Stream step' (state, Nothing)
2536 {-# INLINE_LATE step' #-}
2537 step' gst (st, Nothing) = do
2540 Yield x s -> return $ Yield x (s, Just x)
2541 Skip s -> return $ Skip (s, Nothing)
2544 step' gst (st, Just acc) = do
2549 return $ Yield z (s, Just z)
2550 Skip s -> return $ Skip (s, Just acc)
2553{-# INLINE scanl1 #-}
2554scanl1 :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a
2555scanl1 f = scanl1M (\x y -> return (f x y))
2557{-# INLINE_NORMAL scanl1M' #-}
2558scanl1M' :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a
2559scanl1M' fstep (Stream step state) = Stream step' (state, Nothing)
2561 {-# INLINE_LATE step' #-}
2562 step' gst (st, Nothing) = do
2565 Yield x s -> x `seq` return $ Yield x (s, Just x)
2566 Skip s -> return $ Skip (s, Nothing)
2569 step' gst (st, Just acc) = acc `seq` do
2574 z `seq` return $ Yield z (s, Just z)
2575 Skip s -> return $ Skip (s, Just acc)
2578{-# INLINE scanl1' #-}
2579scanl1' :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a
2580scanl1' f = scanl1M' (\x y -> return (f x y))
2583tap :: Monad m => Fold m a b -> Stream m a -> Stream m a
2584tap (Fold fstep initial extract) (Stream step state) = Stream step' Nothing
2588 step' _ Nothing = do
2590 return $ Skip (Just (r, state))
2592 step' gst (Just (acc, st)) = do
2597 return $ Yield x (Just (acc', s))
2598 Skip s -> return $ Skip (Just (acc, s))
2603-------------------------------------------------------------------------------
2605-------------------------------------------------------------------------------
2607{-# INLINE_NORMAL takeWhileM #-}
2608takeWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a
2609takeWhileM f (Stream step state) = Stream step' state
2611 {-# INLINE_LATE step' #-}
2617 return $ if b then Yield x s else Stop
2618 Skip s -> return $ Skip s
2621{-# INLINE takeWhile #-}
2622takeWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
2623takeWhile f = takeWhileM (return . f)
2625{-# INLINE_NORMAL drop #-}
2626drop :: Monad m => Int -> Stream m a -> Stream m a
2627drop n (Stream step state) = Stream step' (state, Just n)
2629 {-# INLINE_LATE step' #-}
2630 step' gst (st, Just i)
2635 Yield _ s -> Skip (s, Just (i - 1))
2636 Skip s -> Skip (s, Just i)
2638 | otherwise = return $ Skip (st, Nothing)
2640 step' gst (st, Nothing) = do
2644 Yield x s -> Yield x (s, Nothing)
2645 Skip s -> Skip (s, Nothing)
2648data DropWhileState s a
2650 | DropWhileYield a s
2653{-# INLINE_NORMAL dropWhileM #-}
2654dropWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a
2655dropWhileM f (Stream step state) = Stream step' (DropWhileDrop state)
2657 {-# INLINE_LATE step' #-}
2658 step' gst (DropWhileDrop st) = do
2664 then return $ Skip (DropWhileDrop s)
2665 else return $ Skip (DropWhileYield x s)
2666 Skip s -> return $ Skip (DropWhileDrop s)
2669 step' gst (DropWhileNext st) = do
2672 Yield x s -> return $ Skip (DropWhileYield x s)
2673 Skip s -> return $ Skip (DropWhileNext s)
2676 step' _ (DropWhileYield x st) = return $ Yield x (DropWhileNext st)
2678{-# INLINE dropWhile #-}
2679dropWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
2680dropWhile f = dropWhileM (return . f)
2682{-# INLINE_NORMAL filterM #-}
2683filterM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a
2684filterM f (Stream step state) = Stream step' state
2686 {-# INLINE_LATE step' #-}
2695 Skip s -> return $ Skip s
2698{-# INLINE filter #-}
2699filter :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
2700filter f = filterM (return . f)
2702{-# INLINE_NORMAL uniq #-}
2703uniq :: (Eq a, Monad m) => Stream m a -> Stream m a
2704uniq (Stream step state) = Stream step' (Nothing, state)
2706 {-# INLINE_LATE step' #-}
2707 step' gst (Nothing, st) = do
2710 Yield x s -> return $ Yield x (Just x, s)
2711 Skip s -> return $ Skip (Nothing, s)
2713 step' gst (Just x, st) = do
2716 Yield y s | x == y -> return $ Skip (Just x, s)
2717 | otherwise -> return $ Yield y (Just y, s)
2718 Skip s -> return $ Skip (Just x, s)
2721------------------------------------------------------------------------------
2722-- Transformation by Mapping
2723------------------------------------------------------------------------------
2725{-# INLINE_NORMAL sequence #-}
2726sequence :: Monad m => Stream m (m a) -> Stream m a
2727sequence (Stream step state) = Stream step' state
2729 {-# INLINE_LATE step' #-}
2731 r <- step (adaptState gst) st
2733 Yield x s -> x >>= \a -> return (Yield a s)
2734 Skip s -> return $ Skip s
2737------------------------------------------------------------------------------
2739------------------------------------------------------------------------------
2741data LoopState x s = FirstYield s
2742 | InterspersingYield s
2745{-# INLINE_NORMAL intersperseM #-}
2746intersperseM :: Monad m => m a -> Stream m a -> Stream m a
2747intersperseM m (Stream step state) = Stream step' (FirstYield state)
2749 {-# INLINE_LATE step' #-}
2750 step' gst (FirstYield st) = do
2754 Yield x s -> Skip (YieldAndCarry x s)
2755 Skip s -> Skip (FirstYield s)
2758 step' gst (InterspersingYield st) = do
2763 return $ Yield a (YieldAndCarry x s)
2764 Skip s -> return $ Skip $ InterspersingYield s
2767 step' _ (YieldAndCarry x st) = return $ Yield x (InterspersingYield st)
2772 | SuffixYield a (SuffixState s a)
2774{-# INLINE_NORMAL insertAfterEach #-}
2775insertAfterEach :: forall m a. Monad m => m a -> Stream m a -> Stream m a
2776insertAfterEach action (Stream step state) = Stream step' (SuffixElem state)
2778 {-# INLINE_LATE step' #-}
2779 step' gst (SuffixElem st) = do
2782 Yield x s -> Skip (SuffixYield x (SuffixSuffix s))
2783 Skip s -> Skip (SuffixElem s)
2786 step' _ (SuffixSuffix st) = do
2787 action >>= \r -> return $ Skip (SuffixYield r (SuffixElem st))
2789 step' _ (SuffixYield x next) = return $ Yield x next
2791{-# INLINE intersperse #-}
2792intersperse :: Monad m => a -> Stream m a -> Stream m a
2793intersperse a = intersperseM (return a)
2795{-# INLINE_NORMAL insertBy #-}
2796insertBy :: Monad m => (a -> a -> Ordering) -> a -> Stream m a -> Stream m a
2797insertBy cmp a (Stream step state) = Stream step' (state, False, Nothing)
2799 {-# INLINE_LATE step' #-}
2800 step' gst (st, False, _) = do
2803 Yield x s -> case cmp a x of
2804 GT -> return $ Yield x (s, False, Nothing)
2805 _ -> return $ Yield a (s, True, Just x)
2806 Skip s -> return $ Skip (s, False, Nothing)
2807 Stop -> return $ Yield a (st, True, Nothing)
2809 step' _ (_, True, Nothing) = return Stop
2811 step' gst (st, True, Just prev) = do
2814 Yield x s -> return $ Yield prev (s, True, Just x)
2815 Skip s -> return $ Skip (s, True, Just prev)
2816 Stop -> return $ Yield prev (st, True, Nothing)
2818------------------------------------------------------------------------------
2820------------------------------------------------------------------------------
2822{-# INLINE_NORMAL deleteBy #-}
2823deleteBy :: Monad m => (a -> a -> Bool) -> a -> Stream m a -> Stream m a
2824deleteBy eq x (Stream step state) = Stream step' (state, False)
2826 {-# INLINE_LATE step' #-}
2827 step' gst (st, False) = do
2830 Yield y s -> return $
2831 if eq x y then Skip (s, True) else Yield y (s, False)
2832 Skip s -> return $ Skip (s, False)
2835 step' gst (st, True) = do
2838 Yield y s -> return $ Yield y (s, True)
2839 Skip s -> return $ Skip (s, True)
2842------------------------------------------------------------------------------
2843-- Transformation by Map and Filter
2844------------------------------------------------------------------------------
2846-- XXX Will this always fuse properly?
2847{-# INLINE_NORMAL mapMaybe #-}
2848mapMaybe :: Monad m => (a -> Maybe b) -> Stream m a -> Stream m b
2849mapMaybe f = fmap fromJust . filter isJust . map f
2851{-# INLINE_NORMAL mapMaybeM #-}
2852mapMaybeM :: Monad m => (a -> m (Maybe b)) -> Stream m a -> Stream m b
2853mapMaybeM f = fmap fromJust . filter isJust . mapM f
2855------------------------------------------------------------------------------
2857------------------------------------------------------------------------------
2859{-# INLINE_NORMAL indexed #-}
2860indexed :: Monad m => Stream m a -> Stream m (Int, a)
2861indexed (Stream step state) = Stream step' (state, 0)
2863 {-# INLINE_LATE step' #-}
2864 step' gst (st, i) = i `seq` do
2865 r <- step (adaptState gst) st
2867 Yield x s -> return $ Yield (i, x) (s, i+1)
2868 Skip s -> return $ Skip (s, i)
2871{-# INLINE_NORMAL indexedR #-}
2872indexedR :: Monad m => Int -> Stream m a -> Stream m (Int, a)
2873indexedR m (Stream step state) = Stream step' (state, m)
2875 {-# INLINE_LATE step' #-}
2876 step' gst (st, i) = i `seq` do
2877 r <- step (adaptState gst) st
2879 Yield x s -> let i' = i - 1
2880 in return $ Yield (i, x) (s, i')
2881 Skip s -> return $ Skip (s, i)
2884{-# INLINE_NORMAL zipWithM #-}
2886 => (a -> b -> m c) -> Stream m a -> Stream m b -> Stream m c
2887zipWithM f (Stream stepa ta) (Stream stepb tb) = Stream step (ta, tb, Nothing)
2889 {-# INLINE_LATE step #-}
2890 step gst (sa, sb, Nothing) = do
2891 r <- stepa (adaptState gst) sa
2894 Yield x sa' -> Skip (sa', sb, Just x)
2895 Skip sa' -> Skip (sa', sb, Nothing)
2898 step gst (sa, sb, Just x) = do
2899 r <- stepb (adaptState gst) sb
2903 return $ Yield z (sa, sb', Nothing)
2904 Skip sb' -> return $ Skip (sa, sb', Just x)
2907#if __GLASGOW_HASKELL__ >= 801
2908{-# RULES "zipWithM xs xs"
2909 forall f xs. zipWithM @Identity f xs xs = mapM (\x -> f x x) xs #-}
2912{-# INLINE zipWith #-}
2913zipWith :: Monad m => (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c
2914zipWith f = zipWithM (\a b -> return (f a b))
2916------------------------------------------------------------------------------
2918------------------------------------------------------------------------------
2920{-# INLINE_NORMAL mergeByM #-}
2923 => (a -> a -> m Ordering) -> Stream m a -> Stream m a -> Stream m a
2924mergeByM cmp (Stream stepa ta) (Stream stepb tb) =
2925 Stream step (Just ta, Just tb, Nothing, Nothing)
2927 {-# INLINE_LATE step #-}
2929 -- one of the values is missing, and the corresponding stream is running
2930 step gst (Just sa, sb, Nothing, b) = do
2933 Yield a sa' -> Skip (Just sa', sb, Just a, b)
2934 Skip sa' -> Skip (Just sa', sb, Nothing, b)
2935 Stop -> Skip (Nothing, sb, Nothing, b)
2937 step gst (sa, Just sb, a, Nothing) = do
2940 Yield b sb' -> Skip (sa, Just sb', a, Just b)
2941 Skip sb' -> Skip (sa, Just sb', a, Nothing)
2942 Stop -> Skip (sa, Nothing, a, Nothing)
2944 -- both the values are available
2945 step _ (sa, sb, Just a, Just b) = do
2947 return $ case res of
2948 GT -> Yield b (sa, sb, Just a, Nothing)
2949 _ -> Yield a (sa, sb, Nothing, Just b)
2951 -- one of the values is missing, corresponding stream is done
2952 step _ (Nothing, sb, Nothing, Just b) =
2953 return $ Yield b (Nothing, sb, Nothing, Nothing)
2955 step _ (sa, Nothing, Just a, Nothing) =
2956 return $ Yield a (sa, Nothing, Nothing, Nothing)
2958 step _ (Nothing, Nothing, Nothing, Nothing) = return Stop
2960{-# INLINE mergeBy #-}
2963 => (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a
2964mergeBy cmp = mergeByM (\a b -> return $ cmp a b)
2966------------------------------------------------------------------------------
2967-- Transformation comprehensions
2968------------------------------------------------------------------------------
2970{-# INLINE_NORMAL the #-}
2971the :: (Eq a, Monad m) => Stream m a -> m (Maybe a)
2972the (Stream step state) = go state
2975 r <- step defState st
2977 Yield x s -> go' x s
2979 Stop -> return Nothing
2981 r <- step defState st
2983 Yield x s | x == n -> go' n s
2984 | otherwise -> return Nothing
2986 Stop -> return (Just n)
2988--------------------------------------------------------------------------------
2989-- UTF8 Encoding / Decoding
2990--------------------------------------------------------------------------------
2992-- UTF-8 primitives, Lifted from GHC.IO.Encoding.UTF8.
2995ord2 :: Char -> WList
2996ord2 c = assert (n >= 0x80 && n <= 0x07ff) (WCons x1 (WCons x2 WNil))
2999 x1 = fromIntegral $ (n `shiftR` 6) + 0xC0
3000 x2 = fromIntegral $ (n .&. 0x3F) + 0x80
3003ord3 :: Char -> WList
3004ord3 c = assert (n >= 0x0800 && n <= 0xffff) (WCons x1 (WCons x2 (WCons x3 WNil)))
3007 x1 = fromIntegral $ (n `shiftR` 12) + 0xE0
3008 x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
3009 x3 = fromIntegral $ (n .&. 0x3F) + 0x80
3012ord4 :: Char -> WList
3013ord4 c = assert (n >= 0x10000) (WCons x1 (WCons x2 (WCons x3 (WCons x4 WNil))))
3016 x1 = fromIntegral $ (n `shiftR` 18) + 0xF0
3017 x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80
3018 x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
3019 x4 = fromIntegral $ (n .&. 0x3F) + 0x80
3021data CodingFailureMode
3022 = TransliterateCodingFailure
3023 | ErrorOnCodingFailure
3026{-# INLINE replacementChar #-}
3027replacementChar :: Char
3028replacementChar = '\xFFFD'
3030-- Int helps in cheaper conversion from Int to Char
3032type DecoderState = Word8
3034-- See http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ for details.
3036{-# INLINE runFold #-}
3037runFold :: (Monad m) => Fold m a b -> Stream m a -> m b
3038runFold (Fold step begin done) = foldlMx' step begin done
3040-- Aligning to cacheline makes a barely noticeable difference
3041utf8d :: A.Array Word8
3042utf8d = unsafePerformIO $ runFold (A.writeAligned 64) $ fromList [
3043 -- The first part of the table maps bytes to character classes that
3044 -- to reduce the size of the transition table and create bitmasks.
3045 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,
3046 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,
3047 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,
3048 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,
3049 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,
3050 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,
3051 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,
3052 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,
3054 -- The second part is a transition table that maps a combination
3055 -- of a state of the automaton and a character class to a state.
3056 0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12,
3057 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,
3058 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,
3059 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,
3060 12,36,12,12,12,12,12,12,12,12,12,12
3063-- | Return element at the specified index without checking the bounds.
3064-- and without touching the foreign ptr.
3065{-# INLINE_NORMAL unsafePeekElemOff #-}
3066unsafePeekElemOff :: forall a. Storable a => Ptr a -> Int -> a
3067unsafePeekElemOff p i = let !x = A.unsafeInlineIO $ peekElemOff p i in x
3069-- decode is split into two separate cases to avoid branching instructions.
3070-- From the higher level flow we already know which case we are in so we can
3071-- call the appropriate decode function.
3073-- When the state is 0
3074{-# INLINE decode0 #-}
3075decode0 :: Ptr Word8 -> Word8 -> Tuple' DecoderState CodePoint
3077 let !t = table `unsafePeekElemOff` fromIntegral byte
3078 !codep' = (0xff `shiftR` (fromIntegral t)) .&. fromIntegral byte
3079 !state' = table `unsafePeekElemOff` (256 + fromIntegral t)
3080 in (Tuple' state' codep')
3082-- When the state is not 0
3083{-# INLINE decode1 #-}
3089 -> Tuple' DecoderState CodePoint
3090decode1 table state codep byte =
3091 -- Remember codep is Int type!
3092 -- Can it be unsafe to convert the resulting to Char?
3093 let !t = table `unsafePeekElemOff` fromIntegral byte
3094 !codep' = (fromIntegral byte .&. 0x3f) .|. (codep `shiftL` 6)
3095 !state' = table `unsafePeekElemOff`
3096 (256 + fromIntegral state + fromIntegral t)
3097 in (Tuple' state' codep')
3101 = FreshPointDecodeInit s
3102 | FreshPointDecodeFirst s Word8
3103 | FreshPointDecoding s !DecoderState !CodePoint
3104 | YieldAndContinue !Char (FreshPoint s)
3107-- XXX Add proper error messages
3108{-# INLINE_NORMAL decodeUtf8With #-}
3109decodeUtf8With :: Monad m => CodingFailureMode -> Stream m Word8 -> Stream m Char
3110decodeUtf8With cfm (Stream step state) =
3111 let Array p _ _ = utf8d
3112 !ptr = (unsafeForeignPtrToPtr p)
3113 in Stream (step' ptr) (FreshPointDecodeInit state)
3115 {-# INLINE transliterateOrError #-}
3116 transliterateOrError e s =
3118 ErrorOnCodingFailure -> error e
3119 TransliterateCodingFailure -> YieldAndContinue replacementChar s
3120 {-# INLINE inputUnderflow #-}
3123 ErrorOnCodingFailure ->
3124 error "Streamly.Streams.StreamD.decodeUtf8With: Input Underflow"
3125 TransliterateCodingFailure -> YieldAndContinue replacementChar Done
3126 {-# INLINE_LATE step' #-}
3127 step' _ gst (FreshPointDecodeInit st) = do
3128 r <- step (adaptState gst) st
3131 -- Note: It is important to use a ">" instead of a "<=" test
3132 -- here for GHC to generate code layout for default branch
3133 -- prediction for the common case. This is fragile and might
3134 -- change with the compiler versions, we need a more reliable
3135 -- "likely" primitive to control branch predication.
3138 return $ Skip $ YieldAndContinue
3139 (unsafeChr (fromIntegral x))
3140 (FreshPointDecodeInit s)
3141 -- Using a separate state here generates a jump to a
3142 -- separate code block in the core which seems to perform
3143 -- slightly better for the non-ascii case.
3144 True -> return $ Skip $ FreshPointDecodeFirst s x
3145 Skip s -> return $ Skip (FreshPointDecodeInit s)
3146 Stop -> return $ Skip Done
3148 step' table _ (FreshPointDecodeFirst st x) = do
3149 let (Tuple' sv cp) = decode0 table x
3154 transliterateOrError
3155 "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered"
3156 (FreshPointDecodeInit st)
3157 0 -> error "unreachable state"
3158 _ -> Skip (FreshPointDecoding st sv cp)
3160 step' table gst (FreshPointDecoding st statePtr codepointPtr) = do
3161 r <- step (adaptState gst) st
3164 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
3167 0 -> Skip $ YieldAndContinue (unsafeChr cp)
3168 (FreshPointDecodeInit s)
3171 transliterateOrError
3172 "Streamly.Streams.StreamD.decodeUtf8With: Invalid UTF8 codepoint encountered"
3173 (FreshPointDecodeInit s)
3174 _ -> Skip (FreshPointDecoding s sv cp)
3175 Skip s -> return $ Skip (FreshPointDecoding s statePtr codepointPtr)
3176 Stop -> return $ Skip inputUnderflow
3178 step' _ _ (YieldAndContinue c s) = return $ Yield c s
3179 step' _ _ Done = return Stop
3181{-# INLINE decodeUtf8 #-}
3182decodeUtf8 :: Monad m => Stream m Word8 -> Stream m Char
3183decodeUtf8 = decodeUtf8With ErrorOnCodingFailure
3185{-# INLINE decodeUtf8Lenient #-}
3186decodeUtf8Lenient :: Monad m => Stream m Word8 -> Stream m Char
3187decodeUtf8Lenient = decodeUtf8With TransliterateCodingFailure
3189data FlattenState s a
3190 = OuterLoop s !(Maybe (DecoderState, CodePoint))
3191 | InnerLoopDecodeInit s (ForeignPtr a) !(Ptr a) !(Ptr a)
3192 | InnerLoopDecodeFirst s (ForeignPtr a) !(Ptr a) !(Ptr a) Word8
3193 | InnerLoopDecoding s (ForeignPtr a) !(Ptr a) !(Ptr a)
3194 !DecoderState !CodePoint
3195 | YAndC !Char (FlattenState s a) -- These constructors can be
3196 -- encoded in the FreshPoint
3197 -- type, I prefer to keep these
3198 -- flat even though that means
3199 -- coming up with new names
3202-- The normal decodeUtf8 above should fuse with flattenArrays
3203-- to create this exact code but it doesn't for some reason, as of now this
3204-- remains the fastest way I could figure out to decodeUtf8.
3206-- XXX Add Proper error messages
3207{-# INLINE_NORMAL decodeUtf8ArraysWith #-}
3208decodeUtf8ArraysWith ::
3210 => CodingFailureMode
3211 -> Stream m (A.Array Word8)
3213decodeUtf8ArraysWith cfm (Stream step state) =
3214 let Array p _ _ = utf8d
3215 !ptr = (unsafeForeignPtrToPtr p)
3216 in Stream (step' ptr) (OuterLoop state Nothing)
3218 {-# INLINE transliterateOrError #-}
3219 transliterateOrError e s =
3221 ErrorOnCodingFailure -> error e
3222 TransliterateCodingFailure -> YAndC replacementChar s
3223 {-# INLINE inputUnderflow #-}
3226 ErrorOnCodingFailure ->
3228 "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Input Underflow"
3229 TransliterateCodingFailure -> YAndC replacementChar D
3230 {-# INLINE_LATE step' #-}
3231 step' _ gst (OuterLoop st Nothing) = do
3232 r <- step (adaptState gst) st
3235 Yield A.Array {..} s ->
3236 let p = unsafeForeignPtrToPtr aStart
3237 in Skip (InnerLoopDecodeInit s aStart p aEnd)
3238 Skip s -> Skip (OuterLoop s Nothing)
3240 step' _ gst (OuterLoop st dst@(Just (ds, cp))) = do
3241 r <- step (adaptState gst) st
3244 Yield A.Array {..} s ->
3245 let p = unsafeForeignPtrToPtr aStart
3246 in Skip (InnerLoopDecoding s aStart p aEnd ds cp)
3247 Skip s -> Skip (OuterLoop s dst)
3248 Stop -> Skip inputUnderflow
3249 step' _ _ (InnerLoopDecodeInit st startf p end)
3251 liftIO $ touchForeignPtr startf
3252 return $ Skip $ OuterLoop st Nothing
3253 step' _ _ (InnerLoopDecodeInit st startf p end) = do
3254 x <- liftIO $ peek p
3255 -- Note: It is important to use a ">" instead of a "<=" test here for
3256 -- GHC to generate code layout for default branch prediction for the
3257 -- common case. This is fragile and might change with the compiler
3258 -- versions, we need a more reliable "likely" primitive to control
3259 -- branch predication.
3262 return $ Skip $ YAndC
3263 (unsafeChr (fromIntegral x))
3264 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
3265 -- Using a separate state here generates a jump to a separate code
3266 -- block in the core which seems to perform slightly better for the
3268 True -> return $ Skip $ InnerLoopDecodeFirst st startf p end x
3270 step' table _ (InnerLoopDecodeFirst st startf p end x) = do
3271 let (Tuple' sv cp) = decode0 table x
3276 transliterateOrError
3277 "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered"
3278 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
3279 0 -> error "unreachable state"
3280 _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)
3281 step' _ _ (InnerLoopDecoding st startf p end sv cp)
3283 liftIO $ touchForeignPtr startf
3284 return $ Skip $ OuterLoop st (Just (sv, cp))
3285 step' table _ (InnerLoopDecoding st startf p end statePtr codepointPtr) = do
3286 x <- liftIO $ peek p
3287 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
3294 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
3297 transliterateOrError
3298 "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered"
3299 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
3300 _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)
3301 step' _ _ (YAndC c s) = return $ Yield c s
3302 step' _ _ D = return Stop
3304{-# INLINE decodeUtf8Arrays #-}
3307 => Stream m (A.Array Word8)
3309decodeUtf8Arrays = decodeUtf8ArraysWith ErrorOnCodingFailure
3311{-# INLINE decodeUtf8ArraysLenient #-}
3312decodeUtf8ArraysLenient ::
3314 => Stream m (A.Array Word8)
3316decodeUtf8ArraysLenient = decodeUtf8ArraysWith TransliterateCodingFailure
3318data WList = WCons !Word8 !WList | WNil
3320data EncodeState s = EncodeState s !WList
3322{-# INLINE_NORMAL encodeUtf8 #-}
3323encodeUtf8 :: Monad m => Stream m Char -> Stream m Word8
3324encodeUtf8 (Stream step state) = Stream step' (EncodeState state WNil)
3326 {-# INLINE_LATE step' #-}
3327 step' gst (EncodeState st WNil) = do
3328 r <- step (adaptState gst) st
3336 (EncodeState s (WCons (fromIntegral x) WNil))
3337 | x <= 0x7FF -> Skip (EncodeState s (ord2 c))
3341 "Streamly.Streams.StreamD.encodeUtf8: Encountered a surrogate"
3342 else Skip (EncodeState s (ord3 c))
3343 | otherwise -> Skip (EncodeState s (ord4 c))
3344 Skip s -> Skip (EncodeState s WNil)
3346 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