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
2314finally action xs = after action $ onException action xs
2316-- XXX bracket is like concatMap, it generates a stream and then flattens it.
2317-- Like concatMap it has 10x worse performance compared to linear fused
2320-- | Run the first action before the stream starts and remember its output,
2321-- generate a stream using the output, run the second action using the
2322-- remembered value as an argument whenever the stream ends normally or due to
2324{-# INLINE_NORMAL bracket #-}
2325bracket :: MonadCatch m => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a
2326bracket bef aft bet = Stream step' Nothing
2330 {-# INLINE_LATE step' #-}
2331 step' _ Nothing = bef >>= \x -> return (Skip (Just (bet x, x)))
2333 -- NOTE: It is important to use UnStream instead of the Stream pattern
2334 -- here, otherwise we get huge perf degradation, see note in concatMap.
2335 step' gst (Just (UnStream step state, v)) = do
2336 res <- step gst state `MC.onException` aft v
2338 Yield x s -> return $ Yield x (Just (Stream step s, v))
2339 Skip s -> return $ Skip (Just (Stream step s, v))
2340 Stop -> aft v >> return Stop
2342-- | When evaluating a stream if an exception occurs, stream evaluation aborts
2343-- and the specified exception handler is run with the exception as argument.
2344{-# INLINE_NORMAL handle #-}
2345handle :: (MonadCatch m, Exception e) => (e -> m a) -> Stream m a -> Stream m a
2346handle f (Stream step state) = Stream step' (Just state)
2350 {-# INLINE_LATE step' #-}
2351 step' gst (Just st) = do
2352 res <- MC.try $ step gst st
2354 Left e -> f e >>= \x -> return (Yield x Nothing)
2355 Right r -> case r of
2356 Yield x s -> return $ Yield x (Just s)
2357 Skip s -> return $ Skip (Just s)
2360 step' _ Nothing = return Stop
2362-------------------------------------------------------------------------------
2363-- General transformation
2364-------------------------------------------------------------------------------
2366{-# INLINE_NORMAL transform #-}
2367transform :: Monad m => Pipe m a b -> Stream m a -> Stream m b
2368transform (Pipe pstep1 pstep2 pstate) (Stream step state) =
2369 Stream step' (Consume pstate, state)
2373 {-# INLINE_LATE step' #-}
2375 step' gst (Consume pst, st) = pst `seq` do
2376 r <- step (adaptState gst) st
2381 Pipe.Yield b pst' -> return $ Yield b (pst', s)
2382 Pipe.Continue pst' -> return $ Skip (pst', s)
2383 Skip s -> return $ Skip (Consume pst, s)
2386 step' _ (Produce pst, st) = pst `seq` do
2389 Pipe.Yield b pst' -> return $ Yield b (pst', st)
2390 Pipe.Continue pst' -> return $ Skip (pst', st)
2392------------------------------------------------------------------------------
2393-- Transformation by Folding (Scans)
2394------------------------------------------------------------------------------
2396------------------------------------------------------------------------------
2398------------------------------------------------------------------------------
2400-- XXX Is a prescan useful, discarding the last step does not sound useful? I
2401-- am not sure about the utility of this function, so this is implemented but
2402-- not exposed. We can expose it if someone provides good reasons why this is
2405-- XXX We have to execute the stream one step ahead to know that we are at the
2406-- last step. The vector implementation of prescan executes the last fold step
2407-- but does not yield the result. This means we have executed the effect but
2408-- discarded value. This does not sound right. In this implementation we are
2409-- not executing the last fold step.
2410{-# INLINE_NORMAL prescanlM' #-}
2411prescanlM' :: Monad m => (b -> a -> m b) -> m b -> Stream m a -> Stream m b
2412prescanlM' f mz (Stream step state) = Stream step' (state, mz)
2414 {-# INLINE_LATE step' #-}
2415 step' gst (st, prev) = do
2416 r <- step (adaptState gst) st
2420 return $ Yield acc (s, f acc x)
2421 Skip s -> return $ Skip (s, prev)
2424{-# INLINE prescanl' #-}
2425prescanl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b
2426prescanl' f z = prescanlM' (\a b -> return (f a b)) (return z)
2428------------------------------------------------------------------------------
2429-- Monolithic postscans (postscan followed by a map)
2430------------------------------------------------------------------------------
2432-- The performance of a modular postscan followed by a map seems to be
2433-- equivalent to this monolithic scan followed by map therefore we may not need
2434-- this implementation. We just have it for performance comparison and in case
2435-- modular version does not perform well in some situation.
2437{-# INLINE_NORMAL postscanlMx' #-}
2438postscanlMx' :: Monad m
2439 => (x -> a -> m x) -> m x -> (x -> m b) -> Stream m a -> Stream m b
2440postscanlMx' fstep begin done (Stream step state) = do
2441 Stream step' (state, begin)
2443 {-# INLINE_LATE step' #-}
2444 step' gst (st, acc) = do
2445 r <- step (adaptState gst) st
2451 v `seq` y `seq` return (Yield v (s, return y))
2452 Skip s -> return $ Skip (s, acc)
2455{-# INLINE_NORMAL postscanlx' #-}
2456postscanlx' :: Monad m
2457 => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> Stream m b
2458postscanlx' fstep begin done s =
2459 postscanlMx' (\b a -> return (fstep b a)) (return begin) (return . done) s
2461-- XXX do we need consM strict to evaluate the begin value?
2462{-# INLINE scanlMx' #-}
2464 => (x -> a -> m x) -> m x -> (x -> m b) -> Stream m a -> Stream m b
2465scanlMx' fstep begin done s =
2466 (begin >>= \x -> x `seq` done x) `consM` postscanlMx' fstep begin done s
2468{-# INLINE scanlx' #-}
2470 => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> Stream m b
2471scanlx' fstep begin done s =
2472 scanlMx' (\b a -> return (fstep b a)) (return begin) (return . done) s
2474------------------------------------------------------------------------------
2476------------------------------------------------------------------------------
2478{-# INLINE_NORMAL postscanlM' #-}
2479postscanlM' :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
2480postscanlM' fstep begin (Stream step state) =
2481 begin `seq` Stream step' (state, begin)
2483 {-# INLINE_LATE step' #-}
2484 step' gst (st, acc) = acc `seq` do
2485 r <- step (adaptState gst) st
2489 y `seq` return (Yield y (s, y))
2490 Skip s -> return $ Skip (s, acc)
2493{-# INLINE_NORMAL postscanl' #-}
2494postscanl' :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a
2495postscanl' f = postscanlM' (\a b -> return (f a b))
2497{-# INLINE_NORMAL postscanlM #-}
2498postscanlM :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
2499postscanlM fstep begin (Stream step state) = Stream step' (state, begin)
2501 {-# INLINE_LATE step' #-}
2502 step' gst (st, acc) = do
2503 r <- step (adaptState gst) st
2507 return (Yield y (s, y))
2508 Skip s -> return $ Skip (s, acc)
2511{-# INLINE_NORMAL postscanl #-}
2512postscanl :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a
2513postscanl f = postscanlM (\a b -> return (f a b))
2515{-# INLINE_NORMAL scanlM' #-}
2516scanlM' :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
2517scanlM' fstep begin s = begin `seq` (begin `cons` postscanlM' fstep begin s)
2519{-# INLINE scanl' #-}
2520scanl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b
2521scanl' f = scanlM' (\a b -> return (f a b))
2523{-# INLINE_NORMAL scanlM #-}
2524scanlM :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
2525scanlM fstep begin s = begin `cons` postscanlM fstep begin s
2528scanl :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b
2529scanl f = scanlM (\a b -> return (f a b))
2531{-# INLINE_NORMAL scanl1M #-}
2532scanl1M :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a
2533scanl1M fstep (Stream step state) = Stream step' (state, Nothing)
2535 {-# INLINE_LATE step' #-}
2536 step' gst (st, Nothing) = do
2539 Yield x s -> return $ Yield x (s, Just x)
2540 Skip s -> return $ Skip (s, Nothing)
2543 step' gst (st, Just acc) = do
2548 return $ Yield z (s, Just z)
2549 Skip s -> return $ Skip (s, Just acc)
2552{-# INLINE scanl1 #-}
2553scanl1 :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a
2554scanl1 f = scanl1M (\x y -> return (f x y))
2556{-# INLINE_NORMAL scanl1M' #-}
2557scanl1M' :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a
2558scanl1M' fstep (Stream step state) = Stream step' (state, Nothing)
2560 {-# INLINE_LATE step' #-}
2561 step' gst (st, Nothing) = do
2564 Yield x s -> x `seq` return $ Yield x (s, Just x)
2565 Skip s -> return $ Skip (s, Nothing)
2568 step' gst (st, Just acc) = acc `seq` do
2573 z `seq` return $ Yield z (s, Just z)
2574 Skip s -> return $ Skip (s, Just acc)
2577{-# INLINE scanl1' #-}
2578scanl1' :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a
2579scanl1' f = scanl1M' (\x y -> return (f x y))
2582tap :: Monad m => Fold m a b -> Stream m a -> Stream m a
2583tap (Fold fstep initial extract) (Stream step state) = Stream step' Nothing
2587 step' _ Nothing = do
2589 return $ Skip (Just (r, state))
2591 step' gst (Just (acc, st)) = do
2596 return $ Yield x (Just (acc', s))
2597 Skip s -> return $ Skip (Just (acc, s))
2602-------------------------------------------------------------------------------
2604-------------------------------------------------------------------------------
2606{-# INLINE_NORMAL takeWhileM #-}
2607takeWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a
2608takeWhileM f (Stream step state) = Stream step' state
2610 {-# INLINE_LATE step' #-}
2616 return $ if b then Yield x s else Stop
2617 Skip s -> return $ Skip s
2620{-# INLINE takeWhile #-}
2621takeWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
2622takeWhile f = takeWhileM (return . f)
2624{-# INLINE_NORMAL drop #-}
2625drop :: Monad m => Int -> Stream m a -> Stream m a
2626drop n (Stream step state) = Stream step' (state, Just n)
2628 {-# INLINE_LATE step' #-}
2629 step' gst (st, Just i)
2634 Yield _ s -> Skip (s, Just (i - 1))
2635 Skip s -> Skip (s, Just i)
2637 | otherwise = return $ Skip (st, Nothing)
2639 step' gst (st, Nothing) = do
2643 Yield x s -> Yield x (s, Nothing)
2644 Skip s -> Skip (s, Nothing)
2647data DropWhileState s a
2649 | DropWhileYield a s
2652{-# INLINE_NORMAL dropWhileM #-}
2653dropWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a
2654dropWhileM f (Stream step state) = Stream step' (DropWhileDrop state)
2656 {-# INLINE_LATE step' #-}
2657 step' gst (DropWhileDrop st) = do
2663 then return $ Skip (DropWhileDrop s)
2664 else return $ Skip (DropWhileYield x s)
2665 Skip s -> return $ Skip (DropWhileDrop s)
2668 step' gst (DropWhileNext st) = do
2671 Yield x s -> return $ Skip (DropWhileYield x s)
2672 Skip s -> return $ Skip (DropWhileNext s)
2675 step' _ (DropWhileYield x st) = return $ Yield x (DropWhileNext st)
2677{-# INLINE dropWhile #-}
2678dropWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
2679dropWhile f = dropWhileM (return . f)
2681{-# INLINE_NORMAL filterM #-}
2682filterM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a
2683filterM f (Stream step state) = Stream step' state
2685 {-# INLINE_LATE step' #-}
2694 Skip s -> return $ Skip s
2697{-# INLINE filter #-}
2698filter :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
2699filter f = filterM (return . f)
2701{-# INLINE_NORMAL uniq #-}
2702uniq :: (Eq a, Monad m) => Stream m a -> Stream m a
2703uniq (Stream step state) = Stream step' (Nothing, state)
2705 {-# INLINE_LATE step' #-}
2706 step' gst (Nothing, st) = do
2709 Yield x s -> return $ Yield x (Just x, s)
2710 Skip s -> return $ Skip (Nothing, s)
2712 step' gst (Just x, st) = do
2715 Yield y s | x == y -> return $ Skip (Just x, s)
2716 | otherwise -> return $ Yield y (Just y, s)
2717 Skip s -> return $ Skip (Just x, s)
2720------------------------------------------------------------------------------
2721-- Transformation by Mapping
2722------------------------------------------------------------------------------
2724{-# INLINE_NORMAL sequence #-}
2725sequence :: Monad m => Stream m (m a) -> Stream m a
2726sequence (Stream step state) = Stream step' state
2728 {-# INLINE_LATE step' #-}
2730 r <- step (adaptState gst) st
2732 Yield x s -> x >>= \a -> return (Yield a s)
2733 Skip s -> return $ Skip s
2736------------------------------------------------------------------------------
2738------------------------------------------------------------------------------
2740data LoopState x s = FirstYield s
2741 | InterspersingYield s
2744{-# INLINE_NORMAL intersperseM #-}
2745intersperseM :: Monad m => m a -> Stream m a -> Stream m a
2746intersperseM m (Stream step state) = Stream step' (FirstYield state)
2748 {-# INLINE_LATE step' #-}
2749 step' gst (FirstYield st) = do
2753 Yield x s -> Skip (YieldAndCarry x s)
2754 Skip s -> Skip (FirstYield s)
2757 step' gst (InterspersingYield st) = do
2762 return $ Yield a (YieldAndCarry x s)
2763 Skip s -> return $ Skip $ InterspersingYield s
2766 step' _ (YieldAndCarry x st) = return $ Yield x (InterspersingYield st)
2771 | SuffixYield a (SuffixState s a)
2773{-# INLINE_NORMAL insertAfterEach #-}
2774insertAfterEach :: forall m a. Monad m => m a -> Stream m a -> Stream m a
2775insertAfterEach action (Stream step state) = Stream step' (SuffixElem state)
2777 {-# INLINE_LATE step' #-}
2778 step' gst (SuffixElem st) = do
2781 Yield x s -> Skip (SuffixYield x (SuffixSuffix s))
2782 Skip s -> Skip (SuffixElem s)
2785 step' _ (SuffixSuffix st) = do
2786 action >>= \r -> return $ Skip (SuffixYield r (SuffixElem st))
2788 step' _ (SuffixYield x next) = return $ Yield x next
2790{-# INLINE intersperse #-}
2791intersperse :: Monad m => a -> Stream m a -> Stream m a
2792intersperse a = intersperseM (return a)
2794{-# INLINE_NORMAL insertBy #-}
2795insertBy :: Monad m => (a -> a -> Ordering) -> a -> Stream m a -> Stream m a
2796insertBy cmp a (Stream step state) = Stream step' (state, False, Nothing)
2798 {-# INLINE_LATE step' #-}
2799 step' gst (st, False, _) = do
2802 Yield x s -> case cmp a x of
2803 GT -> return $ Yield x (s, False, Nothing)
2804 _ -> return $ Yield a (s, True, Just x)
2805 Skip s -> return $ Skip (s, False, Nothing)
2806 Stop -> return $ Yield a (st, True, Nothing)
2808 step' _ (_, True, Nothing) = return Stop
2810 step' gst (st, True, Just prev) = do
2813 Yield x s -> return $ Yield prev (s, True, Just x)
2814 Skip s -> return $ Skip (s, True, Just prev)
2815 Stop -> return $ Yield prev (st, True, Nothing)
2817------------------------------------------------------------------------------
2819------------------------------------------------------------------------------
2821{-# INLINE_NORMAL deleteBy #-}
2822deleteBy :: Monad m => (a -> a -> Bool) -> a -> Stream m a -> Stream m a
2823deleteBy eq x (Stream step state) = Stream step' (state, False)
2825 {-# INLINE_LATE step' #-}
2826 step' gst (st, False) = do
2829 Yield y s -> return $
2830 if eq x y then Skip (s, True) else Yield y (s, False)
2831 Skip s -> return $ Skip (s, False)
2834 step' gst (st, True) = do
2837 Yield y s -> return $ Yield y (s, True)
2838 Skip s -> return $ Skip (s, True)
2841------------------------------------------------------------------------------
2842-- Transformation by Map and Filter
2843------------------------------------------------------------------------------
2845-- XXX Will this always fuse properly?
2846{-# INLINE_NORMAL mapMaybe #-}
2847mapMaybe :: Monad m => (a -> Maybe b) -> Stream m a -> Stream m b
2848mapMaybe f = fmap fromJust . filter isJust . map f
2850{-# INLINE_NORMAL mapMaybeM #-}
2851mapMaybeM :: Monad m => (a -> m (Maybe b)) -> Stream m a -> Stream m b
2852mapMaybeM f = fmap fromJust . filter isJust . mapM f
2854------------------------------------------------------------------------------
2856------------------------------------------------------------------------------
2858{-# INLINE_NORMAL indexed #-}
2859indexed :: Monad m => Stream m a -> Stream m (Int, a)
2860indexed (Stream step state) = Stream step' (state, 0)
2862 {-# INLINE_LATE step' #-}
2863 step' gst (st, i) = i `seq` do
2864 r <- step (adaptState gst) st
2866 Yield x s -> return $ Yield (i, x) (s, i+1)
2867 Skip s -> return $ Skip (s, i)
2870{-# INLINE_NORMAL indexedR #-}
2871indexedR :: Monad m => Int -> Stream m a -> Stream m (Int, a)
2872indexedR m (Stream step state) = Stream step' (state, m)
2874 {-# INLINE_LATE step' #-}
2875 step' gst (st, i) = i `seq` do
2876 r <- step (adaptState gst) st
2878 Yield x s -> let i' = i - 1
2879 in return $ Yield (i, x) (s, i')
2880 Skip s -> return $ Skip (s, i)
2883{-# INLINE_NORMAL zipWithM #-}
2885 => (a -> b -> m c) -> Stream m a -> Stream m b -> Stream m c
2886zipWithM f (Stream stepa ta) (Stream stepb tb) = Stream step (ta, tb, Nothing)
2888 {-# INLINE_LATE step #-}
2889 step gst (sa, sb, Nothing) = do
2890 r <- stepa (adaptState gst) sa
2893 Yield x sa' -> Skip (sa', sb, Just x)
2894 Skip sa' -> Skip (sa', sb, Nothing)
2897 step gst (sa, sb, Just x) = do
2898 r <- stepb (adaptState gst) sb
2902 return $ Yield z (sa, sb', Nothing)
2903 Skip sb' -> return $ Skip (sa, sb', Just x)
2906#if __GLASGOW_HASKELL__ >= 801
2907{-# RULES "zipWithM xs xs"
2908 forall f xs. zipWithM @Identity f xs xs = mapM (\x -> f x x) xs #-}
2911{-# INLINE zipWith #-}
2912zipWith :: Monad m => (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c
2913zipWith f = zipWithM (\a b -> return (f a b))
2915------------------------------------------------------------------------------
2917------------------------------------------------------------------------------
2919{-# INLINE_NORMAL mergeByM #-}
2922 => (a -> a -> m Ordering) -> Stream m a -> Stream m a -> Stream m a
2923mergeByM cmp (Stream stepa ta) (Stream stepb tb) =
2924 Stream step (Just ta, Just tb, Nothing, Nothing)
2926 {-# INLINE_LATE step #-}
2928 -- one of the values is missing, and the corresponding stream is running
2929 step gst (Just sa, sb, Nothing, b) = do
2932 Yield a sa' -> Skip (Just sa', sb, Just a, b)
2933 Skip sa' -> Skip (Just sa', sb, Nothing, b)
2934 Stop -> Skip (Nothing, sb, Nothing, b)
2936 step gst (sa, Just sb, a, Nothing) = do
2939 Yield b sb' -> Skip (sa, Just sb', a, Just b)
2940 Skip sb' -> Skip (sa, Just sb', a, Nothing)
2941 Stop -> Skip (sa, Nothing, a, Nothing)
2943 -- both the values are available
2944 step _ (sa, sb, Just a, Just b) = do
2946 return $ case res of
2947 GT -> Yield b (sa, sb, Just a, Nothing)
2948 _ -> Yield a (sa, sb, Nothing, Just b)
2950 -- one of the values is missing, corresponding stream is done
2951 step _ (Nothing, sb, Nothing, Just b) =
2952 return $ Yield b (Nothing, sb, Nothing, Nothing)
2954 step _ (sa, Nothing, Just a, Nothing) =
2955 return $ Yield a (sa, Nothing, Nothing, Nothing)
2957 step _ (Nothing, Nothing, Nothing, Nothing) = return Stop
2959{-# INLINE mergeBy #-}
2962 => (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a
2963mergeBy cmp = mergeByM (\a b -> return $ cmp a b)
2965------------------------------------------------------------------------------
2966-- Transformation comprehensions
2967------------------------------------------------------------------------------
2969{-# INLINE_NORMAL the #-}
2970the :: (Eq a, Monad m) => Stream m a -> m (Maybe a)
2971the (Stream step state) = go state
2974 r <- step defState st
2976 Yield x s -> go' x s
2978 Stop -> return Nothing
2980 r <- step defState st
2982 Yield x s | x == n -> go' n s
2983 | otherwise -> return Nothing
2985 Stop -> return (Just n)
2987--------------------------------------------------------------------------------
2988-- UTF8 Encoding / Decoding
2989--------------------------------------------------------------------------------
2991-- UTF-8 primitives, Lifted from GHC.IO.Encoding.UTF8.
2994ord2 :: Char -> WList
2995ord2 c = assert (n >= 0x80 && n <= 0x07ff) (WCons x1 (WCons x2 WNil))
2998 x1 = fromIntegral $ (n `shiftR` 6) + 0xC0
2999 x2 = fromIntegral $ (n .&. 0x3F) + 0x80
3002ord3 :: Char -> WList
3003ord3 c = assert (n >= 0x0800 && n <= 0xffff) (WCons x1 (WCons x2 (WCons x3 WNil)))
3006 x1 = fromIntegral $ (n `shiftR` 12) + 0xE0
3007 x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
3008 x3 = fromIntegral $ (n .&. 0x3F) + 0x80
3011ord4 :: Char -> WList
3012ord4 c = assert (n >= 0x10000) (WCons x1 (WCons x2 (WCons x3 (WCons x4 WNil))))
3015 x1 = fromIntegral $ (n `shiftR` 18) + 0xF0
3016 x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80
3017 x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
3018 x4 = fromIntegral $ (n .&. 0x3F) + 0x80
3020data CodingFailureMode
3021 = TransliterateCodingFailure
3022 | ErrorOnCodingFailure
3025{-# INLINE replacementChar #-}
3026replacementChar :: Char
3027replacementChar = '\xFFFD'
3029-- Int helps in cheaper conversion from Int to Char
3031type DecoderState = Word8
3033-- See http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ for details.
3035{-# INLINE runFold #-}
3036runFold :: (Monad m) => Fold m a b -> Stream m a -> m b
3037runFold (Fold step begin done) = foldlMx' step begin done
3039-- Aligning to cacheline makes a barely noticeable difference
3040utf8d :: A.Array Word8
3041utf8d = unsafePerformIO $ runFold (A.writeAligned 64) $ fromList [
3042 -- The first part of the table maps bytes to character classes that
3043 -- to reduce the size of the transition table and create bitmasks.
3044 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,
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 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,
3049 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,
3050 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,
3051 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,
3053 -- The second part is a transition table that maps a combination
3054 -- of a state of the automaton and a character class to a state.
3055 0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12,
3056 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,
3057 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,
3058 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,
3059 12,36,12,12,12,12,12,12,12,12,12,12
3062-- | Return element at the specified index without checking the bounds.
3063-- and without touching the foreign ptr.
3064{-# INLINE_NORMAL unsafePeekElemOff #-}
3065unsafePeekElemOff :: forall a. Storable a => Ptr a -> Int -> a
3066unsafePeekElemOff p i = let !x = A.unsafeInlineIO $ peekElemOff p i in x
3068-- decode is split into two separate cases to avoid branching instructions.
3069-- From the higher level flow we already know which case we are in so we can
3070-- call the appropriate decode function.
3072-- When the state is 0
3073{-# INLINE decode0 #-}
3074decode0 :: Ptr Word8 -> Word8 -> Tuple' DecoderState CodePoint
3076 let !t = table `unsafePeekElemOff` fromIntegral byte
3077 !codep' = (0xff `shiftR` (fromIntegral t)) .&. fromIntegral byte
3078 !state' = table `unsafePeekElemOff` (256 + fromIntegral t)
3079 in (Tuple' state' codep')
3081-- When the state is not 0
3082{-# INLINE decode1 #-}
3088 -> Tuple' DecoderState CodePoint
3089decode1 table state codep byte =
3090 -- Remember codep is Int type!
3091 -- Can it be unsafe to convert the resulting to Char?
3092 let !t = table `unsafePeekElemOff` fromIntegral byte
3093 !codep' = (fromIntegral byte .&. 0x3f) .|. (codep `shiftL` 6)
3094 !state' = table `unsafePeekElemOff`
3095 (256 + fromIntegral state + fromIntegral t)
3096 in (Tuple' state' codep')
3100 = FreshPointDecodeInit s
3101 | FreshPointDecodeFirst s Word8
3102 | FreshPointDecoding s !DecoderState !CodePoint
3103 | YieldAndContinue !Char (FreshPoint s)
3106-- XXX Add proper error messages
3107{-# INLINE_NORMAL decodeUtf8With #-}
3108decodeUtf8With :: Monad m => CodingFailureMode -> Stream m Word8 -> Stream m Char
3109decodeUtf8With cfm (Stream step state) =
3110 let Array p _ _ = utf8d
3111 !ptr = (unsafeForeignPtrToPtr p)
3112 in Stream (step' ptr) (FreshPointDecodeInit state)
3114 {-# INLINE transliterateOrError #-}
3115 transliterateOrError e s =
3117 ErrorOnCodingFailure -> error e
3118 TransliterateCodingFailure -> YieldAndContinue replacementChar s
3119 {-# INLINE inputUnderflow #-}
3122 ErrorOnCodingFailure ->
3123 error "Streamly.Streams.StreamD.decodeUtf8With: Input Underflow"
3124 TransliterateCodingFailure -> YieldAndContinue replacementChar Done
3125 {-# INLINE_LATE step' #-}
3126 step' _ gst (FreshPointDecodeInit st) = do
3127 r <- step (adaptState gst) st
3130 -- Note: It is important to use a ">" instead of a "<=" test
3131 -- here for GHC to generate code layout for default branch
3132 -- prediction for the common case. This is fragile and might
3133 -- change with the compiler versions, we need a more reliable
3134 -- "likely" primitive to control branch predication.
3137 return $ Skip $ YieldAndContinue
3138 (unsafeChr (fromIntegral x))
3139 (FreshPointDecodeInit s)
3140 -- Using a separate state here generates a jump to a
3141 -- separate code block in the core which seems to perform
3142 -- slightly better for the non-ascii case.
3143 True -> return $ Skip $ FreshPointDecodeFirst s x
3144 Skip s -> return $ Skip (FreshPointDecodeInit s)
3145 Stop -> return $ Skip Done
3147 step' table _ (FreshPointDecodeFirst st x) = do
3148 let (Tuple' sv cp) = decode0 table x
3153 transliterateOrError
3154 "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered"
3155 (FreshPointDecodeInit st)
3156 0 -> error "unreachable state"
3157 _ -> Skip (FreshPointDecoding st sv cp)
3159 step' table gst (FreshPointDecoding st statePtr codepointPtr) = do
3160 r <- step (adaptState gst) st
3163 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
3166 0 -> Skip $ YieldAndContinue (unsafeChr cp)
3167 (FreshPointDecodeInit s)
3170 transliterateOrError
3171 "Streamly.Streams.StreamD.decodeUtf8With: Invalid UTF8 codepoint encountered"
3172 (FreshPointDecodeInit s)
3173 _ -> Skip (FreshPointDecoding s sv cp)
3174 Skip s -> return $ Skip (FreshPointDecoding s statePtr codepointPtr)
3175 Stop -> return $ Skip inputUnderflow
3177 step' _ _ (YieldAndContinue c s) = return $ Yield c s
3178 step' _ _ Done = return Stop
3180{-# INLINE decodeUtf8 #-}
3181decodeUtf8 :: Monad m => Stream m Word8 -> Stream m Char
3182decodeUtf8 = decodeUtf8With ErrorOnCodingFailure
3184{-# INLINE decodeUtf8Lenient #-}
3185decodeUtf8Lenient :: Monad m => Stream m Word8 -> Stream m Char
3186decodeUtf8Lenient = decodeUtf8With TransliterateCodingFailure
3188data FlattenState s a
3189 = OuterLoop s !(Maybe (DecoderState, CodePoint))
3190 | InnerLoopDecodeInit s (ForeignPtr a) !(Ptr a) !(Ptr a)
3191 | InnerLoopDecodeFirst s (ForeignPtr a) !(Ptr a) !(Ptr a) Word8
3192 | InnerLoopDecoding s (ForeignPtr a) !(Ptr a) !(Ptr a)
3193 !DecoderState !CodePoint
3194 | YAndC !Char (FlattenState s a) -- These constructors can be
3195 -- encoded in the FreshPoint
3196 -- type, I prefer to keep these
3197 -- flat even though that means
3198 -- coming up with new names
3201-- The normal decodeUtf8 above should fuse with flattenArrays
3202-- to create this exact code but it doesn't for some reason, as of now this
3203-- remains the fastest way I could figure out to decodeUtf8.
3205-- XXX Add Proper error messages
3206{-# INLINE_NORMAL decodeUtf8ArraysWith #-}
3207decodeUtf8ArraysWith ::
3209 => CodingFailureMode
3210 -> Stream m (A.Array Word8)
3212decodeUtf8ArraysWith cfm (Stream step state) =
3213 let Array p _ _ = utf8d
3214 !ptr = (unsafeForeignPtrToPtr p)
3215 in Stream (step' ptr) (OuterLoop state Nothing)
3217 {-# INLINE transliterateOrError #-}
3218 transliterateOrError e s =
3220 ErrorOnCodingFailure -> error e
3221 TransliterateCodingFailure -> YAndC replacementChar s
3222 {-# INLINE inputUnderflow #-}
3225 ErrorOnCodingFailure ->
3227 "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Input Underflow"
3228 TransliterateCodingFailure -> YAndC replacementChar D
3229 {-# INLINE_LATE step' #-}
3230 step' _ gst (OuterLoop st Nothing) = do
3231 r <- step (adaptState gst) st
3234 Yield A.Array {..} s ->
3235 let p = unsafeForeignPtrToPtr aStart
3236 in Skip (InnerLoopDecodeInit s aStart p aEnd)
3237 Skip s -> Skip (OuterLoop s Nothing)
3239 step' _ gst (OuterLoop st dst@(Just (ds, cp))) = do
3240 r <- step (adaptState gst) st
3243 Yield A.Array {..} s ->
3244 let p = unsafeForeignPtrToPtr aStart
3245 in Skip (InnerLoopDecoding s aStart p aEnd ds cp)
3246 Skip s -> Skip (OuterLoop s dst)
3247 Stop -> Skip inputUnderflow
3248 step' _ _ (InnerLoopDecodeInit st startf p end)
3250 liftIO $ touchForeignPtr startf
3251 return $ Skip $ OuterLoop st Nothing
3252 step' _ _ (InnerLoopDecodeInit st startf p end) = do
3253 x <- liftIO $ peek p
3254 -- Note: It is important to use a ">" instead of a "<=" test here for
3255 -- GHC to generate code layout for default branch prediction for the
3256 -- common case. This is fragile and might change with the compiler
3257 -- versions, we need a more reliable "likely" primitive to control
3258 -- branch predication.
3261 return $ Skip $ YAndC
3262 (unsafeChr (fromIntegral x))
3263 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
3264 -- Using a separate state here generates a jump to a separate code
3265 -- block in the core which seems to perform slightly better for the
3267 True -> return $ Skip $ InnerLoopDecodeFirst st startf p end x
3269 step' table _ (InnerLoopDecodeFirst st startf p end x) = do
3270 let (Tuple' sv cp) = decode0 table x
3275 transliterateOrError
3276 "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered"
3277 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
3278 0 -> error "unreachable state"
3279 _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)
3280 step' _ _ (InnerLoopDecoding st startf p end sv cp)
3282 liftIO $ touchForeignPtr startf
3283 return $ Skip $ OuterLoop st (Just (sv, cp))
3284 step' table _ (InnerLoopDecoding st startf p end statePtr codepointPtr) = do
3285 x <- liftIO $ peek p
3286 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
3293 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
3296 transliterateOrError
3297 "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered"
3298 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
3299 _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)
3300 step' _ _ (YAndC c s) = return $ Yield c s
3301 step' _ _ D = return Stop
3303{-# INLINE decodeUtf8Arrays #-}
3306 => Stream m (A.Array Word8)
3308decodeUtf8Arrays = decodeUtf8ArraysWith ErrorOnCodingFailure
3310{-# INLINE decodeUtf8ArraysLenient #-}
3311decodeUtf8ArraysLenient ::
3313 => Stream m (A.Array Word8)
3315decodeUtf8ArraysLenient = decodeUtf8ArraysWith TransliterateCodingFailure
3317data WList = WCons !Word8 !WList | WNil
3319data EncodeState s = EncodeState s !WList
3321{-# INLINE_NORMAL encodeUtf8 #-}
3322encodeUtf8 :: Monad m => Stream m Char -> Stream m Word8
3323encodeUtf8 (Stream step state) = Stream step' (EncodeState state WNil)
3325 {-# INLINE_LATE step' #-}
3326 step' gst (EncodeState st WNil) = do
3327 r <- step (adaptState gst) st
3335 (EncodeState s (WCons (fromIntegral x) WNil))
3336 | x <= 0x7FF -> Skip (EncodeState s (ord2 c))
3340 "Streamly.Streams.StreamD.encodeUtf8: Encountered a surrogate"
3341 else Skip (EncodeState s (ord3 c))
3342 | otherwise -> Skip (EncodeState s (ord4 c))
3343 Skip s -> Skip (EncodeState s WNil)
3345 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