foldl-transduce 0.2.1.0 → 0.3.0.0

raw patch · 7 files changed

+576/−201 lines, 7 filesdep +freedep +monoid-subclassesPVP ok

version bump matches the API change (PVP)

Dependencies added: free, monoid-subclasses

API changes (from Hackage documentation)

Files

• CHANGELOG +11/−0
• README.md +2/−5
• foldl-transduce.cabal +9/−5
• src/Control/Foldl/Transduce.hs +518/−178
• src/Control/Foldl/Transduce/Internal.hs +2/−2
• src/Control/Foldl/Transduce/Text.hs +12/−11
• tests/tests.hs +22/−0

@@ -1,3 +1,14 @@+# 0.3.0.0++- Transducers can now delimit segments in the done function, too.+  This was required for transducers like surround to work as splitters.+- Strengthened the constraints on the surround function to Traversable.+- Added dependency on free and monoid-subclasses.+- group functions can now treat each group differently.+- Added ignore, splitAt, splitWhen, splitLast+- removed drop, take... use splitAt, splitWhen + bisect.+- Added bisect, evenly convenience functions.+ # 0.2.1.0  - Comonad and Extend instances for Transducer 

@@ -29,8 +29,5 @@ - You can't perform bracketing operations like "withFile" that span the folding   of an entire group. pipes-group allows them. -- There doesn't seem to be a way to just take the first N groups in a stream-  and afterwards rejoin them.--- You have more flexibility in pipes-group to decide how to fold a group based-  on previous results.+- You have more flexibility in pipes-group to decide how to delimit and fold+  the next group based on previous results.

@@ -1,5 +1,5 @@ Name: foldl-transduce-Version: 0.2.1.0+Version: 0.3.0.0 Cabal-Version: >=1.8.0.2 Build-Type: Simple License: BSD3@@ -9,7 +9,7 @@ Maintainer: diaz_carrete@yahoo.com Bug-Reports: https://github.com/danidiaz/foldl-transduce/issues Synopsis: Transducers for foldl folds.-Description: Stateful transducers and streaming-preserving grouping operations for the folds in the foldl package.+Description: Stateful transducers and streaming-preserving grouping operations for foldl folds. Category: Control  Extra-Source-Files:@@ -31,7 +31,9 @@         bifunctors    == 5.*               ,         semigroupoids >= 5.0               ,         foldl         >= 1.1      && < 2   ,-        comonad       == 4.*+        comonad       == 4.*               ,+        free          == 4.*               ,         +        monoid-subclasses == 0.4.*              Exposed-Modules:         Control.Foldl.Transduce,         Control.Foldl.Transduce.Text,@@ -45,8 +47,9 @@   main-is:        doctests.hs    build-depends:-        base >= 4.4 && < 5-      , doctest >= 0.10.1+        base          >= 4.4 && < 5+      , free          == 4.*+      , doctest       >= 0.10.1  test-suite tests   type:           exitcode-stdio-1.0@@ -58,6 +61,7 @@         text                ,         tasty >= 0.10.1.1   ,         tasty-hunit >= 0.9.2,+        monoid-subclasses == 0.4.*,         foldl               ,         foldl-transduce 

