git.iko.soy/streamly
on master help sign in
Make the initial value of Fold a Step type
bdedb69adithyaov
src/Streamly/Internal/Data/Array.hs+2−2
compare with master
unifiedsplit
@@ -111,7 +111,7 @@ writeN limit = Fold step initial extract
111 where
111 where
112 initial = do
112 initial = do
113 marr <- liftIO $ newArray limit bottomElement
113 marr <- liftIO $ newArray limit bottomElement
114− return (Tuple' marr 0)
114+ return $ FL.Partial (Tuple' marr 0)
115 step st@(Tuple' marr i) x
115 step st@(Tuple' marr i) x
116 | i == limit = fmap FL.Done $ extract st
116 | i == limit = fmap FL.Done $ extract st
117 | otherwise = do
117 | otherwise = do
@@ -125,7 +125,7 @@ write = Fold step initial extract
125 where
125 where
126 initial = do
126 initial = do
127 marr <- liftIO $ newArray 0 bottomElement
127 marr <- liftIO $ newArray 0 bottomElement
128− return (Tuple3' marr 0 0)
128+ return $ FL.Partial (Tuple3' marr 0 0)
129 step (Tuple3' marr i capacity) x
129 step (Tuple3' marr i capacity) x
130 | i == capacity =
130 | i == capacity =
131 let newCapacity = max (capacity * 2) 1
131 let newCapacity = max (capacity * 2) 1
src/Streamly/Internal/Data/Array/Prim/MutTypesInclude.hs+8−7
@@ -6,6 +6,7 @@
6
6
7import Control.Monad (when)
7import Control.Monad (when)
8import Control.Monad.IO.Class (MonadIO(..))
8import Control.Monad.IO.Class (MonadIO(..))
9+import Data.Bifunctor (first)
9import Data.Primitive.Types (Prim(..), sizeOf)
10import Data.Primitive.Types (Prim(..), sizeOf)
10import Streamly.Internal.Data.Fold.Types (Fold(..))
11import Streamly.Internal.Data.Fold.Types (Fold(..))
11import Streamly.Internal.Data.SVar (adaptState)
12import Streamly.Internal.Data.SVar (adaptState)
@@ -168,7 +169,7 @@ writeN limit = Fold step initial extract
168
169
169 initial = do
170 initial = do
170 marr <- newArray limit
171 marr <- newArray limit
171− return $ Tuple' marr 0
172+ return $ FL.Partial $ Tuple' marr 0
172
173
173 extract (Tuple' marr len) = shrinkArray marr len >> return marr
174 extract (Tuple' marr len) = shrinkArray marr len >> return marr
174
175
@@ -367,8 +368,8 @@ lpackArraysChunksOf n (Fold step1 initial1 extract1) =
367 ++ "packArraysChunksOf: the size of arrays ["
368 ++ "packArraysChunksOf: the size of arrays ["
368 ++ show n
369 ++ show n
369 ++ "] must be a natural number"
370 ++ "] must be a natural number"
370− r1 <- initial1
371+ res <- initial1
371− return (Tuple' Nothing r1)
372+ return $ first (Tuple' Nothing) res
372
373
373 extract (Tuple' Nothing r1) = extract1 r1
374 extract (Tuple' Nothing r1) = extract1 r1
374 extract (Tuple' (Just buf) r1) = do
375 extract (Tuple' (Just buf) r1) = do
@@ -386,8 +387,8 @@ lpackArraysChunksOf n (Fold step1 initial1 extract1) =
386 FL.Done () -> return $ FL.Done ()
387 FL.Done () -> return $ FL.Done ()
387 FL.Partial s -> do
388 FL.Partial s -> do
388 extract1 s
389 extract1 s
389− r1' <- initial1
390+ res <- initial1
390− return $ FL.Partial $ Tuple' Nothing r1'
391+ return $ first (Tuple' Nothing) res
391 else return $ FL.Partial $ Tuple' (Just arr) r1
392 else return $ FL.Partial $ Tuple' (Just arr) r1
392 step (Tuple' (Just buf) r1) arr = do
393 step (Tuple' (Just buf) r1) arr = do
393 blen <- byteLength buf
394 blen <- byteLength buf
@@ -401,6 +402,6 @@ lpackArraysChunksOf n (Fold step1 initial1 extract1) =
401 FL.Done () -> return $ FL.Done ()
402 FL.Done () -> return $ FL.Done ()
402 FL.Partial s -> do
403 FL.Partial s -> do
403 extract1 s
404 extract1 s
404− r1' <- initial1
405+ res <- initial1
405− return $ FL.Partial $ Tuple' Nothing r1'
406+ return $ first (Tuple' Nothing) res
406 else return $ FL.Partial $ Tuple' (Just buf') r1
407 else return $ FL.Partial $ Tuple' (Just buf') r1
src/Streamly/Internal/Data/Array/Prim/Pinned/Mut/Types.hs+1−1
@@ -143,7 +143,7 @@ writeNAligned align limit = Fold step initial extract
143
143
144 initial = do
144 initial = do
145 marr <- newAlignedArray limit align
145 marr <- newAlignedArray limit align
146− return $ Tuple' marr 0
146+ return $ FL.Partial $ Tuple' marr 0
147
147
148 extract (Tuple' marr len) = shrinkArray marr len >> return marr
148 extract (Tuple' marr len) = shrinkArray marr len >> return marr
149
149
src/Streamly/Internal/Data/Array/Prim/TypesInclude.hs+7−6
@@ -8,6 +8,7 @@ import Control.DeepSeq (NFData(..))
8import Control.Monad (when)
8import Control.Monad (when)
9import Control.Monad.IO.Class (MonadIO(..))
9import Control.Monad.IO.Class (MonadIO(..))
10import Control.Monad.Primitive (PrimMonad(..), primitive_)
10import Control.Monad.Primitive (PrimMonad(..), primitive_)
11+import Data.Bifunctor (first)
11import Data.Primitive.Types (Prim(..), sizeOf)
12import Data.Primitive.Types (Prim(..), sizeOf)
12#if __GLASGOW_HASKELL__ < 808
13#if __GLASGOW_HASKELL__ < 808
13import Data.Semigroup (Semigroup(..))
14import Data.Semigroup (Semigroup(..))
@@ -603,8 +604,8 @@ lpackArraysChunksOf n (Fold step1 initial1 extract1) =
603 -- XXX we can pass the module string from the higher level API
604 -- XXX we can pass the module string from the higher level API
604 error $ "Streamly.Internal.Data.Array.Storable.Foreign.Types.packArraysChunksOf: the size of "
605 error $ "Streamly.Internal.Data.Array.Storable.Foreign.Types.packArraysChunksOf: the size of "
605 ++ "arrays [" ++ show n ++ "] must be a natural number"
606 ++ "arrays [" ++ show n ++ "] must be a natural number"
606− r1 <- initial1
607+ res <- initial1
607− return (Tuple3' Nothing' 0 r1)
608+ return $ first (Tuple3' Nothing' 0) res
608
609
609 extract (Tuple3' Nothing' _ r1) = extract1 r1
610 extract (Tuple3' Nothing' _ r1) = extract1 r1
610 extract (Tuple3' (Just' buf) boff r1) = do
611 extract (Tuple3' (Just' buf) boff r1) = do
@@ -622,8 +623,8 @@ lpackArraysChunksOf n (Fold step1 initial1 extract1) =
622 FL.Done _ -> return $ FL.Done ()
623 FL.Done _ -> return $ FL.Done ()
623 FL.Partial s -> do
624 FL.Partial s -> do
624 extract1 s
625 extract1 s
625− r1' <- initial1
626+ res <- initial1
626− return $ FL.Partial $ Tuple3' Nothing' 0 r1'
627+ return $ first (Tuple3' Nothing' 0) res
627 else do
628 else do
628 buf <- MA.newArray nElem
629 buf <- MA.newArray nElem
629 noff <- spliceInto buf 0 arr
630 noff <- spliceInto buf 0 arr
@@ -640,8 +641,8 @@ lpackArraysChunksOf n (Fold step1 initial1 extract1) =
640 FL.Done _ -> return $ FL.Done ()
641 FL.Done _ -> return $ FL.Done ()
641 FL.Partial s -> do
642 FL.Partial s -> do
642 extract1 s
643 extract1 s
643− r1' <- initial1
644+ res <- initial1
644− return $ FL.Partial $ Tuple3' Nothing' 0 r1'
645+ return $ first (Tuple3' Nothing' 0) res
645 else return $ FL.Partial $ Tuple3' (Just' buf) noff r1
646 else return $ FL.Partial $ Tuple3' (Just' buf) noff r1
646
647
647data SplitState s arr
648data SplitState s arr
src/Streamly/Internal/Data/Array/Storable/Foreign.hs+3−1
@@ -319,7 +319,9 @@ lastN n
319 step (Tuple3' rb rh i) a = do
319 step (Tuple3' rb rh i) a = do
320 rh1 <- liftIO $ RB.unsafeInsert rb rh a
320 rh1 <- liftIO $ RB.unsafeInsert rb rh a
321 return $ FL.Partial $ Tuple3' rb rh1 (i + 1)
321 return $ FL.Partial $ Tuple3' rb rh1 (i + 1)
322+ initial =
322− initial = fmap (\(a, b) -> Tuple3' a b (0 :: Int)) $ liftIO $ RB.new n
323+ let f (a, b) = FL.Partial $ Tuple3' a b (0 :: Int)
324+ in fmap f $ liftIO $ RB.new n
323 done (Tuple3' rb rh i) = do
325 done (Tuple3' rb rh i) = do
324 arr <- liftIO $ MA.newArray n
326 arr <- liftIO $ MA.newArray n
325 foldFunc i rh snoc' arr rb
327 foldFunc i rh snoc' arr rb
src/Streamly/Internal/Data/Array/Storable/Foreign/Mut/Types.hs+10−8
@@ -93,6 +93,7 @@ import Control.Exception (assert)
93import Control.DeepSeq (NFData(..))
93import Control.DeepSeq (NFData(..))
94import Control.Monad (when, void)
94import Control.Monad (when, void)
95import Control.Monad.IO.Class (MonadIO(..))
95import Control.Monad.IO.Class (MonadIO(..))
96+import Data.Bifunctor (first)
96import Data.Functor.Identity (runIdentity)
97import Data.Functor.Identity (runIdentity)
97#if __GLASGOW_HASKELL__ < 808
98#if __GLASGOW_HASKELL__ < 808
98import Data.Semigroup (Semigroup(..))
99import Data.Semigroup (Semigroup(..))
@@ -674,8 +675,9 @@ lpackArraysChunksOf n (Fold step1 initial1 extract1) =
674 -- XXX we can pass the module string from the higher level API
675 -- XXX we can pass the module string from the higher level API
675 error $ "Streamly.Internal.Data.Array.Storable.Foreign.Mut.Types.packArraysChunksOf: the size of "
676 error $ "Streamly.Internal.Data.Array.Storable.Foreign.Mut.Types.packArraysChunksOf: the size of "
676 ++ "arrays [" ++ show n ++ "] must be a natural number"
677 ++ "arrays [" ++ show n ++ "] must be a natural number"
678+
677− r1 <- initial1
679+ r <- initial1
678− return (Tuple' Nothing r1)
680+ return $ first (Tuple' Nothing) r
679
681
680 extract (Tuple' Nothing r1) = extract1 r1
682 extract (Tuple' Nothing r1) = extract1 r1
681 extract (Tuple' (Just buf) r1) = do
683 extract (Tuple' (Just buf) r1) = do
@@ -693,8 +695,8 @@ lpackArraysChunksOf n (Fold step1 initial1 extract1) =
693 FL.Done _ -> return $ FL.Done ()
695 FL.Done _ -> return $ FL.Done ()
694 FL.Partial s -> do
696 FL.Partial s -> do
695 extract1 s
697 extract1 s
696− r1' <- initial1
698+ res <- initial1
697− return $ FL.Partial $ Tuple' Nothing r1'
699+ return $ first (Tuple' Nothing) res
698 else return $ FL.Partial $ Tuple' (Just arr) r1
700 else return $ FL.Partial $ Tuple' (Just arr) r1
699
701
700 step (Tuple' (Just buf) r1) arr = do
702 step (Tuple' (Just buf) r1) arr = do
@@ -712,8 +714,8 @@ lpackArraysChunksOf n (Fold step1 initial1 extract1) =
712 FL.Done _ -> return $ FL.Done ()
714 FL.Done _ -> return $ FL.Done ()
713 FL.Partial s -> do
715 FL.Partial s -> do
714 extract1 s
716 extract1 s
715− r1' <- initial1
717+ res <- initial1
716− return $ FL.Partial $ Tuple' Nothing r1'
718+ return $ first (Tuple' Nothing) res
717 else return $ FL.Partial $ Tuple' (Just buf'') r1
719 else return $ FL.Partial $ Tuple' (Just buf'') r1
718
720
719#if !defined(mingw32_HOST_OS)
721#if !defined(mingw32_HOST_OS)
@@ -1090,7 +1092,7 @@ writeNAllocWith alloc n = Fold step initial extract
1090
1092
1091 where
1093 where
1092
1094
1093− initial = liftIO $ alloc (max n 0)
1095+ initial = FL.Partial <$> liftIO (alloc (max n 0))
1094 step arr@(Array _ end bound) _ | end == bound = return $ FL.Done arr
1096 step arr@(Array _ end bound) _ | end == bound = return $ FL.Done arr
1095 step (Array start end bound) x = do
1097 step (Array start end bound) x = do
1096 liftIO $ poke end x
1098 liftIO $ poke end x
@@ -1150,7 +1152,7 @@ writeNUnsafe n = Fold step initial extract
1150
1152
1151 initial = do
1153 initial = do
1152 (Array start end _) <- liftIO $ newArray (max n 0)
1154 (Array start end _) <- liftIO $ newArray (max n 0)
1153− return $ ArrayUnsafe start end
1155+ return $ FL.Partial $ ArrayUnsafe start end
1154
1156
1155 step (ArrayUnsafe start end) x = do
1157 step (ArrayUnsafe start end) x = do
1156 liftIO $ poke end x
1158 liftIO $ poke end x
src/Streamly/Internal/Data/Either/Strict.hs+29
@@ -19,8 +19,37 @@
19--
19--
20module Streamly.Internal.Data.Either.Strict
20module Streamly.Internal.Data.Either.Strict
21 ( Either' (..)
21 ( Either' (..)
22+ , isLeft'
23+ , isRight'
24+ , fromLeft'
25+ , fromRight'
22 )
26 )
23where
27where
24
28
25-- | A strict 'Either'
29-- | A strict 'Either'
26data Either' a b = Left' !a | Right' !b deriving Show
30data Either' a b = Left' !a | Right' !b deriving Show
31+
32+-- | Return 'True' if the given value is a Left', 'False' otherwise.
33+{-# INLINABLE isLeft' #-}
34+isLeft' :: Either' a b -> Bool
35+isLeft' (Left' _) = True
36+isLeft' (Right' _) = False
37+
38+-- | Return 'True' if the given value is a Right', 'False' otherwise.
39+{-# INLINABLE isRight' #-}
40+isRight' :: Either' a b -> Bool
41+isRight' (Left' _) = False
42+isRight' (Right' _) = True
43+
44+-- XXX This is partial. We can use a default value instead.
45+-- | Return the contents of a Left'-value or errors out.
46+{-# INLINABLE fromLeft' #-}
47+fromLeft' :: Either' a b -> a
48+fromLeft' (Left' a) = a
49+fromLeft' _ = error "fromLeft' expecting a Left'-value"
50+
51+-- | Return the contents of a Right'-value or errors out.
52+{-# INLINABLE fromRight' #-}
53+fromRight' :: Either' a b -> b
54+fromRight' (Right' b) = b
55+fromRight' _ = error "fromRight' expecting a Right'-value"
src/Streamly/Internal/Data/Fold.hs+367−259
@@ -66,6 +66,7 @@ module Streamly.Internal.Data.Fold
66 -- ** Collectors
66 -- ** Collectors
67 , toList
67 , toList
68 , toListRevF -- experimental
68 , toListRevF -- experimental
69+ -- $toListRevF
69 , toParallelSVar
70 , toParallelSVar
70
71
71 -- * Terminating Folds
72 -- * Terminating Folds
@@ -224,6 +225,7 @@ where
224
225
225import Control.Monad (void, join)
226import Control.Monad (void, join)
226import Control.Monad.IO.Class (MonadIO(..))
227import Control.Monad.IO.Class (MonadIO(..))
228+import Data.Bifunctor (first)
227import Data.Functor.Identity (Identity(..))
229import Data.Functor.Identity (Identity(..))
228import Data.Int (Int64)
230import Data.Int (Int64)
229import Data.Map.Strict (Map)
231import Data.Map.Strict (Map)
@@ -235,6 +237,8 @@ import Streamly.Internal.Data.Either.Strict (Either'(..))
235import Streamly.Internal.Data.Maybe.Strict (Maybe'(..), toMaybe)
237import Streamly.Internal.Data.Maybe.Strict (Maybe'(..), toMaybe)
236import Streamly.Internal.Data.Pipe.Types (Pipe (..), PipeState(..))
238import Streamly.Internal.Data.Pipe.Types (Pipe (..), PipeState(..))
237import Streamly.Internal.Data.Tuple.Strict (Tuple'(..), Tuple3'(..))
239import Streamly.Internal.Data.Tuple.Strict (Tuple'(..), Tuple3'(..))
240+import Streamly.Internal.Data.Either.Strict
241+ (fromLeft', fromRight', isLeft', isRight')
238
242
239import qualified Data.Map.Strict as Map
243import qualified Data.Map.Strict as Map
240import qualified Streamly.Internal.Data.Fold.Types as FL
244import qualified Streamly.Internal.Data.Fold.Types as FL
@@ -265,7 +269,7 @@ mkAccum :: Monad m => (s -> a -> s) -> s -> (s -> b) -> Fold m a b
265mkAccum step initial extract =
269mkAccum step initial extract =
266 Fold
270 Fold
267 (\s a -> return $ Partial $ step s a)
271 (\s a -> return $ Partial $ step s a)
268− (return initial)
272+ (return (Partial initial))
269 (return . extract)
273 (return . extract)
270
274
271-- | Similar to 'mkAccum' but the final state extracted is identical to the
275-- | Similar to 'mkAccum' but the final state extracted is identical to the
@@ -284,7 +288,8 @@ mkAccum_ step initial = mkAccum step initial id
284--
288--
285{-# INLINE mkAccumM #-}
289{-# INLINE mkAccumM #-}
286mkAccumM :: Functor m => (s -> a -> m s) -> m s -> (s -> m b) -> Fold m a b
290mkAccumM :: Functor m => (s -> a -> m s) -> m s -> (s -> m b) -> Fold m a b
291+mkAccumM step initial =
287−mkAccumM step = Fold (\s a -> Partial <$> step s a)
292+ Fold (\s a -> Partial <$> step s a) (Partial <$> initial)
288
293
289-- | Similar to 'mkAccumM' but the final state extracted is identical to the
294-- | Similar to 'mkAccumM' but the final state extracted is identical to the
290-- intermediate state.
295-- intermediate state.
@@ -301,7 +306,7 @@ mkAccumM_ step initial = mkAccumM step initial return
301-- /Internal/
306-- /Internal/
302--
307--
303{-# INLINE mkFold #-}
308{-# INLINE mkFold #-}
304−mkFold :: Monad m => (s -> a -> Step s b) -> s -> (s -> b) -> Fold m a b
309+mkFold :: Monad m => (s -> a -> Step s b) -> Step s b -> (s -> b) -> Fold m a b
305mkFold step initial extract =
310mkFold step initial extract =
306 Fold (\s a -> return $ step s a) (return initial) (return . extract)
311 Fold (\s a -> return $ step s a) (return initial) (return . extract)
307
312
@@ -311,7 +316,7 @@ mkFold step initial extract =
311-- /Internal/
316-- /Internal/
312--
317--
313{-# INLINE mkFold_ #-}
318{-# INLINE mkFold_ #-}
314−mkFold_ :: Monad m => (b -> a -> Step b b) -> b -> Fold m a b
319+mkFold_ :: Monad m => (b -> a -> Step b b) -> Step b b -> Fold m a b
315mkFold_ step initial = mkFold step initial id
320mkFold_ step initial = mkFold step initial id
316
321
317-- | Make a terminating fold with an effectful step function and initial state,
322-- | Make a terminating fold with an effectful step function and initial state,
@@ -324,7 +329,7 @@ mkFold_ step initial = mkFold step initial id
324-- /Internal/
329-- /Internal/
325--
330--
326{-# INLINE mkFoldM #-}
331{-# INLINE mkFoldM #-}
327−mkFoldM :: (s -> a -> m (Step s b)) -> m s -> (s -> m b) -> Fold m a b
332+mkFoldM :: (s -> a -> m (Step s b)) -> m (Step s b) -> (s -> m b) -> Fold m a b
328mkFoldM = Fold
333mkFoldM = Fold
329
334
330-- | Similar to 'mkFoldM' but the final state extracted is identical to the
335-- | Similar to 'mkFoldM' but the final state extracted is identical to the
@@ -333,8 +338,8 @@ mkFoldM = Fold
333-- /Internal/
338-- /Internal/
334--
339--
335{-# INLINE mkFoldM_ #-}
340{-# INLINE mkFoldM_ #-}
336−mkFoldM_ :: Monad m => (b -> a -> m (Step b b)) -> m b -> Fold m a b
341+mkFoldM_ :: Monad m => (b -> a -> m (Step b b)) -> m (Step b b) -> Fold m a b
337−mkFoldM_ step initial = Fold step initial return
342+mkFoldM_ step initial = mkFoldM step initial return
338
343
339------------------------------------------------------------------------------
344------------------------------------------------------------------------------
340-- hoist
345-- hoist
@@ -364,16 +369,19 @@ generally = hoist (return . runIdentity)
364-- @since 0.7.0
369-- @since 0.7.0
365{-# INLINE sequence #-}
370{-# INLINE sequence #-}
366sequence :: Monad m => Fold m a (m b) -> Fold m a b
371sequence :: Monad m => Fold m a (m b) -> Fold m a b
367−sequence (Fold step initial extract) = Fold step' initial extract'
372+sequence (Fold step initial extract) = Fold step' initial1 extract'
368
373
369 where
374 where
370
375
371− step' s a = do
376+ eval res =
372− res <- step s a
373 case res of
377 case res of
374 Partial x -> return $ Partial x
378 Partial x -> return $ Partial x
375 Done b -> Done <$> b
379 Done b -> Done <$> b
376
380
381+ initial1 = initial >>= eval
382+
383+ step' s a = step s a >>= eval
384+
377 extract' = join . extract
385 extract' = join . extract
378
386
379-- | Map a monadic function on the output of a fold.
387-- | Map a monadic function on the output of a fold.
@@ -413,7 +421,7 @@ transform (Pipe pstep1 pstep2 pinitial) (Fold fstep finitial fextract) =
413
421
414 where
422 where
415
423
416− initial = Tuple' pinitial <$> finitial
424+ initial = first (Tuple' pinitial) <$> finitial
417
425
418 step (Tuple' ps fs) x = do
426 step (Tuple' ps fs) x = do
419 r <- pstep1 ps x
427 r <- pstep1 ps x
@@ -452,12 +460,12 @@ transform (Pipe pstep1 pstep2 pinitial) (Fold fstep finitial fextract) =
452-- from the 'Foldable', the result is 'None' for empty containers.
460-- from the 'Foldable', the result is 'None' for empty containers.
453{-# INLINABLE _Fold1 #-}
461{-# INLINABLE _Fold1 #-}
454_Fold1 :: Monad m => (a -> a -> a) -> Fold m a (Maybe a)
462_Fold1 :: Monad m => (a -> a -> a) -> Fold m a (Maybe a)
455−_Fold1 step = Fold step_ (return Nothing') (return . toMaybe)
463+_Fold1 step = mkAccum step_ Nothing' toMaybe
456
464
457 where
465 where
458
466
459− step_ Nothing' a = return $ Partial $ Just' a
467+ step_ Nothing' a = Just' a
460− step_ (Just' x) a = return $ Partial $ Just' $ step x a
468+ step_ (Just' x) a = Just' $ step x a
461
469
462------------------------------------------------------------------------------
470------------------------------------------------------------------------------
463-- Left folds
471-- Left folds
@@ -475,15 +483,7 @@ _Fold1 step = Fold step_ (return Nothing') (return . toMaybe)
475-- @since 0.7.0
483-- @since 0.7.0
476{-# INLINABLE drain #-}
484{-# INLINABLE drain #-}
477drain :: Monad m => Fold m a ()
485drain :: Monad m => Fold m a ()
478−drain = Fold step begin done
486+drain = mkAccum_ (\_ _ -> ()) ()
479−
480− where
481−
482− begin = return ()
483−
484− step _ _ = return $ FL.Partial ()
485−
486− done = return
487
487
488-- |
488-- |
489-- > drainBy f = lmapM f drain
489-- > drainBy f = lmapM f drain
@@ -495,7 +495,7 @@ drain = Fold step begin done
495-- @since 0.7.0
495-- @since 0.7.0
496{-# INLINABLE drainBy #-}
496{-# INLINABLE drainBy #-}
497drainBy :: Monad m => (a -> m b) -> Fold m a ()
497drainBy :: Monad m => (a -> m b) -> Fold m a ()
498−drainBy f = Fold (const (fmap FL.Partial . void . f)) (return ()) return
498+drainBy f = lmapM f drain
499
499
500{-# INLINABLE drainBy2 #-}
500{-# INLINABLE drainBy2 #-}
501drainBy2 :: Monad m => (a -> m b) -> Fold2 m c a ()
501drainBy2 :: Monad m => (a -> m b) -> Fold2 m c a ()
@@ -521,7 +521,7 @@ last = _Fold1 (\_ x -> x)
521-- @since 0.7.0
521-- @since 0.7.0
522{-# INLINE genericLength #-}
522{-# INLINE genericLength #-}
523genericLength :: (Monad m, Num b) => Fold m a b
523genericLength :: (Monad m, Num b) => Fold m a b
524−genericLength = Fold (\n _ -> return $ Partial $ n + 1) (return 0) return
524+genericLength = mkAccum_ (\n _ -> n + 1) 0
525
525
526-- | Determine the length of the input stream.
526-- | Determine the length of the input stream.
527--
527--
@@ -541,7 +541,7 @@ length = genericLength
541-- @since 0.7.0
541-- @since 0.7.0
542{-# INLINE sum #-}
542{-# INLINE sum #-}
543sum :: (Monad m, Num a) => Fold m a a
543sum :: (Monad m, Num a) => Fold m a a
544−sum = Fold (\x a -> return $ Partial $ x + a) (return 0) return
544+sum = mkAccum_ (+) 0
545
545
546-- | Determine the product of all elements of a stream of numbers. Returns
546-- | Determine the product of all elements of a stream of numbers. Returns
547-- multiplicative identity (@1@) when the stream is empty. The fold terminates
547-- multiplicative identity (@1@) when the stream is empty. The fold terminates
@@ -553,15 +553,14 @@ sum = Fold (\x a -> return $ Partial $ x + a) (return 0) return
553-- /Since 0.8.0 (Added 'Eq' constraint)/
553-- /Since 0.8.0 (Added 'Eq' constraint)/
554{-# INLINE product #-}
554{-# INLINE product #-}
555product :: (Monad m, Num a, Eq a) => Fold m a a
555product :: (Monad m, Num a, Eq a) => Fold m a a
556−product = Fold step (return 1) return
556+product = mkFold_ step (Partial 1)
557
557
558 where
558 where
559
559
560 step x a =
560 step x a =
561− return
562− $ if a == 0
561+ if a == 0
563− then Done 0
562+ then Done 0
564− else Partial $ x * a
563+ else Partial $ x * a
565
564
566------------------------------------------------------------------------------
565------------------------------------------------------------------------------
567-- To Summary (Maybe)
566-- To Summary (Maybe)
@@ -634,16 +633,15 @@ minimum = _Fold1 min
634-- @since 0.7.0
633-- @since 0.7.0
635{-# INLINABLE mean #-}
634{-# INLINABLE mean #-}
636mean :: (Monad m, Fractional a) => Fold m a a
635mean :: (Monad m, Fractional a) => Fold m a a
637−mean = Fold step (return begin) (return . done)
636+mean = mkAccum step begin done
638
637
639 where
638 where
640
639
641 begin = Tuple' 0 0
640 begin = Tuple' 0 0
642
641
643 step (Tuple' x n) y =
642 step (Tuple' x n) y =
644− return
645− $ let n' = n + 1
643+ let n1 = n + 1
646− in Partial $ Tuple' (x + (y - x) / n') n'
644+ in Tuple' (x + (y - x) / n1) n1
647
645
648 done (Tuple' x _) = x
646 done (Tuple' x _) = x
649
647
@@ -653,13 +651,13 @@ mean = Fold step (return begin) (return . done)
653-- @since 0.7.0
651-- @since 0.7.0
654{-# INLINABLE variance #-}
652{-# INLINABLE variance #-}
655variance :: (Monad m, Fractional a) => Fold m a a
653variance :: (Monad m, Fractional a) => Fold m a a
656−variance = Fold step (return begin) (return . done)
654+variance = mkAccum step begin done
657
655
658 where
656 where
659
657
660 begin = Tuple3' 0 0 0
658 begin = Tuple3' 0 0 0
661
659
662− step (Tuple3' n mean_ m2) x = return $ Partial $ Tuple3' n' mean' m2'
660+ step (Tuple3' n mean_ m2) x = Tuple3' n' mean' m2'
663
661
664 where
662 where
665
663
@@ -692,17 +690,13 @@ stdDev = sqrt variance
692-- @since 0.7.0
690-- @since 0.7.0
693{-# INLINABLE rollingHashWithSalt #-}
691{-# INLINABLE rollingHashWithSalt #-}
694rollingHashWithSalt :: (Monad m, Enum a) => Int64 -> Fold m a Int64
692rollingHashWithSalt :: (Monad m, Enum a) => Int64 -> Fold m a Int64
695−rollingHashWithSalt salt = Fold step initial extract
693+rollingHashWithSalt = mkAccum_ step
696
694
697 where
695 where
698
696
699 k = 2891336453 :: Int64
697 k = 2891336453 :: Int64
700
698
701− initial = return salt
702−
703− step cksum a = return $ Partial $ cksum * k + fromIntegral (fromEnum a)
699+ step cksum a = cksum * k + fromIntegral (fromEnum a)
704−
705− extract = return
706
700
707-- | A default salt used in the implementation of 'rollingHash'.
701-- | A default salt used in the implementation of 'rollingHash'.
708{-# INLINE defaultSalt #-}
702{-# INLINE defaultSalt #-}
@@ -738,7 +732,7 @@ rollingHashFirstN n = ltake n rollingHash
738--
732--
739{-# INLINE sconcat #-}
733{-# INLINE sconcat #-}
740sconcat :: (Monad m, Semigroup a) => a -> Fold m a a
734sconcat :: (Monad m, Semigroup a) => a -> Fold m a a
741−sconcat i = Fold (\x a -> return $ Partial $ x <> a) (return i) return
735+sconcat = mkAccum_ (<>)
742
736
743-- | Fold an input stream consisting of monoidal elements using 'mappend'
737-- | Fold an input stream consisting of monoidal elements using 'mappend'
744-- and 'mempty'.
738-- and 'mempty'.
@@ -783,17 +777,13 @@ foldMap f = lmap f mconcat
783-- @since 0.7.0
777-- @since 0.7.0
784{-# INLINABLE foldMapM #-}
778{-# INLINABLE foldMapM #-}
785foldMapM :: (Monad m, Monoid b) => (a -> m b) -> Fold m a b
779foldMapM :: (Monad m, Monoid b) => (a -> m b) -> Fold m a b
786−foldMapM act = Fold step begin done
780+foldMapM act = mkAccumM_ step (pure mempty)
787
781
788 where
782 where
789
783
790− done = return
791−
792− begin = return mempty
793−
794 step m a = do
784 step m a = do
795 m' <- act a
785 m' <- act a
796− return $! Partial $! mappend m m'
786+ return $! mappend m m'
797
787
798------------------------------------------------------------------------------
788------------------------------------------------------------------------------
799-- To Containers
789-- To Containers
@@ -810,9 +800,23 @@ foldMapM act = Fold step begin done
810-- id . (x1 :) . (x2 :) . (x3 :) . ... . (xn :) $ []
800-- id . (x1 :) . (x2 :) . (x3 :) . ... . (xn :) $ []
811{-# INLINABLE toList #-}
801{-# INLINABLE toList #-}
812toList :: Monad m => Fold m a [a]
802toList :: Monad m => Fold m a [a]
813−toList = Fold (\f x -> return $ Partial $ f . (x :))
803+toList = mkAccum (\f x -> f . (x :)) id ($ [])
814− (return id)
804+
815− (return . ($ []))
805+-- $toListRevF
806+-- This is more efficient than 'Streamly.Internal.Data.Fold.toList'. toList is
807+-- exactly the same as reversing the list after 'toListRevF'.
808+
809+-- | Buffers the input stream to a list in the reverse order of the input.
810+--
811+-- /Warning!/ working on large lists accumulated as buffers in memory could be
812+-- very inefficient, consider using "Streamly.Array" instead.
813+--
814+-- @since 0.7.0
815+
816+-- xn : ... : x2 : x1 : []
817+{-# INLINABLE toListRevF #-}
818+toListRevF :: Monad m => Fold m a [a]
819+toListRevF = mkAccum_ (flip (:)) []
816
820
817------------------------------------------------------------------------------
821------------------------------------------------------------------------------
818-- Partial Folds
822-- Partial Folds
@@ -833,15 +837,14 @@ drainN n = ltake n drain
833-- @since 0.7.0
837-- @since 0.7.0
834{-# INLINABLE genericIndex #-}
838{-# INLINABLE genericIndex #-}
835genericIndex :: (Integral i, Monad m) => i -> Fold m a (Maybe a)
839genericIndex :: (Integral i, Monad m) => i -> Fold m a (Maybe a)
836−genericIndex i = Fold step (return 0) (const (return Nothing))
840+genericIndex i = mkFold step (Partial 0) (const Nothing)
837
841
838 where
842 where
839
843
840 step j a =
844 step j a =
841− return
842− $ if i == j
845+ if i == j
843− then Done $ Just a
846+ then Done $ Just a
844− else Partial (j + 1)
847+ else Partial (j + 1)
845
848
846-- | Lookup the element at the given index.
849-- | Lookup the element at the given index.
847--
850--
@@ -869,15 +872,14 @@ head = _Fold1 const
869-- @since 0.7.0
872-- @since 0.7.0
870{-# INLINABLE find #-}
873{-# INLINABLE find #-}
871find :: Monad m => (a -> Bool) -> Fold m a (Maybe a)
874find :: Monad m => (a -> Bool) -> Fold m a (Maybe a)
872−find predicate = Fold step (return ()) (const (return Nothing))
875+find predicate = mkFold step (Partial ()) (const Nothing)
873
876
874 where
877 where
875
878
876 step () a =
879 step () a =
877− return
878− $ if predicate a
880+ if predicate a
879− then Done (Just a)
881+ then Done (Just a)
880− else Partial ()
882+ else Partial ()
881
883
882-- | In a stream of (key-value) pairs @(a, b)@, return the value @b@ of the
884-- | In a stream of (key-value) pairs @(a, b)@, return the value @b@ of the
883-- first pair where the key equals the given value @a@.
885-- first pair where the key equals the given value @a@.
@@ -887,30 +889,28 @@ find predicate = Fold step (return ()) (const (return Nothing))
887-- @since 0.7.0
889-- @since 0.7.0
888{-# INLINABLE lookup #-}
890{-# INLINABLE lookup #-}
889lookup :: (Eq a, Monad m) => a -> Fold m (a,b) (Maybe b)
891lookup :: (Eq a, Monad m) => a -> Fold m (a,b) (Maybe b)
890−lookup a0 = Fold step (return ()) (const (return Nothing))
892+lookup a0 = mkFold step (Partial ()) (const Nothing)
891
893
892 where
894 where
893
895
894 step () (a, b) =
896 step () (a, b) =
895− return
896− $ if a == a0
897+ if a == a0
897− then Done $ Just b
898+ then Done $ Just b
898− else Partial ()
899+ else Partial ()
899
900
900-- | Returns the first index that satisfies the given predicate.
901-- | Returns the first index that satisfies the given predicate.
901--
902--
902-- @since 0.7.0
903-- @since 0.7.0
903{-# INLINABLE findIndex #-}
904{-# INLINABLE findIndex #-}
904findIndex :: Monad m => (a -> Bool) -> Fold m a (Maybe Int)
905findIndex :: Monad m => (a -> Bool) -> Fold m a (Maybe Int)
905−findIndex predicate = Fold step (return 0) (const (return Nothing))
906+findIndex predicate = mkFold step (Partial 0) (const Nothing)
906
907
907 where
908 where
908
909
909 step i a =
910 step i a =
910− return
911− $ if predicate a
911+ if predicate a
912− then Done $ Just i
912+ then Done $ Just i
913− else Partial (i + 1)
913+ else Partial (i + 1)
914
914
915-- | Returns the first index where a given value is found in the stream.
915-- | Returns the first index where a given value is found in the stream.
916--
916--
@@ -932,7 +932,7 @@ elemIndex a = findIndex (a ==)
932-- @since 0.7.0
932-- @since 0.7.0
933{-# INLINABLE null #-}
933{-# INLINABLE null #-}
934null :: Monad m => Fold m a Bool
934null :: Monad m => Fold m a Bool
935−null = Fold (\() _ -> return $ Done False) (return ()) (\() -> return True)
935+null = mkFold (\() _ -> Done False) (Partial ()) (const True)
936
936
937--
937--
938-- > any p = lmap p or
938-- > any p = lmap p or
@@ -946,17 +946,16 @@ null = Fold (\() _ -> return $ Done False) (return ()) (\() -> return True)
946-- @since 0.7.0
946-- @since 0.7.0
947{-# INLINE any #-}
947{-# INLINE any #-}
948any :: Monad m => (a -> Bool) -> Fold m a Bool
948any :: Monad m => (a -> Bool) -> Fold m a Bool
949−any predicate = Fold step initial return
949+any predicate = mkFold_ step initial
950
950
951 where
951 where
952
952
953− initial = return False
953+ initial = Partial False
954
954
955 step _ a =
955 step _ a =
956− return
957− $ if predicate a
956+ if predicate a
958− then Done True
957+ then Done True
959− else Partial False
958+ else Partial False
960
959
961-- | Return 'True' if the given element is present in the stream.
960-- | Return 'True' if the given element is present in the stream.
962--
961--
@@ -979,17 +978,16 @@ elem a = any (a ==)
979-- @since 0.7.0
978-- @since 0.7.0
980{-# INLINABLE all #-}
979{-# INLINABLE all #-}
981all :: Monad m => (a -> Bool) -> Fold m a Bool
980all :: Monad m => (a -> Bool) -> Fold m a Bool
982−all predicate = Fold step initial return
981+all predicate = mkFold_ step initial
983
982
984 where
983 where
985
984
986− initial = return True
985+ initial = Partial True
987
986
988 step _ a =
987 step _ a =
989− return
990− $ if predicate a
988+ if predicate a
991− then Partial True
989+ then Partial True
992− else Done False
990+ else Done False
993
991
994-- | Returns 'True' if the given element is not present in the stream.
992-- | Returns 'True' if the given element is not present in the stream.
995--
993--
@@ -1199,18 +1197,18 @@ sliceEndWith predicate (Fold fstep finitial fextract) =
1199
1197
1200 initial = finitial
1198 initial = finitial
1201
1199
1202− step s a =
1200+ step s a = do
1201+ res <- fstep s a
1203 if not (predicate a)
1202 if not (predicate a)
1204− then fstep s a
1203+ then return res
1205 else do
1204 else do
1206− res <- fstep s a
1207 case res of
1205 case res of
1208− Partial sres -> Done <$> fextract sres
1206+ Partial s1 -> Done <$> fextract s1
1209− Done bres -> return $ Done bres
1207+ Done b -> return $ Done b
1210
1208
1211data SpanByState a bl fl fr
1209data SpanByState a bl fl fr
1212− = SpanByLeft0 !fl !fr
1210+ = SpanByLeft0 !fl
1213− | SpanByLeft !a !fl !fr
1211+ | SpanByLeft !a !fl
1214 | SpanByRight !bl !fr
1212 | SpanByRight !bl !fr
1215
1213
1216-- | Break the input stream into two groups, the first group takes the input as
1214-- | Break the input stream into two groups, the first group takes the input as
@@ -1231,31 +1229,50 @@ spanBy cmp (Fold stepL initialL extractL) (Fold stepR initialR extractR) =
1231
1229
1232 where
1230 where
1233
1231
1234− initial = SpanByLeft0 <$> initialL <*> initialR
1232+ initial = do
1233+ resL <- initialL
1234+ case resL of
1235+ Partial fl -> return $ Partial $ SpanByLeft0 fl
1236+ Done bl -> do
1237+ resR <- initialR
1238+ return
1239+ $ case resR of
1240+ Partial fr -> Partial $ SpanByRight bl fr
1241+ Done br -> Done (bl, br)
1235
1242
1236− step (SpanByLeft0 fl fr) input = do
1243+ step (SpanByLeft0 fl) input = do
1237 sfl <- stepL fl input
1244 sfl <- stepL fl input
1238− return
1239− $ Partial
1240− $ case sfl of
1245+ case sfl of
1241− Partial fl1 -> SpanByLeft input fl1 fr
1246+ Partial fl1 -> return $ Partial $ SpanByLeft input fl1
1247+ Done bl -> do
1248+ resR <- initialR
1249+ return
1250+ $ case resR of
1242− Done bl -> SpanByRight bl fr
1251+ Partial fr -> Partial $ SpanByRight bl fr
1252+ Done br -> Done (bl, br)
1243− step (SpanByLeft frst fl fr) input =
1253+ step (SpanByLeft frst fl) input =
1244 if cmp frst input
1254 if cmp frst input
1245 then do
1255 then do
1246 sfl <- stepL fl input
1256 sfl <- stepL fl input
1247− return
1248− $ Partial
1249− $ case sfl of
1257+ case sfl of
1250− Partial fl1 -> SpanByLeft frst fl1 fr
1258+ Partial fl1 -> return $ Partial $ SpanByLeft frst fl1
1259+ Done bl -> do
1260+ resR <- initialR
1261+ return
1262+ $ case resR of
1251− Done bl -> SpanByRight bl fr
1263+ Partial fr -> Partial $ SpanByRight bl fr
1264+ Done br -> Done (bl, br)
1252 else do
1265 else do
1253 bl <- extractL fl
1266 bl <- extractL fl
1267+ resR <- initialR
1268+ case resR of
1269+ Partial fr -> do
1254− sfr <- stepR fr input
1270+ sfr <- stepR fr input
1255− return
1271+ return
1256− $ case sfr of
1272+ $ case sfr of
1257− Partial fr1 -> Partial $ SpanByRight bl fr1
1273+ Partial fr1 -> Partial $ SpanByRight bl fr1
1274+ Done br -> Done (bl, br)
1258− Done br -> Done (bl, br)
1275+ Done br -> return $ Done (bl, br)
1259 step (SpanByRight bl fr) input = do
1276 step (SpanByRight bl fr) input = do
1260 sfr <- stepR fr input
1277 sfr <- stepR fr input
1261 return
1278 return
@@ -1263,12 +1280,22 @@ spanBy cmp (Fold stepL initialL extractL) (Fold stepR initialR extractR) =
1263 Partial fr1 -> Partial $ SpanByRight bl fr1
1280 Partial fr1 -> Partial $ SpanByRight bl fr1
1264 Done br -> Done (bl, br)
1281 Done br -> Done (bl, br)
1265
1282
1266− extract (SpanByLeft0 fl fr) = (,) <$> extractL fl <*> extractR fr
1283+ extract (SpanByLeft0 fl) = do
1284+ bl <- extractL fl
1285+ resR <- initialR
1286+ case resR of
1287+ Partial fr -> (bl, ) <$> extractR fr
1288+ Done br -> return (bl, br)
1267− extract (SpanByLeft _ fl fr) = (,) <$> extractL fl <*> extractR fr
1289+ extract (SpanByLeft _ fl) = do
1290+ bl <- extractL fl
1291+ resR <- initialR
1292+ case resR of
1293+ Partial fr -> (bl, ) <$> extractR fr
1294+ Done br -> return (bl, br)
1268 extract (SpanByRight bl fr) = (bl, ) <$> extractR fr
1295 extract (SpanByRight bl fr) = (bl, ) <$> extractR fr
1269
1296
1270data SpanState bl fl fr
1297data SpanState bl fl fr
1271− = SpanLeft !fl !fr
1298+ = SpanLeft !fl
1272 | SpanRight !bl !fr
1299 | SpanRight !bl !fr
1273
1300
1274-- | @span p f1 f2@ composes folds @f1@ and @f2@ such that @f1@ consumes the
1301-- | @span p f1 f2@ composes folds @f1@ and @f2@ such that @f1@ consumes the
@@ -1302,24 +1329,40 @@ span p (Fold stepL initialL extractL) (Fold stepR initialR extractR) =
1302
1329
1303 where
1330 where
1304
1331
1305− initial = SpanLeft <$> initialL <*> initialR
1332+ initial = do
1333+ resL <- initialL
1334+ case resL of
1335+ Partial fl -> return $ Partial $ SpanLeft fl
1336+ Done bl -> do
1337+ resR <- initialR
1338+ return
1339+ $ case resR of
1340+ Partial fr -> Partial $ SpanRight bl fr
1341+ Done br -> Done (bl, br)
1306
1342
1307− step (SpanLeft fl fr) input =
1343+ step (SpanLeft fl) input =
1308 if p input
1344 if p input
1309 then do
1345 then do
1310 sfl <- stepL fl input
1346 sfl <- stepL fl input
1311− return
1312− $ Partial
1313− $ case sfl of
1347+ case sfl of
1314− Partial fl1 -> SpanLeft fl1 fr
1348+ Partial fl1 -> return $ Partial $ SpanLeft fl1
1349+ Done bl -> do
1350+ resR <- initialR
1351+ return
1352+ $ case resR of
1315− Done bl -> SpanRight bl fr
1353+ Partial fr -> Partial $ SpanRight bl fr
1354+ Done br -> Done (bl, br)
1316 else do
1355 else do
1317 bl <- extractL fl
1356 bl <- extractL fl
1357+ resR <- initialR
1358+ case resR of
1359+ Partial fr -> do
1318− sfr <- stepR fr input
1360+ sfr <- stepR fr input
1319− return
1361+ return
1320− $ case sfr of
1362+ $ case sfr of
1321− Partial fr1 -> Partial $ SpanRight bl fr1
1363+ Partial fr1 -> Partial $ SpanRight bl fr1
1364+ Done br -> Done (bl, br)
1322− Done br -> Done (bl, br)
1365+ Done br -> return $ Done (bl, br)
1323 step (SpanRight bl fr) input = do
1366 step (SpanRight bl fr) input = do
1324 sfr <- stepR fr input
1367 sfr <- stepR fr input
1325 return
1368 return
@@ -1327,7 +1370,12 @@ span p (Fold stepL initialL extractL) (Fold stepR initialR extractR) =
1327 Partial fr1 -> Partial $ SpanRight bl fr1
1370 Partial fr1 -> Partial $ SpanRight bl fr1
1328 Done br -> Done (bl, br)
1371 Done br -> Done (bl, br)
1329
1372
1330− extract (SpanLeft fl fr) = (,) <$> extractL fl <*> extractR fr
1373+ extract (SpanLeft fl) = do
1374+ bl <- extractL fl
1375+ resR <- initialR
1376+ case resR of
1377+ Partial fr -> (bl, ) <$> extractR fr
1378+ Done br -> return (bl, br)
1331 extract (SpanRight bl fr) = (bl, ) <$> extractR fr
1379 extract (SpanRight bl fr) = (bl, ) <$> extractR fr
1332
1380
1333-- |
1381-- |
@@ -1376,31 +1424,50 @@ spanByRolling cmp (Fold stepL initialL extractL) (Fold stepR initialR extractR)
1376
1424
1377 where
1425 where
1378
1426
1379− initial = SpanByLeft0 <$> initialL <*> initialR
1427+ initial = do
1428+ resL <- initialL
1429+ case resL of
1430+ Partial fl -> return $ Partial $ SpanByLeft0 fl
1431+ Done bl -> do
1432+ resR <- initialR
1433+ return
1434+ $ case resR of
1435+ Partial fr -> Partial $ SpanByRight bl fr
1436+ Done br -> Done (bl, br)
1380
1437
1381− step (SpanByLeft0 fl fr) input = do
1438+ step (SpanByLeft0 fl) input = do
1382 sfl <- stepL fl input
1439 sfl <- stepL fl input
1383− return
1384− $ Partial
1385− $ case sfl of
1440+ case sfl of
1386− Partial fl1 -> SpanByLeft input fl1 fr
1441+ Partial fl1 -> return $ Partial $ SpanByLeft input fl1
1442+ Done bl -> do
1443+ resR <- initialR
1444+ return
1445+ $ case resR of
1387− Done bl -> SpanByRight bl fr
1446+ Partial fr -> Partial $ SpanByRight bl fr
1447+ Done br -> Done (bl, br)
1388− step (SpanByLeft frst fl fr) input =
1448+ step (SpanByLeft input0 fl) input =
1389− if cmp frst input
1449+ if cmp input0 input
1390 then do
1450 then do
1391 sfl <- stepL fl input
1451 sfl <- stepL fl input
1392− return
1393− $ Partial
1394− $ case sfl of
1452+ case sfl of
1395− Partial fl1 -> SpanByLeft input fl1 fr
1453+ Partial fl1 -> return $ Partial $ SpanByLeft input fl1
1454+ Done bl -> do
1455+ resR <- initialR
1456+ return
1457+ $ case resR of
1396− Done bl -> SpanByRight bl fr
1458+ Partial fr -> Partial $ SpanByRight bl fr
1459+ Done br -> Done (bl, br)
1397 else do
1460 else do
1398 bl <- extractL fl
1461 bl <- extractL fl
1462+ resR <- initialR
1463+ case resR of
1464+ Partial fr -> do
1399− sfr <- stepR fr input
1465+ sfr <- stepR fr input
1400− return
1466+ return
1401− $ case sfr of
1467+ $ case sfr of
1402− Partial fr1 -> Partial $ SpanByRight bl fr1
1468+ Partial fr1 -> Partial $ SpanByRight bl fr1
1469+ Done br -> Done (bl, br)
1403− Done br -> Done (bl, br)
1470+ Done br -> return $ Done (bl, br)
1404 step (SpanByRight bl fr) input = do
1471 step (SpanByRight bl fr) input = do
1405 sfr <- stepR fr input
1472 sfr <- stepR fr input
1406 return
1473 return
@@ -1408,8 +1475,18 @@ spanByRolling cmp (Fold stepL initialL extractL) (Fold stepR initialR extractR)
1408 Partial fr1 -> Partial $ SpanByRight bl fr1
1475 Partial fr1 -> Partial $ SpanByRight bl fr1
1409 Done br -> Done (bl, br)
1476 Done br -> Done (bl, br)
1410
1477
1411− extract (SpanByLeft0 fl fr) = (,) <$> extractL fl <*> extractR fr
1478+ extract (SpanByLeft0 fl) = do
1479+ bl <- extractL fl
1480+ resR <- initialR
1481+ case resR of
1482+ Partial fr -> (bl, ) <$> extractR fr
1483+ Done br -> return (bl, br)
1412− extract (SpanByLeft _ fl fr) = (,) <$> extractL fl <*> extractR fr
1484+ extract (SpanByLeft _ fl) = do
1485+ bl <- extractL fl
1486+ resR <- initialR
1487+ case resR of
1488+ Partial fr -> (bl, ) <$> extractR fr
1489+ Done br -> return (bl, br)
1413 extract (SpanByRight bl fr) = (bl, ) <$> extractR fr
1490 extract (SpanByRight bl fr) = (bl, ) <$> extractR fr
1414
1491
1415------------------------------------------------------------------------------
1492------------------------------------------------------------------------------
@@ -1451,17 +1528,6 @@ breakOn pat f m = undefined
1451tee :: Monad m => Fold m a b -> Fold m a c -> Fold m a (b,c)
1528tee :: Monad m => Fold m a b -> Fold m a c -> Fold m a (b,c)
1452tee = teeWith (,)
1529tee = teeWith (,)
1453
1530
1454−{-# INLINE foldNil #-}
1455−foldNil :: Monad m => Fold m a [b]
1456−foldNil = Fold step begin done where
1457− begin = return []
1458− step _ _ = return $ Partial []
1459− done = return
1460−
1461−{-# INLINE foldCons #-}
1462−foldCons :: Monad m => Fold m a b -> Fold m a [b] -> Fold m a [b]
1463−foldCons = teeWith (:)
1464−
1465-- XXX use "List" instead of "[]"?, use Array for output to scale it to a large
1531-- XXX use "List" instead of "[]"?, use Array for output to scale it to a large
1466-- number of consumers? For polymorphic case a vector could be helpful. For
1532-- number of consumers? For polymorphic case a vector could be helpful. For
1467-- Storables we can use arrays. Will need separate APIs for those.
1533-- Storables we can use arrays. Will need separate APIs for those.
@@ -1488,7 +1554,7 @@ foldCons = teeWith (:)
1488-- @since 0.7.0
1554-- @since 0.7.0
1489{-# INLINE distribute #-}
1555{-# INLINE distribute #-}
1490distribute :: Monad m => [Fold m a b] -> Fold m a [b]
1556distribute :: Monad m => [Fold m a b] -> Fold m a [b]
1491−distribute = foldr foldCons foldNil
1557+distribute = foldr (teeWith (:)) (yield [])
1492
1558
1493------------------------------------------------------------------------------
1559------------------------------------------------------------------------------
1494-- Partitioning
1560-- Partitioning
@@ -1549,7 +1615,20 @@ partitionByM f (Fold stepL beginL doneL) (Fold stepR beginR doneR) =
1549
1615
1550 where
1616 where
1551
1617
1552− begin = RunBoth <$> beginL <*> beginR
1618+ begin = do
1619+ resL <- beginL
1620+ resR <- beginR
1621+ return
1622+ $ case resL of
1623+ Partial sL ->
1624+ Partial
1625+ $ case resR of
1626+ Partial sR -> RunBoth sL sR
1627+ Done bR -> RunLeft sL bR
1628+ Done bL ->
1629+ case resR of
1630+ Partial sR -> Partial $ RunRight bL sR
1631+ Done bR -> Done (bL, bR)
1553
1632
1554 step (RunBoth sL sR) a = do
1633 step (RunBoth sL sR) a = do
1555 r <- f a
1634 r <- f a
@@ -1707,10 +1786,10 @@ demux :: (Monad m, Ord k)
1707 => Map k (Fold m a b) -> Fold m (k, a) (Map k b)
1786 => Map k (Fold m a b) -> Fold m (k, a) (Map k b)
1708demux = demuxWith id
1787demux = demuxWith id
1709
1788
1710−data DemuxState s b rMap kvMap =
1789+data DemuxState s b doneMap runMap =
1711− DemuxMapWithDefault !s !rMap !kvMap
1790+ DemuxMapAndDefault !s !doneMap !runMap
1712− | DemuxMap b !rMap !kvMap
1791+ | DemuxOnlyMap b !doneMap !runMap
1713− | DemuxDefault s !rMap
1792+ | DemuxOnlyDefault s !doneMap
1714
1793
1715-- | Like 'demuxWith' but uses a default catchall fold to handle inputs which
1794-- | Like 'demuxWith' but uses a default catchall fold to handle inputs which
1716-- do not have a specific fold in the map to handle them.
1795-- do not have a specific fold in the map to handle them.
@@ -1734,87 +1813,102 @@ demuxDefaultWith f kv (Fold dstep dinitial dextract) =
1734
1813
1735 where
1814 where
1736
1815
1737− initial =
1816+ initial = do
1738− DemuxMapWithDefault
1817+ let runInit (Fold step1 initial1 done1) = do
1739− <$> dinitial
1818+ r <- initial1
1740− <*> return Map.empty
1819+ return
1741− <*> Prelude.mapM initialize kv
1820+ $ case r of
1821+ Partial _ -> Right' (Fold step1 (return r) done1)
1822+ Done b -> Left' b
1742
1823
1743− step (DemuxMapWithDefault dacc results kvMap) a =
1824+ -- initialize folds in the kv map and separate the ones that are done
1825+ -- from running ones
1826+ kv1 <- Prelude.mapM runInit kv
1827+ let runMap = Map.map fromRight' $ Map.filter isRight' kv1
1828+ doneMap = Map.map fromLeft' $ Map.filter isLeft' kv1
1829+
1830+ -- Run the default fold, and decide the next state based on its result
1831+ dres <- dinitial
1832+ return
1833+ $ case dres of
1834+ Partial s ->
1835+ Partial
1836+ $ if Map.size runMap > 0
1837+ then DemuxMapAndDefault s doneMap runMap
1838+ else DemuxOnlyDefault s doneMap
1839+ Done b ->
1840+ if Map.size runMap > 0
1841+ then Partial $ DemuxOnlyMap b doneMap runMap
1842+ else Done (doneMap, b)
1843+
1844+ {-# INLINE runFold #-}
1845+ runFold fPartial fDone doneMap runMap (Fold step1 initial1 done1) k a1 = do
1846+ resi <- initial1
1847+ case resi of
1848+ Partial st -> do
1849+ res <- step1 st a1
1850+ return $ case res of
1851+ Partial s ->
1852+ let fld = Fold step1 (return $ Partial s) done1
1853+ runMap1 = Map.insert k fld runMap
1854+ in Partial $ fPartial doneMap runMap1
1855+ Done b -> do
1856+ let runMap1 = Map.delete k runMap
1857+ doneMap1 = Map.insert k b doneMap
1744− if Map.size kvMap > 0
1858+ if Map.size runMap1 == 0
1745− then do
1859+ then fDone doneMap1
1860+ else Partial $ fPartial doneMap1 runMap1
1861+ Done _ -> error "Bug: demuxDefaultWith: Done fold"
1862+
1863+ step (DemuxMapAndDefault dacc doneMap runMap) a = do
1746− let (k, a1) = f a
1864+ let (k, a1) = f a
1747− case Map.lookup k kvMap of
1865+ case Map.lookup k runMap of
1748− Nothing -> do
1866+ Nothing -> do
1749− res <- dstep dacc (k, a1)
1867+ res <- dstep dacc (k, a1)
1750− return
1868+ return
1751− $ Partial
1869+ $ Partial
1752− $ case res of
1870+ $ case res of
1753− Partial s -> DemuxMapWithDefault s results kvMap
1871+ Partial s -> DemuxMapAndDefault s doneMap runMap
1754− Done b -> DemuxMap b results kvMap
1872+ Done b -> DemuxOnlyMap b doneMap runMap
1755− Just (Fold step1 initial1 extract1) -> do
1873+ Just fld ->
1756− !st <- initial1
1874+ runFold
1757− !res <- step1 st a1
1875+ (DemuxMapAndDefault dacc)
1758− return
1759− $ case res of
1760− Partial s ->
1876+ (Partial . DemuxOnlyDefault dacc)
1761− let fld = Fold step1 (return s) extract1
1877+ doneMap runMap fld k a1
1762− kvMap1 = Map.insert k fld kvMap
1878+
1763− in Partial
1879+ step (DemuxOnlyMap dval doneMap runMap) a = do
1764− $ DemuxMapWithDefault
1765− dacc results kvMap1
1766− Done b ->
1767− let kvMap1 = Map.delete k kvMap
1768− results1 = Map.insert k b results
1769− in Partial
1770− $ if Map.size kvMap1 == 0
1771− then DemuxDefault dacc results1
1772− else DemuxMapWithDefault
1773− dacc results1 kvMap1
1774− -- XXX Remove this when we have Step in the initial value
1775− else error "demuxDefaultWith: empty key-value Map"
1776− step (DemuxMap dval results kvMap) a =
1777− if Map.size kvMap > 0
1778− then do
1779− let (k, a1) = f a
1880+ let (k, a1) = f a
1780− case Map.lookup k kvMap of
1881+ case Map.lookup k runMap of
1781− Nothing -> return $ Partial $ DemuxMap dval results kvMap
1882+ Nothing -> return $ Partial $ DemuxOnlyMap dval doneMap runMap
1782− Just (Fold step1 initial1 extract1) -> do
1883+ Just fld ->
1783− !st <- initial1
1884+ runFold
1784− !res <- step1 st a1
1885+ (DemuxOnlyMap dval)
1785− return
1786− $ case res of
1787− Partial s ->
1788− let fld = Fold step1 (return s) extract1
1789− kvMap1 = Map.insert k fld kvMap
1790− in Partial $ DemuxMap dval results kvMap1
1791− Done b ->
1886+ (Done . (, dval))
1792− let kvMap1 = Map.delete k kvMap
1887+ doneMap runMap fld k a1
1793− results1 = Map.insert k b results
1888+ step (DemuxOnlyDefault dacc doneMap) a = do
1794− in if Map.size kvMap1 == 0
1795− then Done (results1, dval)
1796− else Partial
1797− $ DemuxMap dval results1 kvMap1
1798− -- XXX Remove this when we have Step in the initial value
1799− else error "demuxDefaultWith: empty key-value Map"
1800− step (DemuxDefault dacc results) a = do
1801 let (k, a1) = f a
1889 let (k, a1) = f a
1802 res <- dstep dacc (k, a1)
1890 res <- dstep dacc (k, a1)
1803 return
1891 return
1804 $ case res of
1892 $ case res of
1805− Partial s -> Partial $ DemuxDefault s results
1893+ Partial s -> Partial $ DemuxOnlyDefault s doneMap
1806− Done b -> Done (results, b)
1894+ Done b -> Done (doneMap, b)
1807
1895
1808− extract (DemuxMapWithDefault dacc results kvMap) = do
1896+ runExtract (Fold _ initial1 done1) = do
1897+ res <- initial1
1898+ case res of
1899+ Partial s -> done1 s
1900+ Done b -> return b
1901+
1902+ extract (DemuxMapAndDefault dacc doneMap runMap) = do
1809 b <- dextract dacc
1903 b <- dextract dacc
1810− kvMap1 <- Prelude.mapM (\(Fold _ i d) -> i >>= d) kvMap
1904+ runMap1 <- Prelude.mapM runExtract runMap
1811− return (results `Map.union` kvMap1, b)
1905+ return (doneMap `Map.union` runMap1, b)
1812− extract (DemuxMap dval results kvMap) = do
1906+ extract (DemuxOnlyMap dval doneMap runMap) = do
1813− kvMap1 <- Prelude.mapM (\(Fold _ i d) -> i >>= d) kvMap
1907+ runMap1 <- Prelude.mapM runExtract runMap
1814− return (results `Map.union` kvMap1, dval)
1908+ return (doneMap `Map.union` runMap1, dval)
1815− extract (DemuxDefault dacc results) = do
1909+ extract (DemuxOnlyDefault dacc doneMap) = do
1816 b <- dextract dacc
1910 b <- dextract dacc
1817− return (results, b)
1911+ return (doneMap, b)
1818
1912
1819{-# INLINE demuxDefault #-}
1913{-# INLINE demuxDefault #-}
1820demuxDefault :: (Monad m, Ord k)
1914demuxDefault :: (Monad m, Ord k)
@@ -1844,43 +1938,44 @@ demuxDefault = demuxDefaultWith id
1844--
1938--
1845{-# INLINE classifyWith #-}
1939{-# INLINE classifyWith #-}
1846classifyWith :: (Monad m, Ord k) => (a -> k) -> Fold m a b -> Fold m a (Map k b)
1940classifyWith :: (Monad m, Ord k) => (a -> k) -> Fold m a b -> Fold m a (Map k b)
1847−classifyWith f (Fold step initial extract) = Fold step' initial' extract'
1941+classifyWith f (Fold step1 initial1 extract1) = mkAccumM step initial extract
1848
1942
1849 where
1943 where
1850
1944
1851− initial' = return Map.empty
1945+ initial = return Map.empty
1852
1946
1853− step' kv a =
1947+ step kv a =
1854 case Map.lookup k kv of
1948 case Map.lookup k kv of
1855 Nothing -> do
1949 Nothing -> do
1856− x <- initial
1950+ x <- initial1
1857− r <- step x a
1951+ case x of
1952+ Partial s -> do
1953+ r <- step1 s a
1858− return
1954+ return
1859− $ Partial
1860− $ flip (Map.insert k) kv
1955+ $ flip (Map.insert k) kv
1861− $ case r of
1956+ $ case r of
1862− Partial sr -> Left' sr
1957+ Partial s1 -> Left' s1
1863− Done br -> Right' br
1958+ Done b -> Right' b
1959+ Done b -> return $ Map.insert k (Right' b) kv
1864 Just x -> do
1960 Just x -> do
1865 case x of
1961 case x of
1866 Left' s -> do
1962 Left' s -> do
1867− r <- step s a
1963+ r <- step1 s a
1868 return
1964 return
1869− $ Partial
1870 $ flip (Map.insert k) kv
1965 $ flip (Map.insert k) kv
1871 $ case r of
1966 $ case r of
1872− Partial sr -> Left' sr
1967+ Partial s1 -> Left' s1
1873− Done br -> Right' br
1968+ Done b -> Right' b
1874− Right' _ -> return $ Partial kv
1969+ Right' _ -> return kv
1875
1970
1876 where
1971 where
1877
1972
1878 k = f a
1973 k = f a
1879
1974
1880− extract' =
1975+ extract =
1881 Prelude.mapM
1976 Prelude.mapM
1882 (\case
1977 (\case
1883− Left' s -> extract s
1978+ Left' s -> extract1 s
1884 Right' b -> return b)
1979 Right' b -> return b)
1885
1980
1886-- | Given an input stream of key value pairs and a fold for values, fold all
1981-- | Given an input stream of key value pairs and a fold for values, fold all
@@ -1920,7 +2015,20 @@ unzipWithM f (Fold stepL beginL doneL) (Fold stepR beginR doneR) =
1920
2015
1921 where
2016 where
1922
2017
1923− begin = RunBoth <$> beginL <*> beginR
2018+ begin = do
2019+ resL <- beginL
2020+ resR <- beginR
2021+ return
2022+ $ case resL of
2023+ Partial sL ->
2024+ Partial
2025+ $ case resR of
2026+ Partial sR -> RunBoth sL sR
2027+ Done bR -> RunLeft sL bR
2028+ Done bL ->
2029+ case resR of
2030+ Partial sR -> Partial $ RunRight bL sR
2031+ Done bR -> Done (bL, bR)
1924
2032
1925 step (RunBoth sL sR) a = do
2033 step (RunBoth sL sR) a = do
1926 (b, c) <- f a
2034 (b, c) <- f a
@@ -2048,7 +2156,7 @@ toParallelSVar svar winfo = Fold step initial extract
2048
2156
2049 where
2157 where
2050
2158
2051− initial = return ()
2159+ initial = return $ Partial ()
2052
2160
2053 -- XXX we can have a separate fold for unlimited buffer case to avoid a
2161 -- XXX we can have a separate fold for unlimited buffer case to avoid a
2054 -- branch in the step here.
2162 -- branch in the step here.
@@ -2067,7 +2175,7 @@ toParallelSVarLimited svar winfo = Fold step initial extract
2067
2175
2068 where
2176 where
2069
2177
2070− initial = return True
2178+ initial = return $ Partial True
2071
2179
2072 step True x =
2180 step True x =
2073 liftIO $ do
2181 liftIO $ do
src/Streamly/Internal/Data/Fold/Types.hs+141−110
@@ -173,8 +173,6 @@ module Streamly.Internal.Data.Fold.Types
173
173
174 , Fold2 (..)
174 , Fold2 (..)
175 , simplify
175 , simplify
176− , toListRevF -- experimental
177− -- $toListRevF
178
176
179 -- * Generators
177 -- * Generators
180 , yield
178 , yield
@@ -295,7 +293,7 @@ instance Functor (Step s) where
295
293
296data Fold m a b =
294data Fold m a b =
297 -- | @Fold @ @ step @ @ initial @ @ extract@
295 -- | @Fold @ @ step @ @ initial @ @ extract@
298− forall s. Fold (s -> a -> m (Step s b)) (m s) (s -> m b)
296+ forall s. Fold (s -> a -> m (Step s b)) (m (Step s b)) (s -> m b)
299
297
300-- | Experimental type to provide a side input to the fold for generating the
298-- | Experimental type to provide a side input to the fold for generating the
301-- initial state. For example, if we have to fold chunks of a stream and write
299-- initial state. For example, if we have to fold chunks of a stream and write
@@ -309,15 +307,16 @@ data Fold2 m c a b =
309-- | Convert more general type 'Fold2' into a simpler type 'Fold'
307-- | Convert more general type 'Fold2' into a simpler type 'Fold'
310simplify :: Functor m => Fold2 m c a b -> c -> Fold m a b
308simplify :: Functor m => Fold2 m c a b -> c -> Fold m a b
311simplify (Fold2 step inject extract) c =
309simplify (Fold2 step inject extract) c =
312− Fold (\x a -> Partial <$> step x a) (inject c) extract
310+ Fold (\x a -> Partial <$> step x a) (Partial <$> inject c) extract
313
311
314-- | Maps a function on the output of the fold (the type @b@).
312-- | Maps a function on the output of the fold (the type @b@).
315instance Functor m => Functor (Fold m a) where
313instance Functor m => Functor (Fold m a) where
316 {-# INLINE fmap #-}
314 {-# INLINE fmap #-}
317− fmap f (Fold step1 initial extract) = Fold step initial (fmap2 f extract)
315+ fmap f (Fold step1 initial1 extract) = Fold step initial (fmap2 f extract)
318
316
319 where
317 where
320
318
319+ initial = fmap2 f initial1
321 step s b = fmap2 f (step1 s b)
320 step s b = fmap2 f (step1 s b)
322 fmap2 g = fmap (fmap g)
321 fmap2 g = fmap (fmap g)
323
322
@@ -328,9 +327,8 @@ instance Functor m => Functor (Fold m a) where
328-- /Unimplemented/
327-- /Unimplemented/
329--
328--
330{-# INLINE yield #-}
329{-# INLINE yield #-}
331−yield :: -- Monad m =>
332− b -> Fold m a b
330+yield :: Applicative m => b -> Fold m a b
333−yield = undefined
331+yield b = Fold undefined (pure $ Done b) pure
334
332
335-- This is the dual of stream "yieldM".
333-- This is the dual of stream "yieldM".
336--
334--
@@ -340,12 +338,11 @@ yield = undefined
340-- /Unimplemented/
338-- /Unimplemented/
341--
339--
342{-# INLINE yieldM #-}
340{-# INLINE yieldM #-}
343−yieldM :: -- Monad m =>
344− m b -> Fold m a b
341+yieldM :: Applicative m => m b -> Fold m a b
345−yieldM = undefined
342+yieldM b = Fold undefined (Done <$> b) pure
346
343
347{-# ANN type Step Fuse #-}
344{-# ANN type Step Fuse #-}
348−data SeqFoldState sl f sr = SeqFoldL sl | SeqFoldR f sr
345+data SeqFoldState sl f sr = SeqFoldL !sl | SeqFoldR !f !sr
349
346
350-- | Sequential fold application. Apply two folds sequentially to an input
347-- | Sequential fold application. Apply two folds sequentially to an input
351-- stream. The input is provided to the first fold, when it is done the
348-- stream. The input is provided to the first fold, when it is done the
@@ -366,13 +363,21 @@ splitWith func (Fold stepL initialL extractL) (Fold stepR initialR extractR) =
366
363
367 where
364 where
368
365
366+ initial = do
369− initial = SeqFoldL <$> initialL
367+ resL <- initialL
368+ case resL of
369+ Partial sl -> return $ Partial $ SeqFoldL sl
370+ Done bl -> do
371+ resR <- initialR
372+ return $ bimap (SeqFoldR (func bl)) (func bl) resR
370
373
371 step (SeqFoldL st) a = do
374 step (SeqFoldL st) a = do
372 r <- stepL st a
375 r <- stepL st a
373 case r of
376 case r of
374 Partial s -> return $ Partial (SeqFoldL s)
377 Partial s -> return $ Partial (SeqFoldL s)
375− Done b -> Partial <$> (SeqFoldR (func b) <$> initialR)
378+ Done b -> do
379+ res <- initialR
380+ return $ bimap (SeqFoldR (func b)) (func b) res
376 step (SeqFoldR f st) a = do
381 step (SeqFoldR f st) a = do
377 r <- stepR st a
382 r <- stepR st a
378 return
383 return
@@ -383,9 +388,12 @@ splitWith func (Fold stepL initialL extractL) (Fold stepR initialR extractR) =
383 extract (SeqFoldR f sR) = fmap f (extractR sR)
388 extract (SeqFoldR f sR) = fmap f (extractR sR)
384 extract (SeqFoldL sL) = do
389 extract (SeqFoldL sL) = do
385 rL <- extractL sL
390 rL <- extractL sL
386− sR <- initialR
391+ res <- initialR
392+ case res of
393+ Partial sR -> do
387− rR <- extractR sR
394+ rR <- extractR sR
395+ return $ func rL rR
388− return $ func rL rR
396+ Done rR -> return $ func rL rR
389
397
390-- | Same as applicative '*>'. Run two folds serially one after the other
398-- | Same as applicative '*>'. Run two folds serially one after the other
391-- discarding the result of the first.
399-- discarding the result of the first.
@@ -407,7 +415,7 @@ data GenericRunner sL sR bL bR
407-- folds and combines their output using the supplied function.
415-- folds and combines their output using the supplied function.
408instance Monad m => Applicative (Fold m a) where
416instance Monad m => Applicative (Fold m a) where
409 {-# INLINE pure #-}
417 {-# INLINE pure #-}
410− pure b = Fold (\() _ -> pure $ Done b) (pure ()) (\() -> pure b)
418+ pure = yield
411
419
412 {-# INLINE (<*>) #-}
420 {-# INLINE (<*>) #-}
413 (<*>) = teeWith ($)
421 (<*>) = teeWith ($)
@@ -425,9 +433,16 @@ teeWith f (Fold stepL beginL doneL) (Fold stepR beginR doneR) =
425 where
433 where
426
434
427 begin = do
435 begin = do
428− sL <- beginL
436+ resL <- beginL
429− sR <- beginR
437+ resR <- beginR
430− return $ RunBoth sL sR
438+ return
439+ $ case resL of
440+ Partial sl ->
441+ Partial
442+ $ case resR of
443+ Partial sr -> RunBoth sl sr
444+ Done br -> RunLeft sl br
445+ Done bl -> bimap (RunRight bl) (f bl) resR
431
446
432 step (RunBoth sL sR) a = do
447 step (RunBoth sL sR) a = do
433 resL <- stepL sL a
448 resL <- stepL sL a
@@ -629,22 +644,6 @@ instance (Monad m, Floating b) => Floating (Fold m a b) where
629-- Internal APIs
644-- Internal APIs
630------------------------------------------------------------------------------
645------------------------------------------------------------------------------
631
646
632−-- $toListRevF
633−-- This is more efficient than 'Streamly.Internal.Data.Fold.toList'. toList is
634−-- exactly the same as reversing the list after 'toListRevF'.
635−
636−-- | Buffers the input stream to a list in the reverse order of the input.
637−--
638−-- /Warning!/ working on large lists accumulated as buffers in memory could be
639−-- very inefficient, consider using "Streamly.Array" instead.
640−--
641−-- @since 0.7.0
642−
643−-- xn : ... : x2 : x1 : []
644−{-# INLINABLE toListRevF #-}
645−toListRevF :: Monad m => Fold m a [a]
646−toListRevF = Fold (\xs x -> return $ Partial $ x:xs) (return []) return
647−
648-- | @(lmap f fold)@ maps the function @f@ on the input of the fold.
647-- | @(lmap f fold)@ maps the function @f@ on the input of the fold.
649--
648--
650-- >>> S.fold (FL.lmap (\x -> x * x) FL.sum) (S.enumerateFromTo 1 100)
649-- >>> S.fold (FL.lmap (\x -> x * x) FL.sum) (S.enumerateFromTo 1 100)
@@ -720,30 +719,35 @@ ltake n (Fold fstep finitial fextract) = Fold step initial extract
720
719
721 where
720 where
722
721
722+ initial = do
723− initial = Tuple' 0 <$> finitial
723+ res <- finitial
724−
724+ case res of
725+ Partial s ->
726+ if n > 0
727+ then return $ Partial $ Tuple' 0 s
728+ else Done <$> fextract s
729+ Done b -> return $ Done b
730+
725− step (Tuple' i r) a
731+ step (Tuple' i r) a = do
726− | i < n = do
727− res <- fstep r a
732+ res <- fstep r a
728− case res of
733+ case res of
729− Partial sres -> do
734+ Partial sres -> do
730− let i1 = i + 1
735+ let i1 = i + 1
731− s1 = Tuple' i1 sres
736+ s1 = Tuple' i1 sres
732− if i1 < n
737+ if i1 < n
733− then return $ Partial s1
738+ then return $ Partial s1
734− else Done <$> fextract sres
739+ else Done <$> fextract sres
735− Done bres -> return $ Done bres
740+ Done bres -> return $ Done bres
736− -- XXX take 0 case is broken currently
737− | otherwise = Done <$> fextract r
738
741
739 extract (Tuple' _ r) = fextract r
742 extract (Tuple' _ r) = fextract r
740
743
741------------------------------------------------------------------------------
744------------------------------------------------------------------------------
742-- Nesting
745-- Nesting
743------------------------------------------------------------------------------
746------------------------------------------------------------------------------
744−--
747+
745−-- | Modify the fold such that when the fold is done, instead of returning the
748+-- | Modify the fold such that it returns a new 'Fold' instead of the output.
749+-- If the fold was already done the returned fold would always yield the
746−-- accumulator, it returns a fold. The returned fold starts from where we left
750+-- result. If the fold was partial, the returned fold starts from where we left
747-- i.e. it uses the last accumulator value as the initial value of the
751-- i.e. it uses the last accumulator value as the initial value of the
748-- accumulator. Thus we can resume the fold later and feed it more input.
752-- accumulator. Thus we can resume the fold later and feed it more input.
749--
753--
@@ -755,11 +759,15 @@ ltake n (Fold fstep finitial fextract) = Fold step initial extract
755--
759--
756-- @since 0.7.0
760-- @since 0.7.0
757{-# INLINABLE duplicate #-}
761{-# INLINABLE duplicate #-}
758−duplicate ::
759− -- Monad m =>
760− Fold m a b -> Fold m a (Fold m a b)
762+duplicate :: Monad m => Fold m a b -> Fold m a (Fold m a b)
761−-- XXX This should change once we have step type in the initial element
763+duplicate (Fold step1 initial1 extract1) =
762−duplicate _ = undefined
764+ Fold step initial (\s -> pure $ Fold step1 (pure $ Partial s) extract1)
765+
766+ where
767+
768+ initial = second yield <$> initial1
769+
770+ step s a = second yield <$> step1 s a
763
771
764-- | Run the initialization effect of a fold. The returned fold would use the
772-- | Run the initialization effect of a fold. The returned fold would use the
765-- value returned by this effect as its initial value.
773-- value returned by this effect as its initial value.
@@ -773,11 +781,16 @@ initialize (Fold step initial extract) = do
773-- | Run one step of a fold and store the accumulator as an initial value in
781-- | Run one step of a fold and store the accumulator as an initial value in
774-- the returned fold.
782-- the returned fold.
775{-# INLINABLE runStep #-}
783{-# INLINABLE runStep #-}
776−runStep ::
777− -- Monad m =>
778− Fold m a b -> a -> m (Fold m a b)
784+runStep :: Monad m => Fold m a b -> a -> m (Fold m a b)
779−-- XXX This should change once we have step type in the initial element
785+runStep (Fold step initial extract) a = return $ Fold step initial1 extract
780−runStep _ _ = undefined
786+
787+ where
788+
789+ initial1 = do
790+ res <- initial
791+ case res of
792+ Partial fs -> step fs a
793+ b@(Done _) -> return b
781
794
782------------------------------------------------------------------------------
795------------------------------------------------------------------------------
783-- Parsing
796-- Parsing
@@ -799,32 +812,51 @@ runStep _ _ = undefined
799--
812--
800{-# INLINE many #-}
813{-# INLINE many #-}
801many :: Monad m => Fold m b c -> Fold m a b -> Fold m a c
814many :: Monad m => Fold m b c -> Fold m a b -> Fold m a c
802−many (Fold fstep finitial fextract) (Fold step1 initial1 extract1) =
815+many (Fold cstep cinitial cextract) (Fold sstep sinitial sextract) =
803 Fold step initial extract
816 Fold step initial extract
804
817
805 where
818 where
806
819
807− initial = Tuple' <$> initial1 <*> finitial
820+ -- cs = collect state
821+ -- ss = split state
822+ -- cres = collect state result
823+ -- sres = split state result
824+ -- cb = collect done
825+ -- sb = split done
826+
827+ -- Caution! There is mutual recursion here, inlining the right functions is
828+ -- important.
829+
830+ {-# INLINE handleSplitStep #-}
831+ handleSplitStep cs sres =
832+ case sres of
833+ Partial ss1 -> return $ Partial $ Tuple' ss1 cs
834+ Done sb -> runCollector cs sb
835+
836+ {-# INLINE handleCollectStep #-}
837+ handleCollectStep cres =
838+ case cres of
839+ Partial cs -> do
840+ sres <- sinitial
841+ handleSplitStep cs sres
842+ Done cb -> return $ Done cb
843+
844+ -- Do not inline this
845+ runCollector cs sb = cstep cs sb >>= handleCollectStep
846+
847+ initial = cinitial >>= handleCollectStep
808
848
809 {-# INLINE step #-}
849 {-# INLINE step #-}
810− step (Tuple' st fs) a = do
850+ step (Tuple' ss cs) a = do
811− r <- step1 st a
851+ sres <- sstep ss a
812− case r of
852+ handleSplitStep cs sres
813− Partial s -> return $ Partial (Tuple' s fs)
814− Done b -> do
815− s <- initial1
816− fs1 <- fstep fs b
817− return
818− $ case fs1 of
819− Partial s1 -> Partial (Tuple' s s1)
820− Done b1 -> Done b1
821
853
822− extract (Tuple' s fs) = do
854+ extract (Tuple' ss cs) = do
823− b <- extract1 s
855+ sb <- sextract ss
824− acc <- fstep fs b
856+ cres <- cstep cs sb
825− case acc of
857+ case cres of
826− Partial s1 -> fextract s1
858+ Partial s -> cextract s
827− Done x -> return x
859+ Done b -> return b
828
860
829-- | @lchunksOf n split collect@ repeatedly applies the @split@ fold to chunks
861-- | @lchunksOf n split collect@ repeatedly applies the @split@ fold to chunks
830-- of @n@ items in the input stream and supplies the result to the @collect@
862-- of @n@ items in the input stream and supplies the result to the @collect@
@@ -847,7 +879,13 @@ lchunksOf2 n (Fold step1 initial1 extract1) (Fold2 step2 inject2 extract2) =
847
879
848 where
880 where
849
881
850− inject' x = Tuple3' 0 <$> initial1 <*> inject2 x
882+ loopUntilPartial s = do
883+ res <- initial1
884+ case res of
885+ Partial fs -> return $ Tuple3' 0 fs s
886+ Done _ -> loopUntilPartial s
887+
888+ inject' x = inject2 x >>= loopUntilPartial
851
889
852 step' (Tuple3' i r1 r2) a =
890 step' (Tuple3' i r1 r2) a =
853 if i < n
891 if i < n
@@ -855,20 +893,10 @@ lchunksOf2 n (Fold step1 initial1 extract1) (Fold2 step2 inject2 extract2) =
855 res <- step1 r1 a
893 res <- step1 r1 a
856 case res of
894 case res of
857 Partial s -> return $ Tuple3' (i + 1) s r2
895 Partial s -> return $ Tuple3' (i + 1) s r2
858− Done b -> do
859− s <- initial1
860− r21 <- step2 r2 b
896+ Done b -> step2 r2 b >>= loopUntilPartial
861− return $ Tuple3' 0 s r21
862− else do
863− res <- extract1 r1
897+ else extract1 r1 >>= step2 r2 >>= loopUntilPartial
864− acc2 <- step2 r2 res
865− i1 <- initial1
866− return $ Tuple3' 0 i1 acc2
867
898
868− extract' (Tuple3' _ r1 r2) = do
899+ extract' (Tuple3' _ r1 r2) = extract1 r1 >>= step2 r2 >>= extract2
869− res <- extract1 r1
870− acc2 <- step2 r2 res
871− extract2 acc2
872
900
873-- | @takeByTime n fold@ uses @fold@ to fold the input items arriving within a
901-- | @takeByTime n fold@ uses @fold@ to fold the input items arriving within a
874-- window of first @n@ seconds.
902-- window of first @n@ seconds.
@@ -884,18 +912,21 @@ takeByTime n (Fold step initial done) = Fold step' initial' done'
884 where
912 where
885
913
886 initial' = do
914 initial' = do
887− s <- initial
915+ res <- initial
916+ case res of
917+ Partial s -> do
888− mv <- liftIO $ newMVar False
918+ mv <- liftIO $ newMVar False
889− t <-
919+ t <-
890− control $ \run ->
920+ control $ \run ->
891− mask $ \restore -> do
921+ mask $ \restore -> do
892− tid <-
922+ tid <-
893− forkIO
923+ forkIO
894− $ catch
924+ $ catch
895− (restore $ void $ run (timerThread mv))
925+ (restore $ void $ run (timerThread mv))
896− (handleChildException mv)
926+ (handleChildException mv)
897− run (return tid)
927+ run (return tid)
898− return $ Tuple3' s mv t
928+ return $ Partial $ Tuple3' s mv t
929+ Done b -> return $ Done b
899
930
900 step' (Tuple3' s mv t) a = do
931 step' (Tuple3' s mv t) a = do
901 val <- liftIO $ readMVar mv
932 val <- liftIO $ readMVar mv
src/Streamly/Internal/Data/Maybe/Strict.hs+15
@@ -20,6 +20,8 @@
20module Streamly.Internal.Data.Maybe.Strict
20module Streamly.Internal.Data.Maybe.Strict
21 ( Maybe' (..)
21 ( Maybe' (..)
22 , toMaybe
22 , toMaybe
23+ , isJust'
24+ , fromJust'
23 )
25 )
24where
26where
25
27
@@ -31,3 +33,16 @@ data Maybe' a = Just' !a | Nothing' deriving Show
31toMaybe :: Maybe' a -> Maybe a
33toMaybe :: Maybe' a -> Maybe a
32toMaybe Nothing' = Nothing
34toMaybe Nothing' = Nothing
33toMaybe (Just' a) = Just a
35toMaybe (Just' a) = Just a
36+
37+-- | Extract the element out of a Just' and throws an error if its argument is
38+-- Nothing'.
39+{-# INLINABLE fromJust' #-}
40+fromJust' :: Maybe' a -> a
41+fromJust' (Just' a) = a
42+fromJust' Nothing' = error "fromJust' cannot be run in Nothing'"
43+
44+-- | Returns True iff its argument is of the form "Just' _".
45+{-# INLINABLE isJust' #-}
46+isJust' :: Maybe' a -> Bool
47+isJust' (Just' _) = True
48+isJust' Nothing' = False
src/Streamly/Internal/Data/Parser/ParserD.hs+78−36
@@ -175,16 +175,20 @@ import Streamly.Internal.Data.Parser.ParserD.Types
175--
175--
176{-# INLINE fromFold #-}
176{-# INLINE fromFold #-}
177fromFold :: Monad m => Fold m a b -> Parser m a b
177fromFold :: Monad m => Fold m a b -> Parser m a b
178−fromFold (Fold fstep finitial fextract) = Parser step finitial fextract
178+fromFold (Fold fstep finitial fextract) = Parser step finitial extract
179
179
180 where
180 where
181
181
182− step s a = do
182+ step (FL.Partial s) a = do
183 res <- fstep s a
183 res <- fstep s a
184 return
184 return
185 $ case res of
185 $ case res of
186− FL.Partial s1 -> Partial 0 s1
186+ FL.Partial s1 -> Partial 0 (FL.Partial s1)
187 FL.Done b -> Done 0 b
187 FL.Done b -> Done 0 b
188+ step (FL.Done b) _ = return $ Done 1 b
189+
190+ extract (FL.Partial s) = fextract s
191+ extract (FL.Done b) = return b
188
192
189-------------------------------------------------------------------------------
193-------------------------------------------------------------------------------
190-- Failing Parsers
194-- Failing Parsers
@@ -293,7 +297,12 @@ takeBetween low high (Fold fstep finitial fextract) =
293
297
294 where
298 where
295
299
296− initial = Tuple' 0 <$> finitial
300+ initial = do
301+ res <- finitial
302+ case res of
303+ FL.Partial s -> return $ Tuple' 0 s
304+ FL.Done _ ->
305+ error "takeBetween: Done/Error in initial not implemented yet."
297
306
298 step (Tuple' i s) a
307 step (Tuple' i s) a
299 | low > high =
308 | low > high =
@@ -341,25 +350,30 @@ takeBetween low high (Fold fstep finitial fextract) =
341--
350--
342{-# INLINE takeEQ #-}
351{-# INLINE takeEQ #-}
343takeEQ :: MonadThrow m => Int -> Fold m a b -> Parser m a b
352takeEQ :: MonadThrow m => Int -> Fold m a b -> Parser m a b
344−takeEQ cnt (Fold fstep finitial fextract) = Parser step initial extract
353+takeEQ n (Fold fstep finitial fextract) = Parser step initial extract
345
354
346 where
355 where
347
356
348− n = max cnt 0
357+ cnt = max n 0
349
358
350− initial = Tuple' 0 <$> finitial
359+ initial = do
360+ res <- finitial
361+ case res of
362+ FL.Partial s -> return $ Tuple' 0 s
363+ FL.Done _ ->
364+ error "takeEQ: Done/Error in initial not implemented yet."
351
365
352 step (Tuple' i r) a
366 step (Tuple' i r) a
353− | i1 < n = do
367+ | i1 < cnt = do
354 res <- fstep r a
368 res <- fstep r a
355 return
369 return
356 $ case res of
370 $ case res of
357 FL.Partial s -> Continue 0 $ Tuple' i1 s
371 FL.Partial s -> Continue 0 $ Tuple' i1 s
358 FL.Done _ ->
372 FL.Done _ ->
359 Error
373 Error
374+ $ "takeEQ: Expecting exactly " ++ show cnt
360− $ "takeEQ: the collecting fold terminated after "
375+ ++ " elements, fold terminated on " ++ show i1
361− ++ "consuming" ++ show i1 ++ " elements"
362− | i1 == n = do
376+ | i1 == cnt = do
363 res <- fstep r a
377 res <- fstep r a
364 Done 0
378 Done 0
365 <$> case res of
379 <$> case res of
@@ -374,12 +388,12 @@ takeEQ cnt (Fold fstep finitial fextract) = Parser step initial extract
374 i1 = i + 1
388 i1 = i + 1
375
389
376 extract (Tuple' i r)
390 extract (Tuple' i r)
377− | i == 0 && n == 0 = fextract r
391+ | i == 0 && cnt == 0 = fextract r
378 | otherwise =
392 | otherwise =
379 throwM
393 throwM
380 $ ParseError
394 $ ParseError
381− $ "takeEQ: Expecting exactly "
395+ $ "takeEQ: Expecting exactly " ++ show cnt
382− ++ show n ++ " elements, got " ++ show i
396+ ++ " elements, input terminated on " ++ show i
383
397
384-- | See 'Streamly.Internal.Data.Parser.takeGE'.
398-- | See 'Streamly.Internal.Data.Parser.takeGE'.
385--
399--
@@ -387,23 +401,28 @@ takeEQ cnt (Fold fstep finitial fextract) = Parser step initial extract
387--
401--
388{-# INLINE takeGE #-}
402{-# INLINE takeGE #-}
389takeGE :: MonadThrow m => Int -> Fold m a b -> Parser m a b
403takeGE :: MonadThrow m => Int -> Fold m a b -> Parser m a b
390−takeGE cnt (Fold fstep finitial fextract) = Parser step initial extract
404+takeGE n (Fold fstep finitial fextract) = Parser step initial extract
391
405
392 where
406 where
393
407
394− n = max cnt 0
408+ cnt = max n 0
395− initial = Tuple' 0 <$> finitial
409+ initial = do
410+ res <- finitial
411+ case res of
412+ FL.Partial s -> return $ Tuple' 0 s
413+ FL.Done _ ->
414+ error "takeGE: Done/Error in initial not implemented yet."
396
415
397 step (Tuple' i r) a
416 step (Tuple' i r) a
398− | i1 < n = do
417+ | i1 < cnt = do
399 res <- fstep r a
418 res <- fstep r a
400 return
419 return
401 $ case res of
420 $ case res of
402 FL.Partial s -> Continue 0 $ Tuple' i1 s
421 FL.Partial s -> Continue 0 $ Tuple' i1 s
403 FL.Done _ ->
422 FL.Done _ ->
404 Error
423 Error
405− $ "takeGE: the collecting fold terminated after "
424+ $ "takeGE: Expecting at least " ++ show cnt
406− ++ "consuming " ++ show i1 ++ " elements"
425+ ++ " elements, fold terminated on " ++ show i1
407 | otherwise = do
426 | otherwise = do
408 res <- fstep r a
427 res <- fstep r a
409 return
428 return
@@ -416,12 +435,12 @@ takeGE cnt (Fold fstep finitial fextract) = Parser step initial extract
416 i1 = i + 1
435 i1 = i + 1
417
436
418 extract (Tuple' i r)
437 extract (Tuple' i r)
419− | i >= n = fextract r
438+ | i >= cnt = fextract r
420 | otherwise =
439 | otherwise =
421 throwM
440 throwM
422 $ ParseError
441 $ ParseError
423− $ "takeGE: Expecting at least "
442+ $ "takeGE: Expecting at least " ++ show cnt
424− ++ show n ++ " elements, got " ++ show i
443+ ++ " elements, input terminated on " ++ show i
425
444
426-- | See 'Streamly.Internal.Data.Parser.takeWhile'.
445-- | See 'Streamly.Internal.Data.Parser.takeWhile'.
427--
446--
@@ -434,7 +453,12 @@ takeWhile predicate (Fold fstep finitial fextract) =
434
453
435 where
454 where
436
455
456+ initial = do
437− initial = finitial
457+ res <- finitial
458+ case res of
459+ FL.Partial s -> return s
460+ FL.Done _ ->
461+ error "takeWhile: Done/Error in initial not implemented yet."
438
462
439 step s a =
463 step s a =
440 if predicate a
464 if predicate a
@@ -460,15 +484,19 @@ takeWhile1 predicate (Fold fstep finitial fextract) =
460 initial = return Nothing
484 initial = return Nothing
461
485
462 step Nothing a =
486 step Nothing a =
487+ let err = Error "takeWhile1: predicate failed on first element"
463− if predicate a
488+ in if predicate a
464− then do
489+ then do
465− s <- finitial
490+ res <- finitial
491+ case res of
492+ FL.Partial s -> do
466− sr <- fstep s a
493+ sr <- fstep s a
467− return
494+ return
468− $ case sr of
495+ $ case sr of
469− FL.Partial r -> Partial 0 (Just r)
496+ FL.Partial s1 -> Partial 0 (Just s1)
470− FL.Done b -> Done 0 b
497+ FL.Done b -> Done 0 b
471− else return $ Error "takeWhile1: predicate failed on first element"
498+ FL.Done _ -> return err
499+ else return err
472 step (Just s) a =
500 step (Just s) a =
473 if predicate a
501 if predicate a
474 then do
502 then do
@@ -533,7 +561,12 @@ wordBy predicate (Fold fstep finitial fextract) = Parser step initial extract
533 FL.Partial s1 -> Partial 0 $ WBWord s1
561 FL.Partial s1 -> Partial 0 $ WBWord s1
534 FL.Done b -> Done 0 b
562 FL.Done b -> Done 0 b
535
563
564+ initial = do
536− initial = WBLeft <$> finitial
565+ res <- finitial
566+ return
567+ $ case res of
568+ FL.Partial s -> WBLeft s
569+ FL.Done _ -> error "wordBy: Done in initial not implemented"
537
570
538 step (WBLeft s) a =
571 step (WBLeft s) a =
539 if not (predicate a)
572 if not (predicate a)
@@ -575,7 +608,12 @@ groupBy cmp (Fold fstep finitial fextract) = Parser step initial extract
575 FL.Done b -> Done 0 b
608 FL.Done b -> Done 0 b
576 FL.Partial s1 -> Partial 0 (GroupByGrouping a0 s1)
609 FL.Partial s1 -> Partial 0 (GroupByGrouping a0 s1)
577
610
611+ initial = do
578− initial = GroupByInit <$> finitial
612+ res <- finitial
613+ return
614+ $ case res of
615+ FL.Partial s -> GroupByInit s
616+ FL.Done _ -> error "groupBy: Done in initial not implemented"
579
617
580 step (GroupByInit s) a = grouper s a a
618 step (GroupByInit s) a = grouper s a a
581 step (GroupByGrouping a0 s) a =
619 step (GroupByGrouping a0 s) a =
@@ -763,7 +801,11 @@ manyTill (Fold fstep finitial fextract)
763
801
764 where
802 where
765
803
804+ initial = do
805+ res <- finitial
806+ case res of
766− initial = ManyTillR 0 <$> finitial <*> initialR
807+ FL.Partial fs -> ManyTillR 0 fs <$> initialR
808+ FL.Done _ -> error "manyTill: Done in initial not implemented"
767
809
768 step (ManyTillR cnt fs st) a = do
810 step (ManyTillR cnt fs st) a = do
769 r <- stepR st a
811 r <- stepR st a
src/Streamly/Internal/Data/Parser/ParserD/Types.hs+12−4
@@ -443,8 +443,12 @@ splitMany (Fold fstep finitial fextract) (Parser step1 initial1 extract1) =
443
443
444 initial = do
444 initial = do
445 ps <- initial1 -- parse state
445 ps <- initial1 -- parse state
446− fs <- finitial -- fold state
446+ res <- finitial -- fold state
447+ return
448+ $ case res of
447− pure (Tuple3' ps (0 :: Int) fs)
449+ FL.Partial fs -> Tuple3' ps (0 :: Int) fs
450+ FL.Done _ ->
451+ error "splitMany: Done in initial not implemented"
448
452
449 {-# INLINE step #-}
453 {-# INLINE step #-}
450 step (Tuple3' st cnt fs) a = do
454 step (Tuple3' st cnt fs) a = do
@@ -493,8 +497,12 @@ splitSome (Fold fstep finitial fextract) (Parser step1 initial1 extract1) =
493
497
494 initial = do
498 initial = do
495 ps <- initial1 -- parse state
499 ps <- initial1 -- parse state
496− fs <- finitial -- fold state
500+ res <- finitial -- fold state
501+ return
502+ $ case res of
497− pure (Tuple3' ps (0 :: Int) (Left fs))
503+ FL.Partial fs -> Tuple3' ps (0 :: Int) (Left fs)
504+ FL.Done _ ->
505+ error "splitSome: Done/Error in initial not implemented"
498
506
499 {-# INLINE step #-}
507 {-# INLINE step #-}
500 step (Tuple3' st cnt (Left fs)) a = do
508 step (Tuple3' st cnt (Left fs)) a = do
src/Streamly/Internal/Data/Sink.hs+1−1
@@ -80,7 +80,7 @@ import qualified Data.Map.Strict as Map
80toFold :: Monad m => Sink m a -> Fold m a ()
80toFold :: Monad m => Sink m a -> Fold m a ()
81toFold (Sink f) = Fold step begin done
81toFold (Sink f) = Fold step begin done
82 where
82 where
83− begin = return ()
83+ begin = return $ Partial ()
84 step _ a = Partial <$> f a
84 step _ a = Partial <$> f a
85 done _ = return ()
85 done _ = return ()
86
86
src/Streamly/Internal/Data/SmallArray.hs+1−1
@@ -112,7 +112,7 @@ writeN limit = Fold step initial extract
112
112
113 initial = do
113 initial = do
114 marr <- liftIO $ newSmallArray limit bottomElement
114 marr <- liftIO $ newSmallArray limit bottomElement
115− return (Tuple' marr 0)
115+ return $ FL.Partial (Tuple' marr 0)
116
116
117 step st@(Tuple' marr i) x
117 step st@(Tuple' marr i) x
118 | i == limit = FL.Done <$> extract st
118 | i == limit = FL.Done <$> extract st
src/Streamly/Internal/Data/Stream/IsStream/Eliminate.hs+2−4
@@ -759,9 +759,7 @@ toHandle h = go
759-- /Internal/
759-- /Internal/
760{-# INLINE toStream #-}
760{-# INLINE toStream #-}
761toStream :: Monad m => Fold m a (SerialT Identity a)
761toStream :: Monad m => Fold m a (SerialT Identity a)
762−toStream = Fold (\f x -> return $ FL.Partial $ f . (x `K.cons`))
762+toStream = FL.mkAccum (\f x -> f . (x `K.cons`)) id ($ K.nil)
763− (return id)
764− (return . ($ K.nil))
765
763
766-- This is more efficient than 'toStream'. toStream is exactly the same as
764-- This is more efficient than 'toStream'. toStream is exactly the same as
767-- reversing the stream after toStreamRev.
765-- reversing the stream after toStreamRev.
@@ -777,7 +775,7 @@ toStream = Fold (\f x -> return $ FL.Partial $ f . (x `K.cons`))
777-- xn : ... : x2 : x1 : []
775-- xn : ... : x2 : x1 : []
778{-# INLINABLE toStreamRev #-}
776{-# INLINABLE toStreamRev #-}
779toStreamRev :: Monad m => Fold m a (SerialT Identity a)
777toStreamRev :: Monad m => Fold m a (SerialT Identity a)
780−toStreamRev = Fold (\xs x -> return $ FL.Partial $ x `K.cons` xs) (return K.nil) return
778+toStreamRev = FL.mkAccum_ (flip K.cons) K.nil
781
779
782-- | Convert a stream to a pure stream.
780-- | Convert a stream to a pure stream.
783--
781--
src/Streamly/Internal/Data/Stream/IsStream/Nesting.hs+13−9
@@ -1802,14 +1802,7 @@ classifySessionsBy tick tmout reset ejectPred
1802 --
1802 --
1803 let curTime = max sessionEventTime timestamp
1803 let curTime = max sessionEventTime timestamp
1804 mOld = Map.lookup key sessionKeyValueMap
1804 mOld = Map.lookup key sessionKeyValueMap
1805−
1805+ let done fb = do
1806− fs <-
1807− case mOld of
1808− Nothing -> initial
1809− Just (Tuple' _ acc) -> return acc
1810− res <- step fs value
1811− case res of
1812− FL.Done fb -> do
1813 -- deleting a key from the heap is expensive, so we never
1806 -- deleting a key from the heap is expensive, so we never
1814 -- delete a key from heap, we just purge it from the Map and it
1807 -- delete a key from heap, we just purge it from the Map and it
1815 -- gets purged from the heap on timeout. We just need an extra
1808 -- gets purged from the heap on timeout. We just need an extra
@@ -1827,7 +1820,7 @@ classifySessionsBy tick tmout reset ejectPred
1827 , sessionKeyValueMap = mp
1820 , sessionKeyValueMap = mp
1828 , sessionOutputStream = yield (key, fb)
1821 , sessionOutputStream = yield (key, fb)
1829 }
1822 }
1830− FL.Partial fs1 -> do
1823+ partial fs1 = do
1831 let acc = Tuple' timestamp fs1
1824 let acc = Tuple' timestamp fs1
1832 (hp1, mp1, out1, cnt1) <- do
1825 (hp1, mp1, out1, cnt1) <- do
1833 let vars = (sessionTimerHeap, sessionKeyValueMap,
1826 let vars = (sessionTimerHeap, sessionKeyValueMap,
@@ -1858,6 +1851,17 @@ classifySessionsBy tick tmout reset ejectPred
1858 , sessionKeyValueMap = mp2
1851 , sessionKeyValueMap = mp2
1859 , sessionOutputStream = out1
1852 , sessionOutputStream = out1
1860 }
1853 }
1854+ res0 <- do
1855+ case mOld of
1856+ Nothing -> initial
1857+ Just (Tuple' _ acc) -> return $ FL.Partial acc
1858+ case res0 of
1859+ FL.Done fb -> done fb
1860+ FL.Partial fs -> do
1861+ res <- step fs value
1862+ case res of
1863+ FL.Done fb -> done fb
1864+ FL.Partial fs1 -> partial fs1
1861
1865
1862 -- Got a timer tick event
1866 -- Got a timer tick event
1863 sstep sessionState@SessionState{..} Nothing =
1867 sstep sessionState@SessionState{..} Nothing =
src/Streamly/Internal/Data/Stream/StreamD/Nesting.hs+314−201
@@ -1218,27 +1218,43 @@ parseIterate func seed (Stream step state) =
1218-- Grouping
1218-- Grouping
1219------------------------------------------------------------------------------
1219------------------------------------------------------------------------------
1220
1220
1221+data GroupByState st fs a b
1222+ = GroupingInit st
1223+ | GroupingDo st !fs
1224+ | GroupingInitWith st !a
1225+ | GroupingDoWith st !fs !a
1226+ | GroupingYield !b (GroupByState st fs a b)
1227+ | GroupingDone
1228+
1221{-# INLINE_NORMAL groupsBy #-}
1229{-# INLINE_NORMAL groupsBy #-}
1222groupsBy :: Monad m
1230groupsBy :: Monad m
1223 => (a -> a -> Bool)
1231 => (a -> a -> Bool)
1224 -> Fold m a b
1232 -> Fold m a b
1225 -> Stream m a
1233 -> Stream m a
1226 -> Stream m b
1234 -> Stream m b
1227−groupsBy cmp f (Stream step state) = Stream (stepOuter f) (Just state, Nothing)
1235+groupsBy cmp (Fold fstep initial done) (Stream step state) =
1236+ Stream stepOuter (GroupingInit state)
1228
1237
1229 where
1238 where
1230
1239
1231 {-# INLINE_LATE stepOuter #-}
1240 {-# INLINE_LATE stepOuter #-}
1232− stepOuter (Fold fstep initial done) gst (Just st, Nothing) = do
1241+ stepOuter _ (GroupingInit st) = do
1242+ -- XXX Note that if the stream stops without yielding a single element
1243+ -- in the group we discard the "initial" effect.
1244+ res <- initial
1245+ return
1246+ $ case res of
1247+ FL.Partial s -> Skip $ GroupingDo st s
1248+ FL.Done b -> Yield b $ GroupingInit st
1249+ stepOuter gst (GroupingDo st fs) = do
1233 res <- step (adaptState gst) st
1250 res <- step (adaptState gst) st
1234 case res of
1251 case res of
1235 Yield x s -> do
1252 Yield x s -> do
1236− fs <- initial
1237 r <- fstep fs x
1253 r <- fstep fs x
1238 case r of
1254 case r of
1239 FL.Partial fs1 -> go SPEC x s fs1
1255 FL.Partial fs1 -> go SPEC x s fs1
1240− FL.Done b -> return $ Yield b (Just s, Just x)
1256+ FL.Done b -> return $ Yield b (GroupingInit s)
1241− Skip s -> return $ Skip (Just s, Nothing)
1257+ Skip s -> return $ Skip $ GroupingDo s fs
1242 Stop -> return Stop
1258 Stop -> return Stop
1243
1259
1244 where
1260 where
@@ -1252,16 +1268,23 @@ groupsBy cmp f (Stream step state) = Stream (stepOuter f) (Just state, Nothing)
1252 r <- fstep acc x
1268 r <- fstep acc x
1253 case r of
1269 case r of
1254 FL.Partial fs1 -> go SPEC prev s fs1
1270 FL.Partial fs1 -> go SPEC prev s fs1
1255− FL.Done b -> return $ Yield b (Just s, Just x)
1271+ FL.Done b -> return $ Yield b (GroupingInit s)
1272+ else do
1273+ r <- done acc
1256− else done acc >>= \r -> return $ Yield r (Just s, Just x)
1274+ return $ Yield r (GroupingInitWith s x)
1257 Skip s -> go SPEC prev s acc
1275 Skip s -> go SPEC prev s acc
1258− Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1276+ Stop -> done acc >>= \r -> return $ Yield r GroupingDone
1259− stepOuter (Fold fstep initial done) gst (Just st, Just prev) = do
1277+ stepOuter _ (GroupingInitWith st x) = do
1260− fs <- initial
1278+ res <- initial
1279+ return
1280+ $ case res of
1281+ FL.Partial s -> Skip $ GroupingDoWith st s x
1282+ FL.Done b -> Yield b $ GroupingInitWith st x
1283+ stepOuter gst (GroupingDoWith st fs prev) = do
1261− r <- fstep fs prev
1284+ res <- fstep fs prev
1262− case r of
1285+ case res of
1263 FL.Partial fs1 -> go SPEC st fs1
1286 FL.Partial fs1 -> go SPEC st fs1
1264− FL.Done b -> return $ Yield b (Just st, Nothing)
1287+ FL.Done b -> return $ Yield b (GroupingInit st)
1265
1288
1266 where
1289 where
1267
1290
@@ -1275,11 +1298,14 @@ groupsBy cmp f (Stream step state) = Stream (stepOuter f) (Just state, Nothing)
1275 r <- fstep acc x
1298 r <- fstep acc x
1276 case r of
1299 case r of
1277 FL.Partial fs1 -> go SPEC s fs1
1300 FL.Partial fs1 -> go SPEC s fs1
1278− FL.Done b -> return $ Yield b (Just s, Just x)
1301+ FL.Done b -> return $ Yield b (GroupingInit s)
1302+ else do
1303+ r <- done acc
1279− else done acc >>= \r -> return $ Yield r (Just s, Just x)
1304+ return $ Yield r (GroupingInitWith s x)
1280 Skip s -> go SPEC s acc
1305 Skip s -> go SPEC s acc
1281− Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1306+ Stop -> done acc >>= \r -> return $ Yield r GroupingDone
1282− stepOuter _ _ (Nothing, _) = return Stop
1307+ stepOuter _ (GroupingYield _ _) = error "groupsBy: Unreachable"
1308+ stepOuter _ GroupingDone = return Stop
1283
1309
1284{-# INLINE_NORMAL groupsRollingBy #-}
1310{-# INLINE_NORMAL groupsRollingBy #-}
1285groupsRollingBy :: Monad m
1311groupsRollingBy :: Monad m
@@ -1287,22 +1313,29 @@ groupsRollingBy :: Monad m
1287 -> Fold m a b
1313 -> Fold m a b
1288 -> Stream m a
1314 -> Stream m a
1289 -> Stream m b
1315 -> Stream m b
1290−groupsRollingBy cmp f (Stream step state) =
1316+groupsRollingBy cmp (Fold fstep initial done) (Stream step state) =
1291− Stream (stepOuter f) (Just state, Nothing)
1317+ Stream stepOuter (GroupingInit state)
1292
1318
1293 where
1319 where
1294
1320
1295 {-# INLINE_LATE stepOuter #-}
1321 {-# INLINE_LATE stepOuter #-}
1296− stepOuter (Fold fstep initial done) gst (Just st, Nothing) = do
1322+ stepOuter _ (GroupingInit st) = do
1323+ -- XXX Note that if the stream stops without yielding a single element
1324+ -- in the group we discard the "initial" effect.
1325+ res <- initial
1326+ return
1327+ $ case res of
1328+ FL.Partial fs -> Skip $ GroupingDo st fs
1329+ FL.Done fb -> Yield fb $ GroupingInit st
1330+ stepOuter gst (GroupingDo st fs) = do
1297 res <- step (adaptState gst) st
1331 res <- step (adaptState gst) st
1298 case res of
1332 case res of
1299 Yield x s -> do
1333 Yield x s -> do
1300− fs <- initial
1301 r <- fstep fs x
1334 r <- fstep fs x
1302 case r of
1335 case r of
1303 FL.Partial fs1 -> go SPEC x s fs1
1336 FL.Partial fs1 -> go SPEC x s fs1
1304− FL.Done b -> return $ Yield b (Just s, Just x)
1337+ FL.Done fb -> return $ Yield fb (GroupingInit s)
1305− Skip s -> return $ Skip $ (Just s, Nothing)
1338+ Skip s -> return $ Skip $ GroupingDo s fs
1306 Stop -> return Stop
1339 Stop -> return Stop
1307
1340
1308 where
1341 where
@@ -1316,62 +1349,104 @@ groupsRollingBy cmp f (Stream step state) =
1316 r <- fstep acc x
1349 r <- fstep acc x
1317 case r of
1350 case r of
1318 FL.Partial fs1 -> go SPEC x s fs1
1351 FL.Partial fs1 -> go SPEC x s fs1
1319− FL.Done b -> return $ Yield b (Just s, Just x)
1352+ FL.Done b -> return $ Yield b (GroupingInit s)
1353+ else do
1354+ r <- done acc
1320− else done acc >>= \r -> return $ Yield r (Just s, Just x)
1355+ return $ Yield r (GroupingInitWith s x)
1321 Skip s -> go SPEC prev s acc
1356 Skip s -> go SPEC prev s acc
1322− Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1357+ Stop -> done acc >>= \r -> return $ Yield r GroupingDone
1323− stepOuter (Fold fstep initial done) gst (Just st, Just prev') = do
1358+ stepOuter _ (GroupingInitWith st x) = do
1324− fs <- initial
1359+ res <- initial
1360+ return
1361+ $ case res of
1362+ FL.Partial s -> Skip $ GroupingDoWith st s x
1363+ FL.Done b -> Yield b $ GroupingInitWith st x
1364+ stepOuter gst (GroupingDoWith st fs previous) = do
1325− r <- fstep fs prev'
1365+ res <- fstep fs previous
1326− case r of
1366+ case res of
1327− FL.Partial fs1 -> go SPEC prev' st fs1
1367+ FL.Partial s -> go SPEC previous st s
1328− FL.Done b -> return $ Yield b (Just st, Nothing)
1368+ FL.Done b -> return $ Yield b (GroupingInit st)
1329
1369
1330 where
1370 where
1331
1371
1372+ -- XXX GHC: groupsBy has one less parameter in this go loop and it
1373+ -- fuses. However, groupsRollingBy does not fuse, removing the prev
1374+ -- parameter makes it fuse. Something needs to be fixed in GHC. The
1375+ -- workaround for this is noted in the comments below.
1332− go !_ prevv stt !acc = do
1376+ go !_ prev !stt !acc = do
1333 res <- step (adaptState gst) stt
1377 res <- step (adaptState gst) stt
1334 case res of
1378 case res of
1335 Yield x s -> do
1379 Yield x s -> do
1336− if cmp prevv x
1380+ if cmp prev x
1337 then do
1381 then do
1338 r <- fstep acc x
1382 r <- fstep acc x
1339 case r of
1383 case r of
1340 FL.Partial fs1 -> go SPEC x s fs1
1384 FL.Partial fs1 -> go SPEC x s fs1
1341− FL.Done b -> return $ Yield b (Just s, Just x)
1385+ FL.Done b -> return $ Yield b (GroupingInit st)
1342− else done acc >>= \r -> return $ Yield r (Just s, Just x)
1386+ else do
1387+ {-
1388+ r <- done acc
1389+ return $ Yield r (GroupingInitWith s x)
1390+ -}
1391+ -- The code above does not let groupBy fuse. We use the
1392+ -- alternative code below instead. Instead of jumping
1393+ -- to GroupingInitWith state, we unroll the code of
1394+ -- GroupingInitWith state here to help GHC with stream
1395+ -- fusion.
1396+ result <- initial
1397+ r <- done acc
1398+ return
1399+ $ Yield r
1400+ $ case result of
1401+ FL.Partial fsi -> GroupingDoWith s fsi x
1402+ FL.Done b -> GroupingYield b (GroupingInit s)
1343− Skip s -> go SPEC prevv s acc
1403+ Skip s -> go SPEC prev s acc
1344− Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1404+ Stop -> done acc >>= \r -> return $ Yield r GroupingDone
1345− stepOuter _ _ (Nothing, _) = return Stop
1405+ stepOuter _ (GroupingYield r next) = return $ Yield r next
1406+ stepOuter _ GroupingDone = return Stop
1346
1407
1347------------------------------------------------------------------------------
1408------------------------------------------------------------------------------
1348-- Splitting - by a predicate
1409-- Splitting - by a predicate
1349------------------------------------------------------------------------------
1410------------------------------------------------------------------------------
1350
1411
1351−data WordsByState s = WordsByJust s | WordsByNothing
1412+data WordsByState st fs b
1413+ = WordsByInit st
1414+ | WordsByDo st !fs
1415+ | WordsByDone
1416+ | WordsByYield !b (WordsByState st fs b)
1352
1417
1353{-# INLINE_NORMAL wordsBy #-}
1418{-# INLINE_NORMAL wordsBy #-}
1354wordsBy :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
1419wordsBy :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
1355−wordsBy predicate f (Stream step state) =
1420+wordsBy predicate (Fold fstep initial done) (Stream step state) =
1356− Stream (stepOuter f) (WordsByJust state)
1421+ Stream stepOuter (WordsByInit state)
1357
1422
1358 where
1423 where
1359
1424
1360 {-# INLINE_LATE stepOuter #-}
1425 {-# INLINE_LATE stepOuter #-}
1361− stepOuter (Fold fstep initial done) gst (WordsByJust st) = do
1426+ stepOuter _ (WordsByInit st) = do
1427+ res <- initial
1428+ return
1429+ $ case res of
1430+ FL.Partial s -> Skip $ WordsByDo st s
1431+ FL.Done b -> Yield b (WordsByInit st)
1432+
1433+ stepOuter gst (WordsByDo st fs) = do
1362 res <- step (adaptState gst) st
1434 res <- step (adaptState gst) st
1363 case res of
1435 case res of
1364 Yield x s -> do
1436 Yield x s -> do
1365 if predicate x
1437 if predicate x
1366− then return $ Skip (WordsByJust s)
1438+ then do
1439+ resi <- initial
1440+ return
1441+ $ case resi of
1442+ FL.Partial fs1 -> Skip $ WordsByDo s fs1
1443+ FL.Done b -> Yield b (WordsByInit s)
1367 else do
1444 else do
1368− fs <- initial
1369 r <- fstep fs x
1445 r <- fstep fs x
1370 case r of
1446 case r of
1371 FL.Partial fs1 -> go SPEC s fs1
1447 FL.Partial fs1 -> go SPEC s fs1
1372− FL.Done b -> return $ Yield b (WordsByJust s)
1448+ FL.Done b -> return $ Yield b (WordsByInit s)
1373−
1374− Skip s -> return $ Skip $ WordsByJust s
1449+ Skip s -> return $ Skip $ WordsByDo s fs
1375 Stop -> return Stop
1450 Stop -> return Stop
1376
1451
1377 where
1452 where
@@ -1381,16 +1456,34 @@ wordsBy predicate f (Stream step state) =
1381 case res of
1456 case res of
1382 Yield x s -> do
1457 Yield x s -> do
1383 if predicate x
1458 if predicate x
1384− then done acc >>= \r -> return $ Yield r (WordsByJust s)
1459+ then do
1460+ {-
1461+ r <- done acc
1462+ return $ Yield r (WordsByInit s)
1463+ -}
1464+ -- The above code does not fuse well. Need to check why
1465+ -- GHC is not able to simplify it well. Using the code
1466+ -- below, instead of jumping through the WordsByInit
1467+ -- state always, we directly go to WordsByDo state in
1468+ -- the common case of Partial.
1469+ resi <- initial
1470+ r <- done acc
1471+ return
1472+ $ Yield r
1473+ $ case resi of
1474+ FL.Partial fs1 -> WordsByDo s fs1
1475+ FL.Done b -> WordsByYield b (WordsByInit s)
1385 else do
1476 else do
1386 r <- fstep acc x
1477 r <- fstep acc x
1387 case r of
1478 case r of
1388 FL.Partial fs1 -> go SPEC s fs1
1479 FL.Partial fs1 -> go SPEC s fs1
1389− FL.Done b -> return $ Yield b (WordsByJust s)
1480+ FL.Done b -> return $ Yield b (WordsByInit s)
1390 Skip s -> go SPEC s acc
1481 Skip s -> go SPEC s acc
1391− Stop -> done acc >>= \r -> return $ Yield r WordsByNothing
1482+ Stop -> done acc >>= \r -> return $ Yield r WordsByDone
1483+
1484+ stepOuter _ WordsByDone = return Stop
1392
1485
1393− stepOuter _ _ WordsByNothing = return Stop
1486+ stepOuter _ (WordsByYield b next) = return $ Yield b next
1394
1487
1395------------------------------------------------------------------------------
1488------------------------------------------------------------------------------
1396-- Splitting on a sequence
1489-- Splitting on a sequence
@@ -1413,25 +1506,30 @@ data SplitOptions = SplitOptions
1413 }
1506 }
1414-}
1507-}
1415
1508
1509+-- XXX using "fs" as the last arg in Constructors may simplify the code a bit,
1510+-- because we can use the constructor directly without having to create "jump"
1511+-- functions.
1416{-# ANN type SplitOnSeqState Fuse #-}
1512{-# ANN type SplitOnSeqState Fuse #-}
1417data SplitOnSeqState rb rh ck w fs s b x =
1513data SplitOnSeqState rb rh ck w fs s b x =
1418 SplitOnSeqInit
1514 SplitOnSeqInit
1419 | SplitOnSeqYield b (SplitOnSeqState rb rh ck w fs s b x)
1515 | SplitOnSeqYield b (SplitOnSeqState rb rh ck w fs s b x)
1420 | SplitOnSeqDone
1516 | SplitOnSeqDone
1421
1517
1422− | SplitOnSeqEmpty s
1518+ | SplitOnSeqEmpty !fs s
1423
1519
1424 | SplitOnSeqSingle !fs s x
1520 | SplitOnSeqSingle !fs s x
1425
1521
1426− | SplitOnSeqWordInit s
1522+ | SplitOnSeqWordInit !fs s
1427 | SplitOnSeqWordLoop !w s !fs
1523 | SplitOnSeqWordLoop !w s !fs
1428 | SplitOnSeqWordDone Int !fs !w
1524 | SplitOnSeqWordDone Int !fs !w
1429
1525
1430− | SplitOnSeqKRInit Int s rb !rh
1526+ | SplitOnSeqKRInit Int !fs s rb !rh
1431 | SplitOnSeqKRLoop fs s rb !rh !ck
1527 | SplitOnSeqKRLoop fs s rb !rh !ck
1432 | SplitOnSeqKRCheck fs s rb !rh
1528 | SplitOnSeqKRCheck fs s rb !rh
1433 | SplitOnSeqKRDone Int !fs rb !rh
1529 | SplitOnSeqKRDone Int !fs rb !rh
1434
1530
1531+ | SplitOnSeqReinit (fs -> SplitOnSeqState rb rh ck w fs s b x)
1532+
1435{-# INLINE_NORMAL splitOnSeq #-}
1533{-# INLINE_NORMAL splitOnSeq #-}
1436splitOnSeq
1534splitOnSeq
1437 :: forall m a b. (MonadIO m, Storable a, Enum a, Eq a)
1535 :: forall m a b. (MonadIO m, Storable a, Enum a, Eq a)
@@ -1474,41 +1572,59 @@ splitOnSeq patArr (Fold fstep initial done) (Stream step state) =
1474
1572
1475 skip = return . Skip
1573 skip = return . Skip
1476
1574
1575+ nextAfterInit nextGen stepRes =
1576+ case stepRes of
1577+ FL.Partial s -> nextGen s
1578+ FL.Done b -> SplitOnSeqYield b (SplitOnSeqReinit nextGen)
1579+
1580+ {-# INLINE yieldProceed #-}
1581+ yieldProceed nextGen fs =
1582+ initial >>= skip . SplitOnSeqYield fs . nextAfterInit nextGen
1583+
1477 {-# INLINE_LATE stepOuter #-}
1584 {-# INLINE_LATE stepOuter #-}
1478− stepOuter _ SplitOnSeqInit =
1585+ stepOuter _ SplitOnSeqInit = do
1586+ res <- initial
1587+ case res of
1588+ FL.Partial acc ->
1479− if patLen == 0
1589+ if patLen == 0
1480− then return $ Skip $ SplitOnSeqEmpty state
1590+ then return $ Skip $ SplitOnSeqEmpty acc state
1481− else if patLen == 1
1591+ else if patLen == 1
1482− then do
1592+ then do
1483− acc <- initial
1484− pat <- liftIO $ A.unsafeIndexIO patArr 0
1593+ pat <- liftIO $ A.unsafeIndexIO patArr 0
1485− return $ Skip $ SplitOnSeqSingle acc state pat
1594+ return $ Skip $ SplitOnSeqSingle acc state pat
1486− else if sizeOf (undefined :: a) * patLen
1595+ else if sizeOf (undefined :: a) * patLen
1487− <= sizeOf (undefined :: Word)
1596+ <= sizeOf (undefined :: Word)
1488− then return $ Skip $ SplitOnSeqWordInit state
1597+ then return $ Skip $ SplitOnSeqWordInit acc state
1489− else do
1598+ else do
1490− (rb, rhead) <- liftIO $ RB.new patLen
1599+ (rb, rhead) <- liftIO $ RB.new patLen
1491− skip $ SplitOnSeqKRInit 0 state rb rhead
1600+ skip $ SplitOnSeqKRInit 0 acc state rb rhead
1601+ FL.Done b -> skip $ SplitOnSeqYield b SplitOnSeqInit
1492
1602
1493 stepOuter _ (SplitOnSeqYield x next) = return $ Yield x next
1603 stepOuter _ (SplitOnSeqYield x next) = return $ Yield x next
1494
1604
1605+ ---------------------------
1606+ -- Checkpoint
1607+ ---------------------------
1608+
1609+ stepOuter _ (SplitOnSeqReinit nextGen) =
1610+ initial >>= skip . nextAfterInit nextGen
1611+
1495 ---------------------------
1612 ---------------------------
1496 -- Empty pattern
1613 -- Empty pattern
1497 ---------------------------
1614 ---------------------------
1498
1615
1499− stepOuter gst (SplitOnSeqEmpty st) = do
1616+ stepOuter gst (SplitOnSeqEmpty acc st) = do
1500 res <- step (adaptState gst) st
1617 res <- step (adaptState gst) st
1501 case res of
1618 case res of
1502 Yield x s -> do
1619 Yield x s -> do
1503− fs <- initial
1504− r <- fstep fs x
1620+ r <- fstep acc x
1621+ b1 <-
1505− case r of
1622+ case r of
1506− FL.Partial fs1 -> do
1623+ FL.Partial acc1 -> done acc1
1507− b <- done fs1
1624+ FL.Done b -> return b
1508− skip $ SplitOnSeqYield b (SplitOnSeqEmpty s)
1509− FL.Done b -> skip $ SplitOnSeqYield b (SplitOnSeqEmpty s)
1625+ let jump c = SplitOnSeqEmpty c s
1510−
1626+ in yieldProceed jump b1
1511− Skip s -> return $ Skip (SplitOnSeqEmpty s)
1627+ Skip s -> skip (SplitOnSeqEmpty acc s)
1512 Stop -> return Stop
1628 Stop -> return Stop
1513
1629
1514 -----------------
1630 -----------------
@@ -1525,18 +1641,14 @@ splitOnSeq patArr (Fold fstep initial done) (Stream step state) =
1525 res <- step (adaptState gst) st
1641 res <- step (adaptState gst) st
1526 case res of
1642 case res of
1527 Yield x s -> do
1643 Yield x s -> do
1644+ let jump c = SplitOnSeqSingle c s pat
1528 if pat == x
1645 if pat == x
1529− then do
1646+ then done fs >>= yieldProceed jump
1530− r <- done fs
1531− fs1 <- initial
1532− return $ Skip $ SplitOnSeqYield r (SplitOnSeqSingle fs1 s pat)
1533 else do
1647 else do
1534 r <- fstep fs x
1648 r <- fstep fs x
1535 case r of
1649 case r of
1536− FL.Partial fs1 -> skip $ SplitOnSeqSingle fs1 s pat
1650+ FL.Partial fs1 -> skip $ jump fs1
1537− FL.Done b -> do
1651+ FL.Done b -> yieldProceed jump b
1538− fs1 <- initial
1539− skip $ SplitOnSeqYield b (SplitOnSeqSingle fs1 s pat)
1540 Skip s -> return $ Skip $ SplitOnSeqSingle fs s pat
1652 Skip s -> return $ Skip $ SplitOnSeqSingle fs s pat
1541 Stop -> do
1653 Stop -> do
1542 r <- done fs
1654 r <- done fs
@@ -1555,11 +1667,10 @@ splitOnSeq patArr (Fold fstep initial done) (Stream step state) =
1555 case r of
1667 case r of
1556 FL.Partial fs1 -> skip $ SplitOnSeqWordDone (n - 1) fs1 wrd
1668 FL.Partial fs1 -> skip $ SplitOnSeqWordDone (n - 1) fs1 wrd
1557 FL.Done b -> do
1669 FL.Done b -> do
1558− fs1 <- initial
1559− let next = SplitOnSeqWordDone (n - 1) fs1 wrd
1670+ let jump c = SplitOnSeqWordDone (n - 1) c wrd
1560− skip $ SplitOnSeqYield b next
1671+ yieldProceed jump b
1561
1672
1562− stepOuter gst (SplitOnSeqWordInit st0) =
1673+ stepOuter gst (SplitOnSeqWordInit fs st0) =
1563 go SPEC 0 0 st0
1674 go SPEC 0 0 st0
1564
1675
1565 where
1676 where
@@ -1572,17 +1683,14 @@ splitOnSeq patArr (Fold fstep initial done) (Stream step state) =
1572 let wrd1 = addToWord wrd x
1683 let wrd1 = addToWord wrd x
1573 if idx == maxIndex
1684 if idx == maxIndex
1574 then do
1685 then do
1575− fs <- initial
1576 if wrd1 .&. wordMask == wordPat
1686 if wrd1 .&. wordMask == wordPat
1577 then do
1687 then do
1578− r <- done fs
1579− let next = SplitOnSeqWordInit s
1688+ let jump c = SplitOnSeqWordInit c s
1580− skip $ SplitOnSeqYield r next
1689+ done fs >>= yieldProceed jump
1581 else skip $ SplitOnSeqWordLoop wrd1 s fs
1690 else skip $ SplitOnSeqWordLoop wrd1 s fs
1582 else go SPEC (idx + 1) wrd1 s
1691 else go SPEC (idx + 1) wrd1 s
1583 Skip s -> go SPEC idx wrd s
1692 Skip s -> go SPEC idx wrd s
1584 Stop -> do
1693 Stop -> do
1585− fs <- initial
1586 if idx /= 0
1694 if idx /= 0
1587 then skip $ SplitOnSeqWordDone idx fs wrd
1695 then skip $ SplitOnSeqWordDone idx fs wrd
1588 else do
1696 else do
@@ -1599,21 +1707,17 @@ splitOnSeq patArr (Fold fstep initial done) (Stream step state) =
1599 res <- step (adaptState gst) st
1707 res <- step (adaptState gst) st
1600 case res of
1708 case res of
1601 Yield x s -> do
1709 Yield x s -> do
1710+ let jump c = SplitOnSeqWordInit c s
1602− let wrd1 = addToWord wrd x
1711+ wrd1 = addToWord wrd x
1603 old = (wordMask .&. wrd)
1712 old = (wordMask .&. wrd)
1604 `shiftR` (elemBits * (patLen - 1))
1713 `shiftR` (elemBits * (patLen - 1))
1605 r <- fstep fs (toEnum $ fromIntegral old)
1714 r <- fstep fs (toEnum $ fromIntegral old)
1606 case r of
1715 case r of
1607 FL.Partial fs1 -> do
1716 FL.Partial fs1 -> do
1608 if wrd1 .&. wordMask == wordPat
1717 if wrd1 .&. wordMask == wordPat
1609− then do
1610− b <- done fs1
1718+ then done fs1 >>= yieldProceed jump
1611− let next = SplitOnSeqWordInit s
1612− skip $ SplitOnSeqYield b next
1613 else go SPEC wrd1 s fs1
1719 else go SPEC wrd1 s fs1
1614− FL.Done b ->
1720+ FL.Done b -> yieldProceed jump b
1615− let next = SplitOnSeqWordInit s
1616− in skip $ SplitOnSeqYield b next
1617 Skip s -> go SPEC wrd s fs
1721 Skip s -> go SPEC wrd s fs
1618 Stop -> skip $ SplitOnSeqWordDone patLen fs wrd
1722 Stop -> skip $ SplitOnSeqWordDone patLen fs wrd
1619
1723
@@ -1621,7 +1725,7 @@ splitOnSeq patArr (Fold fstep initial done) (Stream step state) =
1621 -- General Pattern - Karp Rabin
1725 -- General Pattern - Karp Rabin
1622 -------------------------------
1726 -------------------------------
1623
1727
1624− stepOuter gst (SplitOnSeqKRInit idx st rb rh) = do
1728+ stepOuter gst (SplitOnSeqKRInit idx fs st rb rh) = do
1625 res <- step (adaptState gst) st
1729 res <- step (adaptState gst) st
1626 case res of
1730 case res of
1627 Yield x s -> do
1731 Yield x s -> do
@@ -1630,14 +1734,12 @@ splitOnSeq patArr (Fold fstep initial done) (Stream step state) =
1630 then do
1734 then do
1631 let fold = RB.unsafeFoldRing (RB.ringBound rb)
1735 let fold = RB.unsafeFoldRing (RB.ringBound rb)
1632 let !ringHash = fold addCksum 0 rb
1736 let !ringHash = fold addCksum 0 rb
1633− fs <- initial
1634 if ringHash == patHash
1737 if ringHash == patHash
1635 then skip $ SplitOnSeqKRCheck fs s rb rh1
1738 then skip $ SplitOnSeqKRCheck fs s rb rh1
1636 else skip $ SplitOnSeqKRLoop fs s rb rh1 ringHash
1739 else skip $ SplitOnSeqKRLoop fs s rb rh1 ringHash
1637− else skip $ SplitOnSeqKRInit (idx + 1) s rb rh1
1740+ else skip $ SplitOnSeqKRInit (idx + 1) fs s rb rh1
1638− Skip s -> skip $ SplitOnSeqKRInit idx s rb rh
1741+ Skip s -> skip $ SplitOnSeqKRInit idx fs s rb rh
1639 Stop -> do
1742 Stop -> do
1640− fs <- initial
1641 skip $ SplitOnSeqKRDone idx fs rb (RB.startOf rb)
1743 skip $ SplitOnSeqKRDone idx fs rb (RB.startOf rb)
1642
1744
1643 -- XXX The recursive "go" is more efficient than the state based recursion
1745 -- XXX The recursive "go" is more efficient than the state based recursion
@@ -1662,9 +1764,10 @@ splitOnSeq patArr (Fold fstep initial done) (Stream step state) =
1662 if cksum1 == patHash
1764 if cksum1 == patHash
1663 then skip $ SplitOnSeqKRCheck fs1 s rb rh1
1765 then skip $ SplitOnSeqKRCheck fs1 s rb rh1
1664 else go SPEC fs1 s rh1 cksum1
1766 else go SPEC fs1 s rh1 cksum1
1665− FL.Done b ->
1767+ FL.Done b -> do
1768+ let rst = RB.startOf rb
1666− let next = SplitOnSeqKRInit 0 s rb (RB.startOf rb)
1769+ jump c = SplitOnSeqKRInit 0 c s rb rst
1667− in skip $ SplitOnSeqYield b next
1770+ yieldProceed jump b
1668 Skip s -> go SPEC fs s rh cksum
1771 Skip s -> go SPEC fs s rh cksum
1669 Stop -> skip $ SplitOnSeqKRDone patLen fs rb rh
1772 Stop -> skip $ SplitOnSeqKRDone patLen fs rb rh
1670
1773
@@ -1698,9 +1801,11 @@ splitOnSeq patArr (Fold fstep initial done) (Stream step state) =
1698 if RB.unsafeEqArray rb rh patArr
1801 if RB.unsafeEqArray rb rh patArr
1699 then do
1802 then do
1700 r <- done fs
1803 r <- done fs
1701− let next = SplitOnSeqKRInit 0 st rb (RB.startOf rb)
1804+ let rst = RB.startOf rb
1702− skip $ SplitOnSeqYield r next
1805+ jump c = SplitOnSeqKRInit 0 c st rb rst
1806+ yieldProceed jump r
1703 else skip $ SplitOnSeqKRLoop fs st rb rh patHash
1807 else skip $ SplitOnSeqKRLoop fs st rb rh patHash
1808+
1704 stepOuter _ (SplitOnSeqKRDone 0 fs _ _) = do
1809 stepOuter _ (SplitOnSeqKRDone 0 fs _ _) = do
1705 r <- done fs
1810 r <- done fs
1706 skip $ SplitOnSeqYield r SplitOnSeqDone
1811 skip $ SplitOnSeqYield r SplitOnSeqDone
@@ -1711,9 +1816,8 @@ splitOnSeq patArr (Fold fstep initial done) (Stream step state) =
1711 case r of
1816 case r of
1712 FL.Partial fs1 -> skip $ SplitOnSeqKRDone (n - 1) fs1 rb rh1
1817 FL.Partial fs1 -> skip $ SplitOnSeqKRDone (n - 1) fs1 rb rh1
1713 FL.Done b -> do
1818 FL.Done b -> do
1714− fs1 <- initial
1715− let next = SplitOnSeqKRDone (n - 1) fs1 rb rh1
1819+ let jump c = SplitOnSeqKRDone (n - 1) c rb rh1
1716− skip $ SplitOnSeqYield b next
1820+ yieldProceed jump b
1717
1821
1718{-# ANN type SplitOnSuffixSeqState Fuse #-}
1822{-# ANN type SplitOnSuffixSeqState Fuse #-}
1719data SplitOnSuffixSeqState rb rh ck w fs s b x =
1823data SplitOnSuffixSeqState rb rh ck w fs s b x =
@@ -1721,21 +1825,24 @@ data SplitOnSuffixSeqState rb rh ck w fs s b x =
1721 | SplitOnSuffixSeqYield b (SplitOnSuffixSeqState rb rh ck w fs s b x)
1825 | SplitOnSuffixSeqYield b (SplitOnSuffixSeqState rb rh ck w fs s b x)
1722 | SplitOnSuffixSeqDone
1826 | SplitOnSuffixSeqDone
1723
1827
1724− | SplitOnSuffixSeqEmpty s
1828+ | SplitOnSuffixSeqEmpty !fs s
1725
1829
1726− | SplitOnSuffixSeqSingleInit s x
1830+ | SplitOnSuffixSeqSingleInit !fs s x
1727 | SplitOnSuffixSeqSingle !fs s x
1831 | SplitOnSuffixSeqSingle !fs s x
1728
1832
1729− | SplitOnSuffixSeqWordInit s
1833+ | SplitOnSuffixSeqWordInit !fs s
1730 | SplitOnSuffixSeqWordLoop !w s !fs
1834 | SplitOnSuffixSeqWordLoop !w s !fs
1731 | SplitOnSuffixSeqWordDone Int !fs !w
1835 | SplitOnSuffixSeqWordDone Int !fs !w
1732
1836
1733− | SplitOnSuffixSeqKRInit Int s rb !rh
1837+ | SplitOnSuffixSeqKRInit Int !fs s rb !rh
1734 | SplitOnSuffixSeqKRInit1 !fs s rb !rh
1838 | SplitOnSuffixSeqKRInit1 !fs s rb !rh
1735 | SplitOnSuffixSeqKRLoop fs s rb !rh !ck
1839 | SplitOnSuffixSeqKRLoop fs s rb !rh !ck
1736 | SplitOnSuffixSeqKRCheck fs s rb !rh
1840 | SplitOnSuffixSeqKRCheck fs s rb !rh
1737 | SplitOnSuffixSeqKRDone Int !fs rb !rh
1841 | SplitOnSuffixSeqKRDone Int !fs rb !rh
1738
1842
1843+ | SplitOnSuffixSeqReinit
1844+ (fs -> SplitOnSuffixSeqState rb rh ck w fs s b x)
1845+
1739{-# INLINE_NORMAL splitOnSuffixSeq #-}
1846{-# INLINE_NORMAL splitOnSuffixSeq #-}
1740splitOnSuffixSeq
1847splitOnSuffixSeq
1741 :: forall m a b. (MonadIO m, Storable a, Enum a, Eq a)
1848 :: forall m a b. (MonadIO m, Storable a, Enum a, Eq a)
@@ -1765,27 +1872,33 @@ splitOnSuffixSeq withSep patArr (Fold fstep initial done) (Stream step state) =
1765
1872
1766 addToWord wd a = (wd `shiftL` elemBits) .|. fromIntegral (fromEnum a)
1873 addToWord wd a = (wd `shiftL` elemBits) .|. fromIntegral (fromEnum a)
1767
1874
1875+ nextAfterInit nextGen stepRes =
1876+ case stepRes of
1877+ FL.Partial s -> nextGen s
1878+ FL.Done b ->
1879+ SplitOnSuffixSeqYield b (SplitOnSuffixSeqReinit nextGen)
1880+
1881+ {-# INLINE yieldProceed #-}
1882+ yieldProceed nextGen fs =
1883+ initial >>= skip . SplitOnSuffixSeqYield fs . nextAfterInit nextGen
1884+
1768 -- For single element pattern case
1885 -- For single element pattern case
1769 {-# INLINE processYieldSingle #-}
1886 {-# INLINE processYieldSingle #-}
1770− processYieldSingle pat x s fs =
1887+ processYieldSingle pat x s fs = do
1888+ let jump c = SplitOnSuffixSeqSingleInit c s pat
1771 if pat == x
1889 if pat == x
1772 then do
1890 then do
1773 r <- if withSep then fstep fs x else return $ FL.Partial fs
1891 r <- if withSep then fstep fs x else return $ FL.Partial fs
1892+ b1 <-
1774− case r of
1893+ case r of
1775− FL.Partial fs1 -> do
1894+ FL.Partial fs1 -> done fs1
1776− b <- done fs1
1777− let next = SplitOnSuffixSeqSingleInit s pat
1778− skip $ SplitOnSuffixSeqYield b next
1779− FL.Done b ->
1895+ FL.Done b -> return b
1780− let next = SplitOnSuffixSeqSingleInit s pat
1896+ yieldProceed jump b1
1781− in skip $ SplitOnSuffixSeqYield b next
1782 else do
1897 else do
1783 r <- fstep fs x
1898 r <- fstep fs x
1784 case r of
1899 case r of
1785 FL.Partial fs1 -> skip $ SplitOnSuffixSeqSingle fs1 s pat
1900 FL.Partial fs1 -> skip $ SplitOnSuffixSeqSingle fs1 s pat
1786− FL.Done b ->
1901+ FL.Done b -> yieldProceed jump b
1787− let next = SplitOnSuffixSeqSingleInit s pat
1788− in skip $ SplitOnSuffixSeqYield b next
1789
1902
1790 -- For Rabin-Karp search
1903 -- For Rabin-Karp search
1791 k = 2891336453 :: Word32
1904 k = 2891336453 :: Word32
@@ -1802,39 +1915,49 @@ splitOnSuffixSeq withSep patArr (Fold fstep initial done) (Stream step state) =
1802 skip = return . Skip
1915 skip = return . Skip
1803
1916
1804 {-# INLINE_LATE stepOuter #-}
1917 {-# INLINE_LATE stepOuter #-}
1805− stepOuter _ SplitOnSuffixSeqInit =
1918+ stepOuter _ SplitOnSuffixSeqInit = do
1919+ res <- initial
1920+ case res of
1921+ FL.Partial fs ->
1806− if patLen == 0
1922+ if patLen == 0
1807− then skip $ SplitOnSuffixSeqEmpty state
1923+ then skip $ SplitOnSuffixSeqEmpty fs state
1808− else if patLen == 1
1924+ else if patLen == 1
1809− then do
1925+ then do
1810− pat <- liftIO $ A.unsafeIndexIO patArr 0
1926+ pat <- liftIO $ A.unsafeIndexIO patArr 0
1811− skip $ SplitOnSuffixSeqSingleInit state pat
1927+ skip $ SplitOnSuffixSeqSingleInit fs state pat
1812− else if sizeOf (undefined :: a) * patLen
1928+ else if sizeOf (undefined :: a) * patLen
1813− <= sizeOf (undefined :: Word)
1929+ <= sizeOf (undefined :: Word)
1814− then skip $ SplitOnSuffixSeqWordInit state
1930+ then skip $ SplitOnSuffixSeqWordInit fs state
1815− else do
1931+ else do
1816− (rb, rhead) <- liftIO $ RB.new patLen
1932+ (rb, rhead) <- liftIO $ RB.new patLen
1817− skip $ SplitOnSuffixSeqKRInit 0 state rb rhead
1933+ skip $ SplitOnSuffixSeqKRInit 0 fs state rb rhead
1934+ FL.Done fb -> skip $ SplitOnSuffixSeqYield fb SplitOnSuffixSeqInit
1818
1935
1819 stepOuter _ (SplitOnSuffixSeqYield x next) = return $ Yield x next
1936 stepOuter _ (SplitOnSuffixSeqYield x next) = return $ Yield x next
1820
1937
1938+ ---------------------------
1939+ -- Reinit
1940+ ---------------------------
1941+
1942+ stepOuter _ (SplitOnSuffixSeqReinit nextGen) =
1943+ initial >>= skip . nextAfterInit nextGen
1944+
1821 ---------------------------
1945 ---------------------------
1822 -- Empty pattern
1946 -- Empty pattern
1823 ---------------------------
1947 ---------------------------
1824
1948
1825− stepOuter gst (SplitOnSuffixSeqEmpty st) = do
1949+ stepOuter gst (SplitOnSuffixSeqEmpty acc st) = do
1826 res <- step (adaptState gst) st
1950 res <- step (adaptState gst) st
1827 case res of
1951 case res of
1828 Yield x s -> do
1952 Yield x s -> do
1829− acc <- initial
1953+ let jump c = SplitOnSuffixSeqEmpty c s
1830 r <- fstep acc x
1954 r <- fstep acc x
1955+ b1 <-
1831− case r of
1956+ case r of
1832− FL.Partial fs -> do
1957+ FL.Partial fs -> done fs
1833− b <- done fs
1834− skip $ SplitOnSuffixSeqYield b (SplitOnSuffixSeqEmpty s)
1835− FL.Done b ->
1958+ FL.Done b -> return b
1836− skip $ SplitOnSuffixSeqYield b (SplitOnSuffixSeqEmpty s)
1959+ yieldProceed jump b1
1837− Skip s -> skip (SplitOnSuffixSeqEmpty s)
1960+ Skip s -> skip (SplitOnSuffixSeqEmpty acc s)
1838 Stop -> return Stop
1961 Stop -> return Stop
1839
1962
1840 -----------------
1963 -----------------
@@ -1847,11 +1970,11 @@ splitOnSuffixSeq withSep patArr (Fold fstep initial done) (Stream step state) =
1847 -- Single Pattern
1970 -- Single Pattern
1848 -----------------
1971 -----------------
1849
1972
1850− stepOuter gst (SplitOnSuffixSeqSingleInit st pat) = do
1973+ stepOuter gst (SplitOnSuffixSeqSingleInit fs st pat) = do
1851 res <- step (adaptState gst) st
1974 res <- step (adaptState gst) st
1852 case res of
1975 case res of
1853− Yield x s -> initial >>= processYieldSingle pat x s
1976+ Yield x s -> processYieldSingle pat x s fs
1854− Skip s -> skip $ SplitOnSuffixSeqSingleInit s pat
1977+ Skip s -> skip $ SplitOnSuffixSeqSingleInit fs s pat
1855 Stop -> return Stop
1978 Stop -> return Stop
1856
1979
1857 stepOuter gst (SplitOnSuffixSeqSingle fs st pat) = do
1980 stepOuter gst (SplitOnSuffixSeqSingle fs st pat) = do
@@ -1876,23 +1999,21 @@ splitOnSuffixSeq withSep patArr (Fold fstep initial done) (Stream step state) =
1876 case r of
1999 case r of
1877 FL.Partial fs1 -> skip $ SplitOnSuffixSeqWordDone (n - 1) fs1 wrd
2000 FL.Partial fs1 -> skip $ SplitOnSuffixSeqWordDone (n - 1) fs1 wrd
1878 FL.Done b -> do
2001 FL.Done b -> do
1879− fs1 <- initial
1880− let next = SplitOnSuffixSeqWordDone (n - 1) fs1 wrd
2002+ let jump c = SplitOnSuffixSeqWordDone (n - 1) c wrd
1881− skip $ SplitOnSuffixSeqYield b next
2003+ yieldProceed jump b
1882
2004
1883− stepOuter gst (SplitOnSuffixSeqWordInit st0) = do
2005+ stepOuter gst (SplitOnSuffixSeqWordInit fs0 st0) = do
1884 res <- step (adaptState gst) st0
2006 res <- step (adaptState gst) st0
1885 case res of
2007 case res of
1886 Yield x s -> do
2008 Yield x s -> do
1887− fs <- initial
1888 let wrd = addToWord 0 x
2009 let wrd = addToWord 0 x
1889− r <- if withSep then fstep fs x else return $ FL.Partial fs
2010+ r <- if withSep then fstep fs0 x else return $ FL.Partial fs0
1890 case r of
2011 case r of
1891 FL.Partial fs1 -> go SPEC 1 wrd s fs1
2012 FL.Partial fs1 -> go SPEC 1 wrd s fs1
1892 FL.Done b -> do
2013 FL.Done b -> do
1893− let next = SplitOnSuffixSeqWordInit s
2014+ let jump c = SplitOnSuffixSeqWordInit c s
1894− in skip $ SplitOnSuffixSeqYield b next
2015+ yieldProceed jump b
1895− Skip s -> skip (SplitOnSuffixSeqWordInit s)
2016+ Skip s -> skip (SplitOnSuffixSeqWordInit fs0 s)
1896 Stop -> return Stop
2017 Stop -> return Stop
1897
2018
1898 where
2019 where
@@ -1902,6 +2023,7 @@ splitOnSuffixSeq withSep patArr (Fold fstep initial done) (Stream step state) =
1902 res <- step (adaptState gst) st
2023 res <- step (adaptState gst) st
1903 case res of
2024 case res of
1904 Yield x s -> do
2025 Yield x s -> do
2026+ let jump c = SplitOnSuffixSeqWordInit c s
1905 let wrd1 = addToWord wrd x
2027 let wrd1 = addToWord wrd x
1906 r <- if withSep then fstep fs x else return $ FL.Partial fs
2028 r <- if withSep then fstep fs x else return $ FL.Partial fs
1907 case r of
2029 case r of
@@ -1910,13 +2032,8 @@ splitOnSuffixSeq withSep patArr (Fold fstep initial done) (Stream step state) =
1910 then go SPEC (idx + 1) wrd1 s fs1
2032 then go SPEC (idx + 1) wrd1 s fs1
1911 else if wrd1 .&. wordMask /= wordPat
2033 else if wrd1 .&. wordMask /= wordPat
1912 then skip $ SplitOnSuffixSeqWordLoop wrd1 s fs1
2034 then skip $ SplitOnSuffixSeqWordLoop wrd1 s fs1
1913− else do
2035+ else do done fs >>= yieldProceed jump
1914− b <- done fs
1915− let next = SplitOnSuffixSeqWordInit s
1916− skip $ SplitOnSuffixSeqYield b next
1917− FL.Done b ->
2036+ FL.Done b -> yieldProceed jump b
1918− let next = SplitOnSuffixSeqWordInit s
1919− in skip $ SplitOnSuffixSeqYield b next
1920 Skip s -> go SPEC idx wrd s fs
2037 Skip s -> go SPEC idx wrd s fs
1921 Stop -> skip $ SplitOnSuffixSeqWordDone idx fs wrd
2038 Stop -> skip $ SplitOnSuffixSeqWordDone idx fs wrd
1922
2039
@@ -1930,7 +2047,8 @@ splitOnSuffixSeq withSep patArr (Fold fstep initial done) (Stream step state) =
1930 res <- step (adaptState gst) st
2047 res <- step (adaptState gst) st
1931 case res of
2048 case res of
1932 Yield x s -> do
2049 Yield x s -> do
2050+ let jump c = SplitOnSuffixSeqWordInit c s
1933− let wrd1 = addToWord wrd x
2051+ wrd1 = addToWord wrd x
1934 old = (wordMask .&. wrd)
2052 old = (wordMask .&. wrd)
1935 `shiftR` (elemBits * (patLen - 1))
2053 `shiftR` (elemBits * (patLen - 1))
1936 r <-
2054 r <-
@@ -1940,14 +2058,9 @@ splitOnSuffixSeq withSep patArr (Fold fstep initial done) (Stream step state) =
1940 case r of
2058 case r of
1941 FL.Partial fs1 ->
2059 FL.Partial fs1 ->
1942 if wrd1 .&. wordMask == wordPat
2060 if wrd1 .&. wordMask == wordPat
1943− then do
1944− b <- done fs1
2061+ then done fs1 >>= yieldProceed jump
1945− let next = SplitOnSuffixSeqWordInit s
1946− skip $ SplitOnSuffixSeqYield b next
1947 else go SPEC wrd1 s fs1
2062 else go SPEC wrd1 s fs1
1948− FL.Done b ->
2063+ FL.Done b -> yieldProceed jump b
1949− let next = SplitOnSuffixSeqWordInit s
1950− in skip $ SplitOnSuffixSeqYield b next
1951 Skip s -> go SPEC wrd s fs
2064 Skip s -> go SPEC wrd s fs
1952 Stop ->
2065 Stop ->
1953 if wrd .&. wordMask == wordPat
2066 if wrd .&. wordMask == wordPat
@@ -1962,20 +2075,20 @@ splitOnSuffixSeq withSep patArr (Fold fstep initial done) (Stream step state) =
1962 -- General Pattern - Karp Rabin
2075 -- General Pattern - Karp Rabin
1963 -------------------------------
2076 -------------------------------
1964
2077
1965− stepOuter gst (SplitOnSuffixSeqKRInit idx0 st0 rb rh0) = do
2078+ stepOuter gst (SplitOnSuffixSeqKRInit idx0 fs st0 rb rh0) = do
1966 res <- step (adaptState gst) st0
2079 res <- step (adaptState gst) st0
1967 case res of
2080 case res of
1968 Yield x s -> do
2081 Yield x s -> do
1969 rh1 <- liftIO $ RB.unsafeInsert rb rh0 x
2082 rh1 <- liftIO $ RB.unsafeInsert rb rh0 x
1970− fs <- initial
1971 r <- if withSep then fstep fs x else return $ FL.Partial fs
2083 r <- if withSep then fstep fs x else return $ FL.Partial fs
1972 case r of
2084 case r of
1973 FL.Partial fs1 ->
2085 FL.Partial fs1 ->
1974 skip $ SplitOnSuffixSeqKRInit1 fs1 s rb rh1
2086 skip $ SplitOnSuffixSeqKRInit1 fs1 s rb rh1
1975− FL.Done b ->
2087+ FL.Done b -> do
1976− let next = SplitOnSuffixSeqKRInit 0 s rb (RB.startOf rb)
2088+ let rst = RB.startOf rb
1977− in skip $ SplitOnSuffixSeqYield b next
2089+ jump c = SplitOnSuffixSeqKRInit 0 c s rb rst
2090+ yieldProceed jump b
1978− Skip s -> skip $ SplitOnSuffixSeqKRInit idx0 s rb rh0
2091+ Skip s -> skip $ SplitOnSuffixSeqKRInit idx0 fs s rb rh0
1979 Stop -> return Stop
2092 Stop -> return Stop
1980
2093
1981 stepOuter gst (SplitOnSuffixSeqKRInit1 fs0 st0 rb rh0) = do
2094 stepOuter gst (SplitOnSuffixSeqKRInit1 fs0 st0 rb rh0) = do
@@ -2000,10 +2113,10 @@ splitOnSuffixSeq withSep patArr (Fold fstep initial done) (Stream step state) =
2000 then SplitOnSuffixSeqKRCheck fs1 s rb rh1
2113 then SplitOnSuffixSeqKRCheck fs1 s rb rh1
2001 else SplitOnSuffixSeqKRLoop
2114 else SplitOnSuffixSeqKRLoop
2002 fs1 s rb rh1 ringHash
2115 fs1 s rb rh1 ringHash
2003− FL.Done b ->
2116+ FL.Done b -> do
2004− let next = SplitOnSuffixSeqKRInit
2005− 0 st rb (RB.startOf rb)
2117+ let rst = RB.startOf rb
2006− in skip $ SplitOnSuffixSeqYield b next
2118+ jump c = SplitOnSuffixSeqKRInit 0 c s rb rst
2119+ yieldProceed jump b
2007 Skip s -> go SPEC idx rh s fs
2120 Skip s -> go SPEC idx rh s fs
2008 Stop -> do
2121 Stop -> do
2009 -- do not issue a blank segment when we end at pattern
2122 -- do not issue a blank segment when we end at pattern
@@ -2033,10 +2146,10 @@ splitOnSuffixSeq withSep patArr (Fold fstep initial done) (Stream step state) =
2033 if (cksum1 /= patHash)
2146 if (cksum1 /= patHash)
2034 then go SPEC fs1 s rh1 cksum1
2147 then go SPEC fs1 s rh1 cksum1
2035 else skip $ SplitOnSuffixSeqKRCheck fs1 s rb rh1
2148 else skip $ SplitOnSuffixSeqKRCheck fs1 s rb rh1
2036− FL.Done b ->
2149+ FL.Done b -> do
2037− let next = SplitOnSuffixSeqKRInit
2038− 0 st rb (RB.startOf rb)
2150+ let rst = RB.startOf rb
2039− in skip $ SplitOnSuffixSeqYield b next
2151+ jump c = SplitOnSuffixSeqKRInit 0 c s rb rst
2152+ yieldProceed jump b
2040 Skip s -> go SPEC fs s rh cksum
2153 Skip s -> go SPEC fs s rh cksum
2041 Stop ->
2154 Stop ->
2042 if RB.unsafeEqArray rb rh patArr
2155 if RB.unsafeEqArray rb rh patArr
@@ -2051,8 +2164,9 @@ splitOnSuffixSeq withSep patArr (Fold fstep initial done) (Stream step state) =
2051 if RB.unsafeEqArray rb rh patArr
2164 if RB.unsafeEqArray rb rh patArr
2052 then do
2165 then do
2053 r <- done fs
2166 r <- done fs
2054− let next = SplitOnSuffixSeqKRInit 0 st rb (RB.startOf rb)
2167+ let rst = RB.startOf rb
2055− skip $ SplitOnSuffixSeqYield r next
2168+ jump c = SplitOnSuffixSeqKRInit 0 c st rb rst
2169+ yieldProceed jump r
2056 else skip $ SplitOnSuffixSeqKRLoop fs st rb rh patHash
2170 else skip $ SplitOnSuffixSeqKRLoop fs st rb rh patHash
2057
2171
2058 stepOuter _ (SplitOnSuffixSeqKRDone 0 fs _ _) = do
2172 stepOuter _ (SplitOnSuffixSeqKRDone 0 fs _ _) = do
@@ -2065,9 +2179,8 @@ splitOnSuffixSeq withSep patArr (Fold fstep initial done) (Stream step state) =
2065 case r of
2179 case r of
2066 FL.Partial fs1 -> skip $ SplitOnSuffixSeqKRDone (n - 1) fs1 rb rh1
2180 FL.Partial fs1 -> skip $ SplitOnSuffixSeqKRDone (n - 1) fs1 rb rh1
2067 FL.Done b -> do
2181 FL.Done b -> do
2068− fs1 <- initial
2069− let next = SplitOnSuffixSeqKRDone (n - 1) fs1 rb rh1
2182+ let jump c = SplitOnSuffixSeqKRDone (n - 1) c rb rh1
2070− skip $ SplitOnSuffixSeqYield b next
2183+ yieldProceed jump b
2071
2184
2072------------------------------------------------------------------------------
2185------------------------------------------------------------------------------
2073-- Nested Container Transformation
2186-- Nested Container Transformation
src/Streamly/Internal/Data/Stream/StreamD/Transform.hs+59−22
@@ -258,12 +258,15 @@ tap (Fold fstep initial extract) (Stream step state) = Stream step' TapInit
258 where
258 where
259
259
260 step' _ TapInit = do
260 step' _ TapInit = do
261− r <- initial
261+ res <- initial
262− return $ Skip (Tapping r state)
262+ return
263+ $ Skip
264+ $ case res of
265+ FL.Partial s -> Tapping s state
266+ FL.Done _ -> TapDone state
263 step' gst (Tapping acc st) = do
267 step' gst (Tapping acc st) = do
264 r <- step gst st
268 r <- step gst st
265 case r of
269 case r of
266− -- XXX Abstract Yield?
267 Yield x s -> do
270 Yield x s -> do
268 res <- fstep acc x
271 res <- fstep acc x
269 return
272 return
@@ -299,8 +302,12 @@ tapOffsetEvery offset n (Fold fstep initial extract) (Stream step state) =
299
302
300 {-# INLINE_LATE step' #-}
303 {-# INLINE_LATE step' #-}
301 step' _ TapOffInit = do
304 step' _ TapOffInit = do
302− r <- initial
305+ res <- initial
306+ return
307+ $ Skip
308+ $ case res of
303− return $ Skip $ TapOffTapping r state (offset `mod` n)
309+ FL.Partial s -> TapOffTapping s state (offset `mod` n)
310+ FL.Done _ -> TapOffDone state
304 step' gst (TapOffTapping acc st count) = do
311 step' gst (TapOffTapping acc st count) = do
305 r <- step gst st
312 r <- step gst st
306 case r of
313 case r of
@@ -478,35 +485,65 @@ tapAsync f (Stream step1 state1) = Stream step TapInit
478-- Scanning with a Fold
485-- Scanning with a Fold
479------------------------------------------------------------------------------
486------------------------------------------------------------------------------
480
487
481−data PostScanState s f = PostScan s !f
488+data ScanState s f = ScanInit s | ScanDo s !f | ScanDone
482
489
483{-# INLINE_NORMAL postscanOnce #-}
490{-# INLINE_NORMAL postscanOnce #-}
484postscanOnce :: Monad m => FL.Fold m a b -> Stream m a -> Stream m b
491postscanOnce :: Monad m => FL.Fold m a b -> Stream m a -> Stream m b
485−postscanOnce (FL.Fold fstep begin done) (Stream step state) =
492+postscanOnce (FL.Fold fstep initial extract) (Stream sstep state) =
486− Stream step' (PostScan state begin)
493+ Stream step (ScanInit state)
487
494
488 where
495 where
489
496
490− {-# INLINE_LATE step' #-}
497+ {-# INLINE_LATE step #-}
491− step' gst (PostScan st acc) = do
498+ step _ (ScanInit st) = do
499+ res <- initial
500+ return
501+ $ case res of
502+ FL.Partial fs -> Skip $ ScanDo st fs
503+ FL.Done b -> Yield b ScanDone
504+ step gst (ScanDo st fs) = do
492− r <- step (adaptState gst) st
505+ res <- sstep (adaptState gst) st
493− case r of
506+ case res of
494 Yield x s -> do
507 Yield x s -> do
495− old <- acc
496− res <- fstep old x
508+ r <- fstep fs x
497− case res of
509+ case r of
498− FL.Partial fs -> do
510+ FL.Partial fs1 -> do
499− !v <- done fs
511+ !b <- extract fs1
500− return $ Yield v $ PostScan s (return fs)
512+ return $ Yield b $ ScanDo s fs1
501− FL.Done _ -> return Stop
513+ FL.Done b -> return $ Yield b ScanDone
502− Skip s -> return $ Skip $ PostScan s acc
514+ Skip s -> return $ Skip $ ScanDo s fs
503 Stop -> return Stop
515 Stop -> return Stop
516+ step _ ScanDone = return Stop
504
517
505{-# INLINE scanOnce #-}
518{-# INLINE scanOnce #-}
506scanOnce :: Monad m
519scanOnce :: Monad m
507 => FL.Fold m a b -> Stream m a -> Stream m b
520 => FL.Fold m a b -> Stream m a -> Stream m b
508−scanOnce fld@(FL.Fold _ begin done) s =
521+scanOnce (FL.Fold fstep initial extract) (Stream sstep state) =
509− (begin >>= \x -> x `seq` done x) `consM` postscanOnce fld s
522+ Stream step (ScanInit state)
523+
524+ where
525+
526+ {-# INLINE_LATE step #-}
527+ step _ (ScanInit st) = do
528+ res <- initial
529+ case res of
530+ FL.Partial fs -> do
531+ !b <- extract fs
532+ return $ Yield b $ ScanDo st fs
533+ FL.Done b -> return $ Yield b ScanDone
534+ step gst (ScanDo st fs) = do
535+ res <- sstep (adaptState gst) st
536+ case res of
537+ Yield x s -> do
538+ r <- fstep fs x
539+ case r of
540+ FL.Partial fs1 -> do
541+ !b <- extract fs1
542+ return $ Yield b $ ScanDo s fs1
543+ FL.Done b -> return $ Yield b ScanDone
544+ Skip s -> return $ Skip $ ScanDo s fs
545+ Stop -> return Stop
546+ step _ ScanDone = return Stop
510
547
511------------------------------------------------------------------------------
548------------------------------------------------------------------------------
512-- Scanning - Prescans
549-- Scanning - Prescans
src/Streamly/Internal/Data/Stream/StreamD/Type.hs+76−26
@@ -388,8 +388,11 @@ toStreamD = fromStreamK . K.toStream
388
388
389{-# INLINE_NORMAL foldOnce #-}
389{-# INLINE_NORMAL foldOnce #-}
390foldOnce :: (Monad m) => Fold m a b -> Stream m a -> m b
390foldOnce :: (Monad m) => Fold m a b -> Stream m a -> m b
391−foldOnce (Fold fstep begin done) (Stream step state) =
391+foldOnce (Fold fstep begin done) (Stream step state) = do
392+ res <- begin
393+ case res of
392− begin >>= \x -> go SPEC x state
394+ FL.Partial fs -> go SPEC fs state
395+ FL.Done fb -> return fb
393
396
394 where
397 where
395
398
@@ -942,6 +945,15 @@ data GroupState s fs b a
942 | GroupYield b (GroupState s fs b a)
945 | GroupYield b (GroupState s fs b a)
943 | GroupFinish
946 | GroupFinish
944
947
948+-- | This is the stream equivalent of "Data.Fold.Internal.many". The fold
949+-- may consume 0 or more elements. It means:
950+--
951+-- * If the stream is empty the default value of the fold would still be
952+-- emitted in the output.
953+-- * At the end of the stream if the last application of the fold did not
954+-- receive any input it would still yield the default fold accumulator as the
955+-- last value.
956+--
945{-# INLINE_NORMAL foldMany #-}
957{-# INLINE_NORMAL foldMany #-}
946foldMany :: Monad m => Fold m a b -> Stream m a -> Stream m b
958foldMany :: Monad m => Fold m a b -> Stream m a -> Stream m b
947foldMany (Fold fstep initial extract) (Stream step state) =
959foldMany (Fold fstep initial extract) (Stream step state) =
@@ -951,16 +963,21 @@ foldMany (Fold fstep initial extract) (Stream step state) =
951
963
952 {-# INLINE_LATE step' #-}
964 {-# INLINE_LATE step' #-}
953 step' _ (GroupStart st) = do
965 step' _ (GroupStart st) = do
954− -- fs = fold state
955− fs <- initial
966+ r <- initial
956− return $ Skip (GroupBuffer st fs)
967+ return
968+ $ Skip
969+ $ case r of
970+ FL.Done b -> GroupYield b (GroupStart st)
971+ FL.Partial fs -> GroupBuffer st fs
957 -- This state is not strictly required but it helps the compiler fuse the
972 -- This state is not strictly required but it helps the compiler fuse the
958 -- code.
973 -- code.
959 step' _ (GroupConsume st fs x) = do
974 step' _ (GroupConsume st fs x) = do
960− fs' <- fstep fs x
975+ r <- fstep fs x
976+ return
977+ $ Skip
961− case fs' of
978+ $ case r of
962− FL.Done b -> return $ Skip (GroupYield b (GroupStart st))
979+ FL.Done b -> GroupYield b (GroupStart st)
963− FL.Partial ps -> return $ Skip (GroupBuffer st ps)
980+ FL.Partial fs1 -> GroupBuffer st fs1
964 step' gst (GroupBuffer st fs) = do
981 step' gst (GroupBuffer st fs) = do
965 r <- step (adaptState gst) st
982 r <- step (adaptState gst) st
966 case r of
983 case r of
@@ -972,37 +989,70 @@ foldMany (Fold fstep initial extract) (Stream step state) =
972 step' _ (GroupYield b next) = return $ Yield b next
989 step' _ (GroupYield b next) = return $ Yield b next
973 step' _ GroupFinish = return Stop
990 step' _ GroupFinish = return Stop
974
991
992+{-# ANN type FoldMany1 Fuse #-}
993+data FoldMany1 s fs b a
994+ = FoldMany1Start s
995+ | FoldMany1First fs s
996+ | FoldMany1Consume s fs a
997+ | FoldMany1Gen s fs
998+ | FoldMany1Yield b (FoldMany1 s fs b a)
999+ | FoldMany1Done
1000+
1001+-- | Like 'foldMany' except that the fold consumes 1 or more elements. It
1002+-- means:
1003+--
1004+-- * If the stream is empty the output would be empty.
1005+-- * At the end of the stream if the last application of the fold did not
1006+-- receive any input it would not result in any output.
1007+--
1008+-- @foldMany1 f = parseMany (fromFold f)@
1009+--
1010+-- This could be problematic unless we use an accumulator fold instead of a
1011+-- terminating fold. A terminating fold may terminate even without accepting a
1012+-- single element. We can use parseMany instead where we can return the input
1013+-- if the fold terminates without accepting any input. The alternative is to
1014+-- always execute the fold's initial action and discard it in case the stream
1015+-- stops without actually feeding input to it.
1016+--
975{-# INLINE_NORMAL foldMany1 #-}
1017{-# INLINE_NORMAL foldMany1 #-}
976foldMany1 :: Monad m => Fold m a b -> Stream m a -> Stream m b
1018foldMany1 :: Monad m => Fold m a b -> Stream m a -> Stream m b
977foldMany1 (Fold fstep initial extract) (Stream step state) =
1019foldMany1 (Fold fstep initial extract) (Stream step state) =
978− Stream step' (GroupStart state)
1020+ Stream step' (FoldMany1Start state)
979
1021
980 where
1022 where
981
1023
982 {-# INLINE_LATE step' #-}
1024 {-# INLINE_LATE step' #-}
983− step' gst (GroupStart st) = do
1025+ step' _ (FoldMany1Start st) = do
1026+ r <- initial
1027+ return
1028+ $ Skip
1029+ $ case r of
1030+ FL.Done b -> FoldMany1Yield b (FoldMany1Start st)
1031+ FL.Partial fs -> FoldMany1First fs st
1032+ step' gst (FoldMany1First fs st) = do
984 r <- step (adaptState gst) st
1033 r <- step (adaptState gst) st
985 case r of
1034 case r of
986 Yield x s -> do
1035 Yield x s -> do
987− fi <- initial
988− return $ Skip $ GroupConsume s fi x
1036+ return $ Skip $ FoldMany1Consume s fs x
989− Skip s -> return $ Skip (GroupStart s)
1037+ Skip s -> return $ Skip (FoldMany1Start s)
990− Stop -> return $ Stop
1038+ Stop -> return Stop
991− step' _ (GroupConsume st fs x) = do
1039+ step' _ (FoldMany1Consume st fs x) = do
992− fs' <- fstep fs x
1040+ r <- fstep fs x
1041+ return
1042+ $ Skip
993− case fs' of
1043+ $ case r of
994− FL.Done b -> return $ Skip (GroupYield b (GroupStart st))
1044+ FL.Done b -> FoldMany1Yield b (FoldMany1Start st)
995− FL.Partial ps -> return $ Skip (GroupBuffer st ps)
1045+ FL.Partial fs1 -> FoldMany1Gen st fs1
996− step' gst (GroupBuffer st fs) = do
1046+ step' gst (FoldMany1Gen st fs) = do
997 r <- step (adaptState gst) st
1047 r <- step (adaptState gst) st
998 case r of
1048 case r of
999− Yield x s -> return $ Skip $ GroupConsume s fs x
1049+ Yield x s -> return $ Skip $ FoldMany1Consume s fs x
1000− Skip s -> return $ Skip (GroupBuffer s fs)
1050+ Skip s -> return $ Skip (FoldMany1Gen s fs)
1001 Stop -> do
1051 Stop -> do
1002 b <- extract fs
1052 b <- extract fs
1003− return $ Skip (GroupYield b GroupFinish)
1053+ return $ Skip (FoldMany1Yield b FoldMany1Done)
1004− step' _ (GroupYield b next) = return $ Yield b next
1054+ step' _ (FoldMany1Yield b next) = return $ Yield b next
1005− step' _ GroupFinish = return Stop
1055+ step' _ FoldMany1Done = return Stop
1006
1056
1007data GroupState2 s fs
1057data GroupState2 s fs
1008 = GroupStart2 s
1058 = GroupStart2 s
src/Streamly/Internal/Data/Stream/StreamK.hs+10−7
@@ -436,19 +436,22 @@ foldlMx' step begin done m = go begin m
436
436
437{-# INLINABLE foldOnce #-}
437{-# INLINABLE foldOnce #-}
438foldOnce :: (IsStream t, Monad m) => FL.Fold m a b -> t m a -> m b
438foldOnce :: (IsStream t, Monad m) => FL.Fold m a b -> t m a -> m b
439−foldOnce (FL.Fold step begin done) = go begin
439+foldOnce (FL.Fold step begin done) m = do
440+ res <- begin
441+ case res of
442+ FL.Partial fs -> go fs m
443+ FL.Done fb -> return fb
444+
440 where
445 where
441 go !acc m1 =
446 go !acc m1 =
442− let stop = acc >>= done
447+ let stop = done acc
443− single a = acc
448+ single a = step acc a
444− >>= \b -> step b a
445 >>= \case
449 >>= \case
446 FL.Partial s -> done s
450 FL.Partial s -> done s
447 FL.Done b1 -> return b1
451 FL.Done b1 -> return b1
448− yieldk a r = acc
452+ yieldk a r = step acc a
449− >>= \b -> step b a
450 >>= \case
453 >>= \case
451− FL.Partial s -> go (return s) r
454+ FL.Partial s -> go s r
452 FL.Done b1 -> return b1
455 FL.Done b1 -> return b1
453 in foldStream defState yieldk single stop m1
456 in foldStream defState yieldk single stop m1
454
457
src/Streamly/Internal/Data/Unfold.hs+5−2
@@ -276,8 +276,11 @@ swap = lmap Tuple.swap
276--
276--
277{-# INLINE_NORMAL fold #-}
277{-# INLINE_NORMAL fold #-}
278fold :: Monad m => Unfold m a b -> Fold m b c -> a -> m c
278fold :: Monad m => Unfold m a b -> Fold m b c -> a -> m c
279−fold (Unfold ustep inject) (Fold fstep initial extract) a =
279+fold (Unfold ustep inject) (Fold fstep initial extract) a = do
280+ res <- initial
281+ case res of
280− initial >>= \x -> inject a >>= go SPEC x
282+ FL.Partial x -> inject a >>= go SPEC x
283+ FL.Done b -> return b
281
284
282 where
285 where
283
286
src/Streamly/Internal/FileSystem/File.hs+5−2
@@ -357,13 +357,16 @@ writeChunks path = Fold step initial extract
357 h <- liftIO (openFile path WriteMode)
357 h <- liftIO (openFile path WriteMode)
358 fld <- FL.initialize (FH.writeChunks h)
358 fld <- FL.initialize (FH.writeChunks h)
359 `MC.onException` liftIO (hClose h)
359 `MC.onException` liftIO (hClose h)
360− return (fld, h)
360+ return $ FL.Partial (fld, h)
361 step (fld, h) x = do
361 step (fld, h) x = do
362 r <- FL.runStep fld x `MC.onException` liftIO (hClose h)
362 r <- FL.runStep fld x `MC.onException` liftIO (hClose h)
363 return $ FL.Partial (r, h)
363 return $ FL.Partial (r, h)
364 extract (Fold _ initial1 extract1, h) = do
364 extract (Fold _ initial1 extract1, h) = do
365 liftIO $ hClose h
365 liftIO $ hClose h
366− initial1 >>= extract1
366+ res <- initial1
367+ case res of
368+ FL.Partial fs -> extract1 fs
369+ FL.Done fb -> return fb
367
370
368-- | @writeWithBufferOf chunkSize handle@ writes the input stream to @handle@.
371-- | @writeWithBufferOf chunkSize handle@ writes the input stream to @handle@.
369-- Bytes in the input stream are collected into a buffer until we have a chunk
372-- Bytes in the input stream are collected into a buffer until we have a chunk
src/Streamly/Internal/Network/Inet/TCP.hs+5−2
@@ -357,13 +357,16 @@ writeChunks addr port = Fold step initial extract
357 initial = do
357 initial = do
358 skt <- liftIO (connect addr port)
358 skt <- liftIO (connect addr port)
359 fld <- FL.initialize (SK.writeChunks skt) `MC.onException` liftIO (Net.close skt)
359 fld <- FL.initialize (SK.writeChunks skt) `MC.onException` liftIO (Net.close skt)
360− return (Tuple' fld skt)
360+ return $ FL.Partial (Tuple' fld skt)
361 step (Tuple' fld skt) x = do
361 step (Tuple' fld skt) x = do
362 r <- FL.runStep fld x `MC.onException` liftIO (Net.close skt)
362 r <- FL.runStep fld x `MC.onException` liftIO (Net.close skt)
363 return $ FL.Partial (Tuple' r skt)
363 return $ FL.Partial (Tuple' r skt)
364 extract (Tuple' (Fold _ initial1 extract1) skt) = do
364 extract (Tuple' (Fold _ initial1 extract1) skt) = do
365 liftIO $ Net.close skt
365 liftIO $ Net.close skt
366− initial1 >>= extract1
366+ res <- initial1
367+ case res of
368+ FL.Partial fs -> extract1 fs
369+ FL.Done fb -> return fb
367
370
368-- | Like 'write' but provides control over the write buffer. Output will
371-- | Like 'write' but provides control over the write buffer. Output will
369-- be written to the IO device as soon as we collect the specified number of
372-- be written to the IO device as soon as we collect the specified number of
test/Streamly/Test/Data/Parser.hs+19−30
@@ -7,7 +7,7 @@ import Test.Hspec (Spec, hspec, describe)
7import Test.Hspec.QuickCheck
7import Test.Hspec.QuickCheck
8import Test.QuickCheck
8import Test.QuickCheck
9 (arbitrary, forAll, elements, Property, property, listOf,
9 (arbitrary, forAll, elements, Property, property, listOf,
10− vectorOf, Gen, suchThat)
10+ vectorOf, Gen)
11import Test.QuickCheck.Monadic (monadicIO, assert, run)
11import Test.QuickCheck.Monadic (monadicIO, assert, run)
12
12
13import Prelude hiding (sequence)
13import Prelude hiding (sequence)
@@ -490,9 +490,9 @@ many :: Property
490many =
490many =
491 forAll (listOf (chooseInt (0, 1))) $ \ls ->
491 forAll (listOf (chooseInt (0, 1))) $ \ls ->
492 let fldstp conL currL = return $ FL.Partial $ conL ++ currL
492 let fldstp conL currL = return $ FL.Partial $ conL ++ currL
493− concatFold = FL.Fold fldstp (return []) return
493+ concatFold = FL.Fold fldstp (return (FL.Partial [])) return
494− prsr = P.many concatFold
494+ prsr =
495− $ P.fromFold $ FL.sliceSepBy (== 1) FL.toList
495+ P.many concatFold $ P.fromFold $ FL.sliceSepBy (== 1) FL.toList
496 in
496 in
497 case S.parse prsr (S.fromList ls) of
497 case S.parse prsr (S.fromList ls) of
498 Right res_list -> checkListEqual res_list
498 Right res_list -> checkListEqual res_list
@@ -510,13 +510,10 @@ some =
510 forAll (listOf (chooseInt (0, 1))) $ \genLs ->
510 forAll (listOf (chooseInt (0, 1))) $ \genLs ->
511 let
511 let
512 ls = 0 : genLs
512 ls = 0 : genLs
513+ fldstp conL currL = return $ FL.Partial $ conL ++ currL
513− concatFold = FL.Fold
514+ concatFold = FL.Fold fldstp (return (FL.Partial [])) return
514− (\concatList curr_list ->
515+ prsr =
515− return $ FL.Partial $ concatList ++ curr_list)
516− (return [])
517− return
518− prsr = P.some concatFold
519− $ P.fromFold $ FL.sliceSepBy (== 1) FL.toList
516+ P.some concatFold $ P.fromFold $ FL.sliceSepBy (== 1) FL.toList
520 in
517 in
521 case S.parse prsr (S.fromList ls) of
518 case S.parse prsr (S.fromList ls) of
522 Right res_list -> res_list == Prelude.filter (== 0) ls
519 Right res_list -> res_list == Prelude.filter (== 0) ls
@@ -532,11 +529,9 @@ some =
532-- Instances
529-- Instances
533-------------------------------------------------------------------------------
530-------------------------------------------------------------------------------
534
531
535−-- XXX Remove "`suchThat` (\x -> length x > 0)) $ \ list1 ->" once FL.ltake is
536−-- fixed.
537applicative :: Property
532applicative :: Property
538applicative =
533applicative =
539− forAll (listOf (chooseAny :: Gen Int) `suchThat` (\x -> length x > 0)) $ \ list1 ->
534+ forAll (listOf (chooseAny :: Gen Int)) $ \ list1 ->
540 forAll (listOf (chooseAny :: Gen Int)) $ \ list2 ->
535 forAll (listOf (chooseAny :: Gen Int)) $ \ list2 ->
541 let parser =
536 let parser =
542 (,)
537 (,)
@@ -548,32 +543,26 @@ applicative =
548 listEquals (==) olist1 list1
543 listEquals (==) olist1 list1
549 listEquals (==) olist2 list2
544 listEquals (==) olist2 list2
550
545
551−-- XXX Remove "`suchThat` (\x -> length x > 0)) $ \ list1 ->" once FL.ltake is
552−-- fixed.
553sequence :: Property
546sequence :: Property
554sequence =
547sequence =
555− forAll (vectorOf 11 (listOf (chooseAny :: Gen Int) `suchThat`
548+ forAll (vectorOf 11 (listOf (chooseAny :: Gen Int))) $ \ ins ->
556− (\x -> length x > 0))) $ \ ins ->
557− let p xs = P.fromFold (FL.ltake (length xs) FL.toList)
549+ let p xs = P.fromFold (FL.ltake (length xs) FL.toList)
558− in monadicIO $ do
550+ in monadicIO $ do
559 outs <- run $
551 outs <- run $
560 S.parse
552 S.parse
561 (Prelude.sequence $ fmap p ins)
553 (Prelude.sequence $ fmap p ins)
562 (S.fromList $ concat ins)
554 (S.fromList $ concat ins)
563 listEquals (==) outs ins
555 listEquals (==) outs ins
564
556
565−-- XXX Remove "`suchThat` (\x -> length x > 0)) $ \ list1 ->" once FL.ltake is
566−-- fixed.
567monad :: Property
557monad :: Property
568monad =
558monad =
569− forAll (listOf (chooseAny :: Gen Int) `suchThat`
559+ forAll (listOf (chooseAny :: Gen Int)) $ \ list1 ->
570− (\x -> length x > 0)) $ \ list1 ->
560+ forAll (listOf (chooseAny :: Gen Int)) $ \ list2 ->
571− forAll (listOf (chooseAny :: Gen Int)) $ \ list2 ->
572− let parser = do
561+ let parser = do
573− olist1 <- P.fromFold (FL.ltake (length list1) FL.toList)
562+ olist1 <- P.fromFold (FL.ltake (length list1) FL.toList)
574− olist2 <- P.fromFold (FL.ltake (length list2) FL.toList)
563+ olist2 <- P.fromFold (FL.ltake (length list2) FL.toList)
575− return (olist1, olist2)
564+ return (olist1, olist2)
576− in monadicIO $ do
565+ in monadicIO $ do
577 (olist1, olist2) <-
566 (olist1, olist2) <-
578 run $ S.parse parser (S.fromList $ list1 ++ list2)
567 run $ S.parse parser (S.fromList $ list1 ++ list2)
579 listEquals (==) olist1 list1
568 listEquals (==) olist1 list1
test/Streamly/Test/Data/Parser/ParserD.hs+12−14
@@ -7,7 +7,7 @@ import Test.Hspec (Spec, hspec, describe)
7import Test.Hspec.QuickCheck
7import Test.Hspec.QuickCheck
8import Test.QuickCheck
8import Test.QuickCheck
9 (arbitrary, forAll, elements, Property,
9 (arbitrary, forAll, elements, Property,
10− property, listOf, vectorOf, (.&&.), Gen, suchThat)
10+ property, listOf, vectorOf, (.&&.), Gen)
11import Test.QuickCheck.Monadic (monadicIO, assert, run)
11import Test.QuickCheck.Monadic (monadicIO, assert, run)
12
12
13import qualified Data.List as List
13import qualified Data.List as List
@@ -492,8 +492,10 @@ many =
492 $ \ls ->
492 $ \ls ->
493 let fldstp conL currL = return $ FL.Partial (conL ++ currL)
493 let fldstp conL currL = return $ FL.Partial (conL ++ currL)
494 concatFold =
494 concatFold =
495− FL.Fold fldstp (return []) return
495+ FL.Fold fldstp (return (FL.Partial [])) return
496+ prsr =
497+ P.many concatFold
496− prsr = P.many concatFold $ P.fromFold $ FL.sliceSepBy (== 1) FL.toList
498+ $ P.fromFold $ FL.sliceSepBy (== 1) FL.toList
497 in case S.parseD prsr (S.fromList ls) of
499 in case S.parseD prsr (S.fromList ls) of
498 Right res_list ->
500 Right res_list ->
499 checkListEqual res_list (Prelude.filter (== 0) ls)
501 checkListEqual res_list (Prelude.filter (== 0) ls)
@@ -510,8 +512,10 @@ some =
510 forAll (listOf (chooseInt (0, 1)))
512 forAll (listOf (chooseInt (0, 1)))
511 $ \ls ->
513 $ \ls ->
512 let fldstp conL currL = return $ FL.Partial $ conL ++ currL
514 let fldstp conL currL = return $ FL.Partial $ conL ++ currL
513− concatFold = FL.Fold fldstp (return []) return
515+ concatFold = FL.Fold fldstp (return (FL.Partial [])) return
516+ prsr =
517+ P.some concatFold
514− prsr = P.some concatFold $ P.fromFold $ FL.sliceSepBy (== 1) FL.toList
518+ $ P.fromFold $ FL.sliceSepBy (== 1) FL.toList
515 in case S.parseD prsr (S.fromList ls) of
519 in case S.parseD prsr (S.fromList ls) of
516 Right res_list -> res_list == Prelude.filter (== 0) ls
520 Right res_list -> res_list == Prelude.filter (== 0) ls
517 Left _ -> False
521 Left _ -> False
@@ -526,11 +530,9 @@ someFail =
526-- Instances
530-- Instances
527-------------------------------------------------------------------------------
531-------------------------------------------------------------------------------
528
532
529−-- XXX Remove "`suchThat` (\x -> length x > 0)) $ \ list1 ->" once FL.ltake is
530−-- fixed.
531applicative :: Property
533applicative :: Property
532applicative =
534applicative =
533− forAll (listOf (chooseAny :: Gen Int) `suchThat` (\x -> length x > 0)) $ \ list1 ->
535+ forAll (listOf (chooseAny :: Gen Int)) $ \ list1 ->
534 forAll (listOf (chooseAny :: Gen Int)) $ \ list2 ->
536 forAll (listOf (chooseAny :: Gen Int)) $ \ list2 ->
535 let parser =
537 let parser =
536 (,)
538 (,)
@@ -542,11 +544,9 @@ applicative =
542 listEquals (==) olist1 list1
544 listEquals (==) olist1 list1
543 listEquals (==) olist2 list2
545 listEquals (==) olist2 list2
544
546
545−-- XXX Remove "`suchThat` (\x -> length x > 0)) $ \ list1 ->" once FL.ltake is
546−-- fixed.
547sequence :: Property
547sequence :: Property
548sequence =
548sequence =
549− forAll (vectorOf 11 (listOf (chooseAny :: Gen Int) `suchThat` (\x -> length x > 0))) $ \ ins ->
549+ forAll (vectorOf 11 (listOf (chooseAny :: Gen Int))) $ \ ins ->
550 let parsers = fmap (\xs -> P.fromFold $ FL.ltake (length xs) FL.toList) ins
550 let parsers = fmap (\xs -> P.fromFold $ FL.ltake (length xs) FL.toList) ins
551 in monadicIO $ do
551 in monadicIO $ do
552 outs <- run $
552 outs <- run $
@@ -555,11 +555,9 @@ sequence =
555 (S.fromList $ concat ins)
555 (S.fromList $ concat ins)
556 listEquals (==) outs ins
556 listEquals (==) outs ins
557
557
558−-- XXX Remove "`suchThat` (\x -> length x > 0)) $ \ list1 ->" once FL.ltake is
559−-- fixed.
560monad :: Property
558monad :: Property
561monad =
559monad =
562− forAll (listOf (chooseAny :: Gen Int) `suchThat` (\x -> length x > 0)) $ \ list1 ->
560+ forAll (listOf (chooseAny :: Gen Int)) $ \ list1 ->
563 forAll (listOf (chooseAny :: Gen Int)) $ \ list2 ->
561 forAll (listOf (chooseAny :: Gen Int)) $ \ list2 ->
564 let parser = do
562 let parser = do
565 olist1 <- P.fromFold (FL.ltake (length list1) FL.toList)
563 olist1 <- P.fromFold (FL.ltake (length list1) FL.toList)
test/lib/Streamly/Test/Prelude/Common.hs+2−2
@@ -1168,8 +1168,8 @@ transformCombineOpsCommon constr desc eq t = do
1168 withMaxSuccess maxTestCount $
1168 withMaxSuccess maxTestCount $
1169 monadicIO $ do
1169 monadicIO $ do
1170 cref <- run $ newIORef 0
1170 cref <- run $ newIORef 0
1171− let fldstp _ e = FL.Partial <$> modifyIORef' cref (e+)
1171+ let fldstp _ e = modifyIORef' cref (e +)
1172− sumfoldinref = FL.Fold fldstp (return ()) (const $ return ())
1172+ sumfoldinref = FL.mkAccumM_ fldstp (return ())
1173 op = S.tap sumfoldinref . S.mapM (\x -> return (x+1))
1173 op = S.tap sumfoldinref . S.mapM (\x -> return (x+1))
1174 listOp = fmap (+1)
1174 listOp = fmap (+1)
1175 stream <- run ((S.toList . t) $ op (constr a <> constr b))
1175 stream <- run ((S.toList . t) $ op (constr a <> constr b))