@@ -1,5 +1,8 @@ {-# LANGUAGE ExistentialQuantification, RankNTypes #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-}  -- |@@ -12,66 +15,99 @@         Transduction      ,   Transduction'      ,   Transducer(..)+    ,   ToTransducer(..)+        -- ** Monadic transducer types     ,   TransductionM     ,   TransductionM'     ,   TransducerM(..)+    ,   ToTransducerM(..)         -- * Applying transducers     ,   transduce     ,   transduce'     ,   transduceM     ,   transduceM'-        -- * Working with groups-    ,   groups-    ,   groups'-    ,   groupsM-    ,   groupsM'+    ,   transduceK+        -- * Folding over groups     ,   folds     ,   folds'     ,   foldsM     ,   foldsM'+        -- * Group operations+    ,   Infinite+    ,   ReifiedTransduction (..)+    ,   groups+    ,   evenly+    ,   bisect    +        --+    ,   Moore+    ,   ReifiedTransduction' (..)+    ,   groups'+    ,   evenly'+        -- ** Monadic group operations+    ,   ReifiedTransductionM (..)+    ,   groupsM+    ,   evenlyM+    ,   bisectM+        --+    ,   ReifiedTransductionM' (..)+    ,   groupsM'+    ,   evenlyM'         -- * Transducers-    ,   take-    ,   takeWhile-    ,   drop-    ,   dropWhile+    ,   ignore     ,   surround     ,   surroundIO         -- * Splitters     ,   chunksOf+    ,   splitAt+    ,   chunkedSplitAt+    ,   splitWhen+    ,   splitLast+    ,   chunkedStripPrefix         -- * Transducer utilities-    ,   _generalize-    ,   _simplify     ,   foldify     ,   foldifyM+    ,   condense+    ,   condenseM     ,   hoistTransducer+        -- * Fold utilities+    ,   quiesce+    ,   quiesceWith     ,   hoistFold         -- * Re-exports         -- $reexports     ,   module Data.Functor.Extend     ,   module Control.Foldl+    ,   module Control.Comonad.Cofree     ) where -import Prelude hiding (take,drop,takeWhile,dropWhile)+import Prelude hiding (take,drop,splitAt,dropWhile)  import Data.Bifunctor import Data.Monoid+import qualified Data.Monoid.Cancellative as CM+import qualified Data.Monoid.Null as NM+import qualified Data.Monoid.Factorial as SFM import Data.Functor.Identity import Data.Functor.Extend import Data.Foldable (Foldable,foldlM,foldl',toList)+import Data.Traversable import Control.Applicative import Control.Monad import Control.Monad.IO.Class+import Control.Monad.Trans.Except import Control.Comonad+import Control.Comonad.Cofree  import Control.Foldl (Fold(..),FoldM(..)) import qualified Control.Foldl as L-import Control.Foldl.Transduce.Internal (Pair(..),Trio(..),_1of3)+import Control.Foldl.Transduce.Internal (Pair(..),Quartet(..),_1of3)  {- $setup  >>> import qualified Control.Foldl as L >>> import Control.Foldl.Transduce >>> import Control.Applicative->>> import Prelude hiding (take,drop,takeWhile,dropWhile)+>>> import qualified Control.Comonad.Cofree as C+>>> import Prelude hiding (splitAt,takeWhile,dropWhile)  -} @@ -104,13 +140,22 @@ -} type Transduction a b = forall x. Fold b x -> Fold a x +{-| Helper for storing a 'Transduction' safely on a container.		 +-}+newtype ReifiedTransduction a b = ReifiedTransduction { getTransduction :: Transduction a b }+ {-| A more general from of 'Transduction' that adds new information to the     return value of the 'Fold'.  -} type Transduction' a b r = forall x. Fold b x -> Fold a (r,x) +{-| Helper for storing a 'ReifiedTransduction' safely on a container.		++-}+newtype ReifiedTransduction' a b r = ReifiedTransduction' { getTransduction' :: Transduction' a b r }+ {-| A stateful process that transforms a stream of inputs into a stream of     outputs, and may optionally demarcate groups in the stream of outputs. @@ -119,23 +164,23 @@     The step function returns a triplet of:      * The new internal state.-    * Outputs that continue the last segment detected in the previous step.-    * A list of lists containing outputs for segments detected in the current+    * List of outputs belonging to the last segment detected in the previous step.+    * A list of lists of outputs belonging to segments detected in the current       step. If the list is empty, that means no splitting has taken place in the       current step. 'Transducer's that do not perform grouping never return anything       other than @[]@ here. In effect, they treat the whole stream as a single group.      The extraction function returns the 'Transducer's own result value, as-    well as any pending outputs.+    well as any pending output. -} data Transducer i o r-     = forall x. Transducer (x -> i -> (x,[o],[[o]])) x (x -> (r,[o]))+     = forall x. Transducer (x -> i -> (x,[o],[[o]])) x (x -> (r,[o],[[o]]))  instance Comonad (Transducer i o) where-    extract (Transducer _ begin done) = fst (done begin)+    extract (Transducer _ begin done) = _1of3 (done begin)     {-# INLINABLE extract #-} -    duplicate (Transducer step begin done) = Transducer step begin (\x -> (Transducer step x done,[]))+    duplicate (Transducer step begin done) = Transducer step begin (\x -> (Transducer step x done,[],[]))     {-# INLINABLE duplicate #-}  instance Extend (Transducer i o) where@@ -143,64 +188,111 @@     {-# INLINABLE duplicated #-}  instance Functor (Transducer i o) where-    fmap f (Transducer step begin done) = Transducer step begin (first f . done)+    fmap f (Transducer step begin done) = +        Transducer +            step +            begin +            ((\(x,xs,xss) -> (f x,xs,xss)) . done)  instance Bifunctor (Transducer i) where     first f (Transducer step begin done) =-        Transducer (fmap (\(x,xs,xss) -> (x,map f xs, map (map f) xss)) . step) begin (fmap (fmap f) . done)+        Transducer +            (fmap (\(x,xs,xss) -> (x,map f xs, map (map f) xss)) . step) +            begin +            ((\(x,xs,xss) -> (x,map f xs, map (map f) xss)) . done)      second f w = fmap f w +{-| Helps converting monadic transducers (over 'Identity') into pure ones.		++-}+class ToTransducer t where+    toTransducer :: t i o r -> Transducer i o r++instance ToTransducer Transducer where+    toTransducer = id++instance ToTransducer (TransducerM Identity) where+    toTransducer = _simplify+ {-| Like 'Transduction', but works on monadic 'Fold's.		  -} type TransductionM m a b = forall x. Monad m => FoldM m b x -> FoldM m a x +{-| Helper for storing a 'TransductionM' safely on a container.		++-}+newtype ReifiedTransductionM m a b = ReifiedTransductionM { getTransductionM :: TransductionM m a b }+ {-| Like 'Transduction'', but works on monadic 'Fold's.		  -} type TransductionM' m a b r = forall x. FoldM m b x -> FoldM m a (r,x) +{-| Helper for storing a 'TransductionM'' safely on a container.		++-}+newtype ReifiedTransductionM' m a b r = ReifiedTransductionM' { getTransductionM' :: TransductionM' m a b r }+ {-| Like 'Transducer', but monadic.  -} data TransducerM m i o r-     = forall x. TransducerM (x -> i -> m (x,[o],[[o]])) (m x) (x -> m (r,[o]))+     = forall x. TransducerM (x -> i -> m (x,[o],[[o]])) (m x) (x -> m (r,[o],[[o]])) + instance Monad m => Functor (TransducerM m i o) where     fmap f (TransducerM step begin done) = TransducerM step begin done'       where         done' x = do-            (r,os) <- done x+            (r,os,oss) <- done x             let r' = f r-            return $! (r' `seq` (r', os))+            return $! (r' `seq` (r',os,oss))  instance (Functor m, Monad m) => Bifunctor (TransducerM m i) where     first f (TransducerM step begin done) =-        TransducerM (fmap (fmap (\(x,xs,xss) -> (x,map f xs, map (map f) xss))) . step) begin (fmap (fmap (fmap f)) . done)+        TransducerM +        (fmap (fmap (\(x,xs,xss) -> (x,map f xs, map (map f) xss))) . step) +        begin +        (fmap (\(x,xs,xss) -> (x,map f xs, map (map f) xss)) . done)      second f w = fmap f w  instance Monad m => Extend (TransducerM m i o) where     duplicated (TransducerM step begin done) = -        TransducerM step begin (\x -> return $! (TransducerM step (return x) done,[]))+        TransducerM step begin (\x -> return $! (TransducerM step (return x) done,[],[]))     {-# INLINABLE duplicated #-} ++{-| Helps converting pure transducers into monadic ones.		++-}+class ToTransducerM m t where+    toTransducerM :: t i o r -> TransducerM m i o r++-- http://chrisdone.com/posts/haskell-constraint-trick+instance (m ~ m') => ToTransducerM m (TransducerM m') where+    toTransducerM = id++instance Monad m => ToTransducerM m Transducer where+    toTransducerM = _generalize+ {-| Apply a 'Transducer' to a 'Fold', discarding the return value of the     'Transducer'.		 ->>> L.fold (transduce (Transducer (\_ i -> ((),[i],[])) () (\_ -> ('r',[]))) L.list) [1..7]+>>> L.fold (transduce (Transducer (\_ i -> ((),[i],[])) () (\_ -> ('r',[],[]))) L.list) [1..7] [1,2,3,4,5,6,7] -}-transduce :: Transducer i o s -> Transduction i o +transduce :: ToTransducer t => t i o s -> Transduction i o  transduce t = fmap snd . (transduce' t)  {-| Generalized version of 'transduce' that preserves the return value of     the 'Transducer'. ->>> L.fold (transduce' (Transducer (\_ i -> ((),[i],[])) () (\_ -> ('r',[]))) L.list) [1..7]+>>> L.fold (transduce' (Transducer (\_ i -> ((),[i],[])) () (\_ -> ('r',[],[]))) L.list) [1..7] ('r',[1,2,3,4,5,6,7]) -}-transduce' :: Transducer i o s -> Transduction' i o s-transduce' (Transducer wstep wstate wdone) (Fold fstep fstate fdone) =+transduce' :: ToTransducer t => t i o s -> Transduction' i o s+transduce' (toTransducer -> Transducer wstep wstate wdone) (Fold fstep fstate fdone) =     Fold step (Pair wstate fstate) done          where             step (Pair ws fs) i = @@ -208,22 +300,22 @@                 in                 Pair ws' (foldl' fstep fs (os ++ mconcat oss))               done (Pair ws fs) = -                let (wr,os) = wdone ws+                let (wr,os,oss) = wdone ws                 in -                (,) wr (fdone (foldl' fstep fs os))+                (,) wr (fdone (foldl' fstep fs (os ++ mconcat oss)))   {-| Like 'transduce', but works on monadic 'Fold's.		  -}-transduceM :: Monad m => TransducerM m i o s -> TransductionM m i o +transduceM :: (Monad m, ToTransducerM m t)  => t i o s -> TransductionM m i o  transduceM t = fmap snd . (transduceM' t)  {-| Like 'transduce'', but works on monadic 'Fold's.		  -}-transduceM' :: Monad m => TransducerM m i o s -> TransductionM' m i o s-transduceM' (TransducerM wstep wstate wdone) (FoldM fstep fstate fdone) =+transduceM' :: (Monad m, ToTransducerM m t)  => t i o s -> TransductionM' m i o s+transduceM' (toTransducerM -> TransducerM wstep wstate wdone) (FoldM fstep fstate fdone) =     FoldM step (liftM2 Pair wstate fstate) done          where             step (Pair ws fs) i = do@@ -231,83 +323,34 @@                 fs' <- foldlM fstep fs (os ++ mconcat oss)                 return $! Pair ws' fs'             done (Pair ws fs) = do-                (wr,os) <- wdone ws-                fr <- fdone =<< foldlM fstep fs os+                (wr,os,oss) <- wdone ws+                fr <- fdone =<< foldlM fstep fs (os ++ mconcat oss)                 return $! (,) wr fr ---------------------------------------------------------------------------------{-| Pass the first @n@ inputs to the 'Fold', and ignore the rest.		-->>> L.fold (transduce (take 2) L.list) [1..5]-[1,2]+{-| Transduce with a Kleisli arrow that returns a list.		 ->>> L.fold (transduce (take 0) L.list) [1..5]-[] -}-take :: Int -> Transducer a a ()-take howmany = -    Transducer step howmany done +transduceK :: (Monad m) => (i -> m [o]) -> TransductionM m i o +transduceK k = transduceM (TransducerM step (return ()) (\_ -> return ((),[],[])))     where-        step howmanypending i -            | howmanypending == 0 = -                (0,[],[])-            | otherwise = -                (pred howmanypending,[i],[]) -        done = const ((),[])+    step _ i = liftM (\os -> ((),os,[])) (k i) -{-| 		 ->>> L.fold (transduce (takeWhile (<3)) L.list) [1..5]-[1,2]--}-takeWhile :: (a -> Bool) -> Transducer a a ()-takeWhile predicate = -    Transducer step False done -    where-        step False i = -            if predicate i -               then (False,[i],[])-               else (True,[],[])-        step True _ = -               (True,[],[])-        done = const ((),[])+------------------------------------------------------------------------------ -{-| Ignore the firs @n@ inputs, pass all subsequent inputs to the 'Fold'.		+{-| Ignore all the inputs coming into the fold. ->>> L.fold (transduce (drop 2) L.list) [1..5]-[3,4,5]+    Polymorphic in both inputs and outputs.		 ->>> L.fold (transduce (drop 0) L.list) [1..5]-[1,2,3,4,5] -}-drop :: Int -> Transducer a a ()-drop howmany = -    Transducer step howmany done -    where-        step howmanypending i -            | howmanypending == 0 = -                (0,[i],[]) -            | otherwise = -                (pred howmanypending,[],[])-        done = const ((),[])--{-| 		-->>> L.fold (transduce (dropWhile (<3)) L.list) [1..5]-[3,4,5]--}-dropWhile :: (a -> Bool) -> Transducer a a ()-dropWhile predicate = -    Transducer step False done +ignore :: Transducer a b ()+ignore = +    Transducer step () done      where-        step False i = -            if predicate i -               then (False,[],[])-               else (True,[i],[])-        step True i = -               (True,[i],[])-        done = const ((),[])+        step _ _ = +            ((),[],[])+        done = +            const ((),[],[])  data SurroundState = PrefixAdded | PrefixPending @@ -315,19 +358,26 @@  >>> L.fold (transduce (surround "prefix" "suffix") L.list) "middle" "prefixmiddlesuffix"++    Used as a splitter, it puts the prefix, the original stream and+    the suffix in separate groups:++>>> L.fold (groups (surround "prefix" "suffix") (evenly (transduce (surround "[" "]"))) L.list) "middle"+"[prefix][middle][suffix]"+ -}-surround :: (Foldable p, Foldable s) => p a -> s a -> Transducer a a ()+surround :: (Traversable p, Traversable s) => p a -> s a -> Transducer a a () surround (toList -> ps) (toList -> ss) =      Transducer step PrefixPending done      where         step PrefixPending a = -            (PrefixAdded, ps ++ [a],[])+            (PrefixAdded, ps,[[a]])         step PrefixAdded a =              (PrefixAdded, [a],[])         done PrefixPending = -            ((), ps ++ ss)+            ((), ps, [[],ss])         done PrefixAdded = -            ((), ss)+            ((), [], [ss])  {-| Like 'surround', but the prefix and suffix are obtained using a 'IO'     action.@@ -335,7 +385,7 @@ >>> L.foldM (transduceM (surroundIO (return "prefix") (return "suffix")) (L.generalize L.list)) "middle" "prefixmiddlesuffix" -}-surroundIO :: (Foldable p, Foldable s, Functor m, MonadIO m) +surroundIO :: (Traversable p, Traversable s, Functor m, MonadIO m)             => m (p a)             -> m (s a)             -> TransducerM m a a ()@@ -344,16 +394,16 @@     where         step PrefixPending a = do             ps <- fmap toList prefixa-            return (PrefixAdded, ps ++ [a],[])+            return (PrefixAdded, ps, [[a]])         step PrefixAdded a = -            return (PrefixAdded, [a],[])+            return (PrefixAdded, [a], [])         done PrefixPending = do             ps <- fmap toList prefixa             ss <- fmap toList suffixa-            return ((), toList ps ++ toList ss)+            return ((), ps, [[],ss])         done PrefixAdded = do             ss <- fmap toList suffixa-            return ((), toList ss)+            return ((), [], [ss])  ------------------------------------------------------------------------------ @@ -384,32 +434,35 @@ -} foldify :: Transducer i o s -> Fold i s foldify (Transducer step begin done) =-    Fold (\x i -> _1of3 (step x i)) begin (\x -> fst (done x))+    Fold (\x i -> _1of3 (step x i)) begin (\x -> _1of3 (done x))  {-| Monadic version of 'foldify'.		  -} foldifyM :: Functor m => TransducerM m i o s -> FoldM m i s foldifyM (TransducerM step begin done) =-    FoldM (\x i -> fmap _1of3 (step x i)) begin (\x -> fmap fst (done x))+    FoldM (\x i -> fmap _1of3 (step x i)) begin (\x -> fmap _1of3 (done x))  {-| Transforms a 'Fold' into a 'Transducer' that sends the return value of the     'Fold' downstream when upstream closes.		  -}-chokepoint :: Fold a r -> Transducer a r ()-chokepoint (Fold fstep fstate fdone) =+condense :: Fold a r -> Transducer a r r+condense (Fold fstep fstate fdone) =     (Transducer wstep fstate wdone)     where         wstep = \fstate' i -> (fstep fstate' i,[],[])-        wdone = \fstate' -> ((),[fdone fstate'])+        wdone = \fstate' -> (\r -> (r,[r],[])) (fdone fstate') -chokepointM :: Applicative m => FoldM m a r -> TransducerM m a r ()-chokepointM (FoldM fstep fstate fdone) = +{-| Monadic version of 'condense'.		++-}+condenseM :: Applicative m => FoldM m a r -> TransducerM m a r r+condenseM (FoldM fstep fstate fdone) =      (TransducerM wstep fstate wdone)     where         wstep = \fstate' i -> fmap (\s -> (s,[],[])) (fstep fstate' i)-        wdone = \fstate' -> fmap (\r -> ((),[r])) (fdone fstate')+        wdone = \fstate' -> fmap (\r -> (r,[r],[])) (fdone fstate')   {-| Changes the base monad used by a 'TransducerM'.		@@ -424,103 +477,274 @@ hoistFold :: Monad m => (forall a. m a -> n a) -> FoldM m i r -> FoldM n i r  hoistFold g (FoldM step begin done) = FoldM (\s i -> g (step s i)) (g begin) (g . done) +{-| Turn a 'FoldM' that fails abruptly into one that encodes the error into+    its return value.++    Can be useful when combining fallible 'FoldM's with non-fallible ones.++>>> L.foldM (quiesce (FoldM (\_ _-> throwE ()) (return ()) (\_ -> throwE ()))) [1..7]+Left ()+-}+quiesce :: Monad m => FoldM (ExceptT e m) a r -> FoldM m a (Either e r)+quiesce (FoldM step initial done) = +    FoldM step' (runExceptT initial) done'+    where+    step' x i = do  +        case x of+            Left _ -> return x+            Right notyetfail -> runExceptT (step notyetfail i)+    done' x = do+        case x of +            Left e -> return (Left e)+            Right notyetfail -> do+                result <- runExceptT (done notyetfail)+                case result of +                    Left e -> return (Left e)+                    Right r -> return (Right r)++{-| Generalized version of 'quiesce' to turn a fallible 'FoldM' into another+    that starts a "fallback fold" when it encounters an error.++    "Start folding this way, if you encounter an error, start folding this +    other way".                               ++>>> L.foldM (quiesceWith (L.generalize L.length) (FoldM (\_ _-> throwE ()) (return ()) (\_ -> throwE ()))) [1..7]+Left ((),7)+-}+quiesceWith :: (Functor m,Monad m) => FoldM m a v -> FoldM (ExceptT e m) a r -> FoldM m a (Either (e,v) r)+quiesceWith fallbackFold (FoldM step initial done) = +    FoldM step' (runExceptT (withExceptT (Pair fallbackFold) initial)) done'+    where+    step' x i = do  +        case x of+            Left (Pair ffold e) -> do+                ffold' <- L.foldM (duplicated ffold) [i]+                return (Left (Pair ffold' e))+            Right notyetfail -> do+                 x' <- runExceptT (step notyetfail i)+                 case x' of+                     Left e -> do+                         ffold <- L.foldM (duplicated fallbackFold) [i]+                         return (Left (Pair ffold e))+                     Right x'' -> return (Right x'')+    done' x = case x of+            Left (Pair ffold e) -> do+                alternativeResult <- L.foldM ffold []+                return (Left (e,alternativeResult))+            Right notyetfail -> do +                x' <- runExceptT (done notyetfail)+                case x' of+                    Left e -> do+                        alternativeResult <- L.foldM fallbackFold []+                        return (Left (e,alternativeResult))+                    Right x'' -> return (Right x'')+ ------------------------------------------------------------------------------ -{-| Repeatedly applies a 'Transduction' to process each of the groups-    demarcated by a 'Transducer', returning a 'Fold' what works over the-    undivided stream of inputs. +{-| Infinite list of values.		++-}+type Infinite e = Cofree Identity e++{-| Unending machine that gives you a @b@ whenever you give it an @a@.++-}+type Moore a b = Cofree ((->) a) b++{-| Processes each of the groups demarcated by a 'Transducer' using +    a 'Transduction' taken from an unending supply, +    returning a 'Transduction' what works over the undivided stream of inputs.           The return value of the 'Transducer' is discarded. ->>> L.fold (groups (chunksOf 2) (transduce (surround "<" ">")) L.list) "aabbccdd"+>>> L.fold (groups (chunksOf 2) (evenly (transduce (surround "<" ">"))) L.list) "aabbccdd" "<aa><bb><cc><dd>"++>>> :{ +    let +      transducers = flip C.unfold 0 $ \i -> (,)+         (ReifiedTransduction (transduce (surround (show i) []))) +         (Identity (succ i))+    in L.fold (groups (chunksOf 2) transducers L.list) "aabbccdd"+    :}+"0aa1bb2cc3dd" -}-groups :: Transducer a b s -> Transduction b c -> Transduction a c -groups splitter transduction oldfold = -    let transduction' = fmap ((,) ()) . transduction-        newfold = groups' splitter L.mconcat transduction' oldfold +groups :: ToTransducer t +       => t a b s +       -> Infinite (ReifiedTransduction b c) -- ^ infinite list of transductions+       -> Transduction a c +groups splitter transductions oldfold = +    let transductions' = +              fmap (\rt -> +                        (ReifiedTransduction' (fmap (fmap ((,) ())) (getTransduction rt))))+            . hoistCofree (const . runIdentity)+            $ transductions +        newfold = groups' splitter L.mconcat transductions' oldfold      in      fmap snd newfold +{-| Use the same 'Transduction' for each group.		++-}+evenly :: Transduction b c -> Infinite (ReifiedTransduction b c) +evenly = coiter Identity . ReifiedTransduction ++{-| Use one transduction to process the first group, and another for the second+    and all subsequent groups.		++-}+bisect :: ToTransducer t +       => t a b s +       -> Transduction b c -- ^ head+       -> Transduction b c +       -> Transduction a c +bisect t t0 t1 = groups t (ReifiedTransduction t0 :< Identity (evenly t1))+ {-| Generalized version of 'groups' that preserves the return value of the     'Transducer'. -    A summary value for each group is also calculated. They are aggregated for-    the whole stream, with the help of an auxiliary 'Fold'.+    A summary value for each group is also calculated. These values are +    aggregated for the whole stream, with the help of an auxiliary 'Fold'. ->>> L.fold (groups' (chunksOf 2) L.list (\f -> transduce (surround "<" ">") (liftA2 (,) L.list f)) L.list) "aabbccdd"++>>> :{ +    let +        transductions = evenly' $ \f ->+            transduce (surround "<" ">") (liftA2 (,) L.list f)+    in  L.fold (groups' (chunksOf 2) L.list transductions L.list) "aabbccdd"+    :} (((),["<aa>","<bb>","<cc>","<dd>"]),"<aa><bb><cc><dd>") -}-groups' :: Transducer a b s+groups' :: ToTransducer t+        => t a b s         -> Fold u v -- ^ auxiliary 'Fold' that aggregates the @u@ values produced for each group-        -> Transduction' b c u -- ^ repeatedly applied for processing each group+        -> Moore u (ReifiedTransduction' b c u) -- ^ a machine that eats @u@ values and spits transductions         -> Transduction' a c (s,v) -groups' (Transducer sstep sbegin sdone) somesummarizer t somefold =-    Fold step (Trio sbegin somesummarizer (t (duplicated somefold))) done +groups' (toTransducer -> Transducer sstep sbegin sdone) somesummarizer (ReifiedTransduction' t0 :< somemachine) somefold =+    Fold step (Quartet sbegin somesummarizer (t0 (duplicated somefold)) somemachine) done        where -        step (Trio sstate summarizer innerfold) i = +        step (Quartet sstate summarizer innerfold machine) i =            let                 (sstate', oldSplit, newSplits) = sstep sstate i-               (summarizer',innerfold') = +               (summarizer',innerfold',machine') =                     foldl' -                   (\(summarizer_,innerfold_) somesplit -> -                       let (u,resetted) = reset innerfold_-                       in  (L.fold (duplicated summarizer_) [u], feed resetted somesplit))-                   (summarizer, feed innerfold oldSplit) +                   step'+                   (summarizer, feed innerfold oldSplit,machine)                     newSplits            in-           Trio sstate' summarizer' innerfold'+           Quartet sstate' summarizer' innerfold' machine'+        +        step' (summarizer_,innerfold_,machine_) somesplit = +           let (u,resetted,nextmachine) = reset machine_ innerfold_+           in  (L.fold (duplicated summarizer_) [u], feed resetted somesplit,nextmachine)+         feed = L.fold . duplicated-        reset (Fold _ fstate fdone) = fmap (t . duplicated) (fdone fstate) -        done (Trio sstate summarizer (Fold fstep fstate fdone)) = +        reset machine (Fold _ fstate fdone) = +            let (u,nextfold) = fdone fstate+                ReifiedTransduction' t1 :< nextmachine = machine u+            in  (u,t1 (duplicated nextfold),nextmachine)+        done (Quartet sstate summarizer innerfold machine) =              let -                (s,bss) = sdone sstate-                (u,extract -> x) = fdone (foldl' fstep fstate bss)-            in  ((s,L.fold summarizer [u]),x)+                (s,oldSplit,newSplits) = sdone sstate+                (summarizer',innerfold',_) = +                   foldl' +                   step'+                   (summarizer,feed innerfold oldSplit,machine) +                   newSplits+                (u,finalfold) = extract innerfold'+            in  ((s,L.fold summarizer' [u]),extract finalfold) +{-| Use the same 'Transduction'' for each group.++    Ignores the inputs to the Moore machine.++-}+evenly' :: Transduction' b c u -> Moore u (ReifiedTransduction' b c u) +evenly' = coiter const . ReifiedTransduction' ++ {-| Monadic version of 'groups'.		  -}-groupsM :: Monad m => TransducerM m a b s -> TransductionM m b c -> TransductionM m a c-groupsM splitter transduction oldfold = -    let transduction' = fmap ((,) ()) . transduction-        newfold = -            groupsM' splitter (L.generalize L.mconcat) transduction' oldfold +groupsM :: (Monad m, ToTransducerM m t)+               => t a b s -- ^+               -> Infinite (ReifiedTransductionM m b c)+               -> TransductionM m a c+groupsM splitter transductions oldfold = +    let transductions' = +              fmap (\rt -> +                        ReifiedTransductionM'+                        (fmap (fmap ((,) ())) (getTransductionM rt)))+            . hoistCofree (const . runIdentity)+            $ transductions +        newfold = groupsM' splitter (L.generalize L.mconcat) transductions' oldfold      in      fmap snd newfold +{-| Monadic version of 'evenly'.		++-}+evenlyM :: TransductionM m b c -> Infinite (ReifiedTransductionM m b c) +evenlyM = coiter Identity . ReifiedTransductionM++{-| Monadic version of 'bisect'.		++-}+bisectM :: ToTransducerM m t +        => t a b s +        -> TransductionM m b c -- ^ head+        -> TransductionM m b c +        -> TransductionM m a c +bisectM t t0 t1 = groupsM t (ReifiedTransductionM t0 :< Identity (evenlyM t1))+ {-| Monadic version of 'groups''.		  -}-groupsM' :: Monad m => TransducerM m a b s -> FoldM m u v -> TransductionM' m b c u -> TransductionM' m a c (s,v) -groupsM' (TransducerM sstep sbegin sdone) somesummarizer t somefold =-    FoldM step (sbegin >>= \x -> return (Trio x somesummarizer (t (duplicated somefold)))) done        +groupsM' :: (Monad m, ToTransducerM m t) +         => t a b s +         -> FoldM m u v +         -> Moore u (ReifiedTransductionM' m b c u) -- ^ a machine that eats @u@ values and spits transductions+         -> TransductionM' m a c (s,v) ++groupsM' (toTransducerM -> TransducerM sstep sbegin sdone) somesummarizer (ReifiedTransductionM' t0 :< somemachine) somefold =+    FoldM step (sbegin >>= \x -> return (Quartet x somesummarizer (t0 (duplicated somefold)) somemachine)) done             where-        step (Trio sstate summarizer innerfold) i = do+        step (Quartet sstate summarizer innerfold machine) i = do             (sstate', oldSplit, newSplits) <- sstep sstate i              innerfold' <- feed innerfold oldSplit-            (summarizer',innerfold'') <- foldlM step' (summarizer,innerfold') newSplits-            return $! Trio sstate' summarizer' innerfold''+            (summarizer',innerfold'',machine') <- foldlM step' (summarizer,innerfold',machine) newSplits+            return $! Quartet sstate' summarizer' innerfold'' machine' -        step' = \(summarizer, innerfold) is -> do-            (u,innerfold') <- reset innerfold +        step' = \(summarizer,innerfold,machine) is -> do+            (u,innerfold',machine') <- reset machine innerfold              summarizer' <- L.foldM (duplicated summarizer) [u]             innerfold'' <- feed innerfold' is-            return $! (summarizer',innerfold'') +            return $! (summarizer',innerfold'',machine')           feed = L.foldM . duplicated -        reset (FoldM _ fstate fdone) = do-           (u,x) <- fdone =<< fstate -           return (u, t (duplicated x))+        reset machine (FoldM _ fstate fdone) = do+           (u,nextfold) <- fdone =<< fstate +           let +               ReifiedTransductionM' t1 :< nextmachine = machine u+           return (u,t1 (duplicated nextfold),nextmachine) -        done (Trio sstate summarizer (FoldM fstep fstate fdone)) = do-            (s,bss) <- sdone sstate-            (u,finalfold) <- fdone =<< flip (foldlM fstep) bss =<< fstate-            v <- L.foldM summarizer [u]+        done (Quartet sstate summarizer innerfold machine) = do+            (s,oldSplit,newSplits) <- sdone sstate+            innerfold' <- feed innerfold oldSplit+            (summarizer',innerfold'',_) <- foldlM step' (summarizer,innerfold',machine) newSplits+            (u,finalfold) <- L.foldM innerfold'' []+            v <- L.foldM summarizer' [u]             r <- L.foldM finalfold []             return ((s,v),r) ++{-| Monadic version of 'evenly''.		++-}+evenlyM' :: TransductionM' m b c u -> Moore u (ReifiedTransductionM' m b c u) +evenlyM' = coiter const . ReifiedTransductionM'+ {-| Summarizes each of the groups demarcated by the 'Transducer' using a     'Fold'.      @@ -529,35 +753,34 @@ >>> L.fold (folds (chunksOf 3) L.sum L.list) [1..7] [6,15,7] -}-folds :: Transducer a b s -> Fold b c -> Transduction a c-folds splitter f = groups splitter (transduce (chokepoint f))+folds :: ToTransducer t => t a b s -> Fold b c -> Transduction a c+folds splitter f = groups splitter (evenly (transduce (condense f)))  {-| Like 'folds', but preserves the return value of the 'Transducer'.  >>> L.fold (folds' (chunksOf 3) L.sum L.list) [1..7] ((),[6,15,7]) -}-folds' :: Transducer a b s -> Fold b c -> Transduction' a c s+folds' :: ToTransducer t => t a b s -> Fold b c -> Transduction' a c s folds' splitter innerfold somefold =      fmap (bimap fst id) (groups' splitter L.mconcat innertrans somefold)     where-    innertrans = fmap ((,) ()) . transduce (chokepoint innerfold)+    innertrans = evenly' $ \x -> fmap ((,) ()) (transduce (condense innerfold) x)  {-| Monadic version of 'folds'.		  -}-foldsM :: (Applicative m,Monad m) => TransducerM m a b s -> FoldM m b c -> TransductionM m a c-foldsM splitter f = groupsM splitter (transduceM (chokepointM f))-+foldsM :: (Applicative m, Monad m, ToTransducerM m t) => t a b s -> FoldM m b c -> TransductionM m a c+foldsM splitter f = groupsM splitter (evenlyM (transduceM (condenseM f)))  {-| Monadic version of 'folds''.		  -}-foldsM' :: (Applicative m,Monad m) => TransducerM m a b s -> FoldM m b c -> TransductionM' m a c s+foldsM' :: (Applicative m,Monad m, ToTransducerM m t) => t a b s -> FoldM m b c -> TransductionM' m a c s foldsM' splitter innerfold somefold =      fmap (bimap fst id) (groupsM' splitter (L.generalize L.mconcat) innertrans somefold)     where-    innertrans = fmap ((,) ()) . transduceM (chokepointM innerfold)+    innertrans = evenlyM' $ \x -> fmap ((,) ()) (transduceM (condenseM innerfold) x)  ------------------------------------------------------------------------------ @@ -566,7 +789,7 @@ >>> L.fold (folds (chunksOf 2) L.list L.list) [1..7] [[1,2],[3,4],[5,6],[7]] ->>> L.fold (groups (chunksOf 2) (transduce (surround [] [0])) L.list) [1..7]+>>> L.fold (groups (chunksOf 2) (evenly (transduce (surround [] [0]))) L.list) [1..7] [1,2,0,3,4,0,5,6,0,7,0] -} chunksOf :: Int -> Transducer a a ()@@ -575,7 +798,124 @@     where         step 0 a = (pred groupSize, [], [[a]])         step i a = (pred i, [a], [])-        done _ = ((),[])+        done _ = ((),[],[])++{-| Splits the stream at a given position.		++>>> L.fold (bisect (splitAt 2) (transduce ignore) id L.list) [1..5]+[3,4,5]++-}+splitAt :: Int -> Transducer a a ()+splitAt howmany = +    Transducer step (Just howmany) done +    where+        step Nothing i =+            (Nothing,[i],[])+        step (Just howmanypending) i +            | howmanypending == 0 = +                (Nothing,[],[[i]])+            | otherwise = +                (Just (pred howmanypending),[i],[]) +        done = mempty++{-| Similar to `splitAt`, but works with streams of "chunked" data like+    bytestrings, texts, vectors, lists of lists...		++>>> L.fold (bisect (chunkedSplitAt 7) (transduce ignore) id L.list) [[1..5],[6..9]]+[[8,9]]++-}+chunkedSplitAt :: SFM.StableFactorialMonoid m => Int -> Transducer m m ()+chunkedSplitAt howmany = +    Transducer step (Just howmany) done+    where+        step Nothing m =+            (Nothing,[m],[])+        step (Just howmanypending) m+            | NM.null m = +                (Just howmanypending,[],[])+            | howmanypending == 0 = +                (Nothing,[],[[m]])+            | howmanypending >= SFM.length m =+                (Just (howmanypending - SFM.length m),[m],[])+            | otherwise =+                let (prefix,suffix) = SFM.splitAt howmanypending m+                in+                (Nothing,[prefix],[[suffix]])+        done = mempty++data SplitWhenWhenState = +      SplitWhenConditionEncountered +    | SplitWhenConditionPending++{-| 		++>>> L.fold (bisect (splitWhen (>3)) id (transduce ignore) L.list) [1..5]+[1,2,3]+-}+splitWhen :: (a -> Bool) -> Transducer a a ()+splitWhen predicate = +    Transducer step SplitWhenConditionPending done +    where+        step SplitWhenConditionPending i = +            if predicate i +               then (SplitWhenConditionEncountered,[],[[i]])+               else (SplitWhenConditionPending,[i],[])+        step SplitWhenConditionEncountered i = +               (SplitWhenConditionEncountered,[i],[])+        done = mempty++{-| Puts the last element of the input stream (if it exists) in a separate+    group.++>>> L.fold (bisect splitLast id (transduce ignore) L.list) [1..5]+[1,2,3,4]+-}+splitLast :: Transducer a a (Maybe a)+splitLast =+    Transducer step Nothing done+    where+        step Nothing i = +            (Just i,[],[])+        step (Just oldi) i = +            (Just i,[oldi],[])+        done Nothing = +            (Nothing,[],[])+        done (Just lasti) = (Just lasti, [], [[lasti]])++{-| Strip a prefix from a stream of "chunked" data, like packed text.		++    If the prefix doesn't match, fail with the unmatched part of the prefix and+    the input that caused the error.++>>> runExceptT $ L.foldM (transduceM (chunkedStripPrefix [[1..2],[3..4]]) (L.generalize L.list)) [[1..5],[6..9]]+Right [[5],[6,7,8,9]]++>>> runExceptT $ L.foldM (transduceM (chunkedStripPrefix [[1..2],[3,77,99]]) (L.generalize L.list)) [[1..5],[6..9]]+Left ([[77,99]],Just [4,5])+-}+chunkedStripPrefix :: (CM.LeftGCDMonoid i,SFM.StableFactorialMonoid i,Traversable t,Monad m) +                   => t i -- ^+                   -> TransducerM (ExceptT ([i],Maybe i) m) i i ()+chunkedStripPrefix (filter (not . NM.null) . toList -> chunks) = +    TransducerM step (return chunks) done+    where+        step []     i = +            return ([],[i],[])+        step (x:xs) i = +            let (prefix',i',x') = CM.stripCommonPrefix i x +            in +            if NM.null prefix'+                then throwE (x:xs,Just i)+                else +                    if NM.null x' +                       then step xs i'+                       else step (x':xs) i'+        done [] = +            return mempty+        done (x:xs) = +            throwE (x:xs, Nothing)   ------------------------------------------------------------------------------ 

@@ -1,13 +1,13 @@ module Control.Foldl.Transduce.Internal (         -- * Strict datatypes          Pair(..)-    ,   Trio(..)+    ,   Quartet(..)     ,   _1of3     ) where  data Pair a b = Pair !a !b -data Trio a b c = Trio !a !b !c+data Quartet a b c d = Quartet !a !b !c !d  _1of3 :: (a,b,c) -> a _1of3 (x,_,_) = x

@@ -39,6 +39,7 @@  {- $setup +>>> :set -XFlexibleContexts >>> import Data.String hiding (lines,words) >>> import Data.Text (Text) >>> import Control.Applicative@@ -63,8 +64,8 @@         (Pair leftovers next',[txt],[])     done (Pair leftovers _) =          if B.null leftovers-            then ((), [])-            else ((), foldMap (pure . T.singleton) onLeftovers')+            then ((), [], [])+            else ((), foldMap (pure . T.singleton) onLeftovers',[])     onLeftovers' = onLeftovers "leftovers" Nothing  {-| Builds a UTF8-decoding 'Transducer'. Takes an error handler from@@ -124,14 +125,14 @@                     return (Pair leftovers next2,[txt],[])         done (Pair leftovers _) = do             if B.null leftovers-                then return ((), [])+                then return ((), [], [])                 else do                     emc <- liftIO . try . evaluate $ onLeftovers'                     case emc of                         Left ue -> do                             throwE ue                         Right mc -> do-                            return ((), foldMap (return . T.singleton) mc)+                            return ((), foldMap (return . T.singleton) mc,[])         next' = next T.strictDecode           onLeftovers' = T.strictDecode "leftovers" Nothing @@ -171,7 +172,7 @@             if blank i                  then (False,[],[])                 else (True, [T.stripStart i],[])-        done _  = ((),[])+        done _  = ((),[],[])  {-| Remove trailing white space from a stream of 'Text'.		 @@ -192,15 +193,15 @@                 then (i:txts, [], [])                 else ([i], reverse txts, [])         done txts = case reverse txts of-            txt : _ -> ((), [T.stripEnd txt])-            _ -> ((), [])+            txt : _ -> ((), [T.stripEnd txt], [])+            _ -> ((), [], [])  {-| Splits a stream of text into lines, removing the newlines. ->>> L.fold (L.groups lines (transduce (surround [T.pack "x"] [])) L.list) (map T.pack ["line 1\n line 2\n"])+>>> L.fold (L.groups lines (evenly (transduce (surround [T.pack "x"] []))) L.list) (map T.pack ["line 1\n line 2\n"]) ["x","line 1","x"," line 2"] ->>> L.fold (L.groups lines (transduce newline) L.list) (map T.pack ["line 1\n line 2\n"])+>>> L.fold (L.groups lines (evenly (transduce newline)) L.list) (map T.pack ["line 1\n line 2\n"]) ["line 1","\n"," line 2","\n"]      Used with 'L.transduce', it simply removes newlines:@@ -225,7 +226,7 @@                        (True,_) -> (lastc, [], map pure txts)                        (False,t:ts) -> (lastc, [t], map pure ts) -        done _ = ((),[])+        done _ = ((),[],[])   data WordsState = @@ -268,5 +269,5 @@                                else ([w],map pure ws)                         (_,[]) -> error "never happens, txt not blank"                 in (nextstate,oldgroup,newgroups)-        done _ = ((),[])+        done _ = ((),[],[]) 

@@ -1,6 +1,10 @@ module Main where +import Prelude hiding (splitAt)+import Data.String hiding (lines,words) import Data.Monoid+import Data.Bifunctor+import qualified Data.Monoid.Factorial as SFM import Test.Tasty import Test.Tasty.HUnit @@ -55,5 +59,23 @@                 (T.pack "\n")                 (mconcat (L.fold (transduce newline L.list) (map T.pack [""])))         ]+        ,+        testGroup "quiesceWith" $ +        [+            testCase "collectAfterFailure" $+                let foldthatfails = +                        transduceM utf8E (L.generalize L.list)+                    inputs = +                        map fromString ["invalid \xc3\x28 sequence","xxx","zzz","___"]+                    fallbackfold =+                        bisectM (chunkedSplitAt 4) id (transduceM ignore) (L.generalize L.list)+                in+                do+                   r <- L.foldM (quiesceWith fallbackfold foldthatfails) inputs +                   assertEqual +                       mempty +                       (Left ('C',4))+                       (first (bimap (head . show) (SFM.length . mconcat)) r)+        ]        ]