scc 0.4 → 0.5

raw patch · 11 files changed

+1679/−2127 lines, 11 filesdep +monad-coroutinedep +monad-paralleldep −parallelPVP ok

version bump matches the API change (PVP)

Dependencies added: monad-coroutine, monad-parallel

Dependencies removed: parallel

API changes (from Hackage documentation)

Files

• Control/Concurrent/Coroutine.hs +0/−318
• Control/Concurrent/SCC/Combinators.hs +946/−1100
• Control/Concurrent/SCC/Components.hs +31/−27
• Control/Concurrent/SCC/Primitives.hs +46/−119
• Control/Concurrent/SCC/Streams.hs +234/−92
• Control/Concurrent/SCC/Types.hs +67/−90
• Control/Concurrent/SCC/XML.hs +263/−293
• Makefile +23/−13
• Shell.hs +17/−22
• Test.hs +42/−43
• scc.cabal +10/−10

@@ -1,318 +0,0 @@-{- -    Copyright 2009-2010 Mario Blazevic--    This file is part of the Streaming Component Combinators (SCC) project.--    The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public-    License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later-    version.--    SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty-    of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more details.--    You should have received a copy of the GNU General Public License along with SCC.  If not, see-    <http://www.gnu.org/licenses/>.--}---- | This module defines the 'Coroutine' monad transformer.--- --- A 'Coroutine' monadic computation can 'suspend' its execution at any time, returning to its invoker. The returned--- coroutine suspension contains the continuation of the coroutine embedded in a functor. Here is an example of a--- coroutine that suspends computation in the 'IO' monad using the functor 'Yield':--- --- @--- producer = do yield 1---               lift (putStrLn \"Produced one, next is four.\")---               yield 4---               return \"Finished\"--- @--- --- A suspended 'Coroutine' computation can be resumed. The easiest way to run a coroutine is by using the 'pogoStick'--- function, which keeps resuming the coroutine in trampolined style until it completes. Here is an example of--- 'pogoStick' applied to the /producer/ above:--- --- @--- printProduce :: Show x => Coroutine (Yield x) IO r -> IO r--- printProduce producer = pogoStick (\\(Yield x cont) -> lift (print x) >> cont) producer--- @--- --- Multiple concurrent coroutines can be run as well, and this module provides two different ways. The function 'seesaw'--- can be used to run two interleaved computations. Another possible way is to weave together steps of different--- coroutines into a single coroutine using the function 'couple', which can then be executed by 'pogoStick'.--- --- Coroutines can be run from within another coroutine. In this case, the nested coroutines would normally suspend to--- their invoker. Another option is to allow a nested coroutine to suspend both itself and its invoker at once. In this--- case, the two suspension functors should be grouped into an 'EitherFunctor'. To run nested coroutines of this kind,--- use functions 'pogoStickNested', 'seesawNested', and 'coupleNested'.--- --- For other uses of trampoline-style coroutines, see--- --- > Trampolined Style - Ganz, S. E. Friedman, D. P. Wand, M, ACM SIGPLAN NOTICES, 1999, VOL 34; NUMBER 9, pages 18-27--- --- and--- --- > The Essence of Multitasking - William L. Harrison, Proceedings of the 11th International Conference on Algebraic--- > Methodology and Software Technology, volume 4019 of Lecture Notes in Computer Science, 2006--{-# LANGUAGE ScopedTypeVariables, Rank2Types, MultiParamTypeClasses, TypeFamilies, EmptyDataDecls,-             FlexibleInstances, OverlappingInstances, UndecidableInstances- #-}--module Control.Concurrent.Coroutine-   (-    -- * Coroutine definition-    Coroutine,-    suspend,-    -- * Useful classes-    ParallelizableMonad(..), AncestorFunctor,-    -- * Running Coroutine computations-    runCoroutine, pogoStick, pogoStickNested, seesaw, seesawNested, SeesawResolver(..),-    -- * Suspension functors-    Yield(Yield), Await(Await), Naught,-    yield, await,-    -- * Nested and coupled Coroutine computations-    nest, couple, coupleNested,-    local, out, liftOut,-    EitherFunctor(LeftF, RightF), NestedFunctor (NestedFunctor), SomeFunctor(..)-   )-where--import Control.Concurrent (forkIO)-import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)-import Control.Monad (liftM, liftM2, when)-import Control.Monad.Identity-import Control.Monad.Trans (MonadTrans(..), MonadIO(..))-import Control.Parallel (par, pseq)---- | Class of monads that can perform two computations in parallel.-class Monad m => ParallelizableMonad m where-   -- | Perform two monadic computations in parallel and pass the results.-   bindM2 :: (a -> b -> m c) -> m a -> m b -> m c-   bindM2 f ma mb = do {a <- ma; b <- mb; f a b}---- | Any monad that allows the result value to be extracted, such as `Identity` or `Maybe` monad, can implement--- `bindM2` by using `par`.-instance ParallelizableMonad Identity where-   bindM2 f ma mb = let a = runIdentity ma-                        b = runIdentity mb-                    in  a `par` (b `pseq` a `pseq` f a b)--instance ParallelizableMonad Maybe where-   bindM2 f ma mb = case ma `par` (mb `pseq` (ma, mb))-                    of (Just a, Just b) -> f a b-                       _ -> Nothing---- | IO is parallelizable by `forkIO`.-instance ParallelizableMonad IO where-   bindM2 f ma mb = do va <- newEmptyMVar-                       vb <- newEmptyMVar-                       forkIO (ma >>= putMVar va)-                       forkIO (mb >>= putMVar vb)-                       a <- takeMVar va-                       b <- takeMVar vb-                       f a b---- | Suspending, resumable monadic computations.-newtype Coroutine s m r = Coroutine {-   -- | Run the next step of a `Coroutine` computation.-   resume :: m (CoroutineState s m r)-   }--data CoroutineState s m r =-   -- | Coroutine computation is finished with final value /r/.-   Done r-   -- | Computation is suspended, its remainder is embedded in the functor /s/.- | Suspend! (s (Coroutine s m r))--instance (Functor s, Monad m) => Monad (Coroutine s m) where-   return x = Coroutine (return (Done x))-   t >>= f = Coroutine (resume t >>= apply f)-      where apply f (Done x) = resume (f x)-            apply f (Suspend s) = return (Suspend (fmap (>>= f) s))--instance (Functor s, ParallelizableMonad m) => ParallelizableMonad (Coroutine s m) where-   bindM2 f t1 t2 = Coroutine (bindM2 combine (resume t1) (resume t2)) where-      combine (Done x) (Done y) = resume (f x y)-      combine (Suspend s) (Done y) = return $ Suspend (fmap (flip f y =<<) s)-      combine (Done x) (Suspend s) = return $ Suspend (fmap (f x =<<) s)-      combine (Suspend s1) (Suspend s2) = return $ Suspend (fmap (bindM2 f $ suspend s1) s2)--instance Functor s => MonadTrans (Coroutine s) where-   lift = Coroutine . liftM Done--instance (Functor s, MonadIO m) => MonadIO (Coroutine s m) where-   liftIO = lift . liftIO---- | The 'Yield' functor instance is equivalent to (,) but more descriptive.-data Yield x y = Yield x y-instance Functor (Yield x) where-   fmap f (Yield x y) = Yield x (f y)---- | The 'Await' functor instance is equivalent to (->) but more descriptive.-data Await x y = Await! (x -> y)-instance Functor (Await x) where-   fmap f (Await g) = Await (f . g)---- | The 'Naught' functor instance doesn't contain anything and cannot be constructed. Used for building non-suspendable--- coroutines.-data Naught x-instance Functor Naught where-   fmap f _ = undefined---- | Combines two alternative functors into one, applying one or the other. Used for nested coroutines.-data EitherFunctor l r x = LeftF (l x) | RightF (r x)-instance (Functor l, Functor r) => Functor (EitherFunctor l r) where-   fmap f (LeftF l) = LeftF (fmap f l)-   fmap f (RightF r) = RightF (fmap f r)---- | Combines two functors into one, applying both.-newtype NestedFunctor l r x = NestedFunctor (l (r x))-instance (Functor l, Functor r) => Functor (NestedFunctor l r) where-   fmap f (NestedFunctor lr) = NestedFunctor ((fmap . fmap) f lr)---- | Combines two functors into one, applying either or both of them. Used for coupled coroutines.-data SomeFunctor l r x = LeftSome (l x) | RightSome (r x) | Both (NestedFunctor l r x)-instance (Functor l, Functor r) => Functor (SomeFunctor l r) where-   fmap f (LeftSome l) = LeftSome (fmap f l)-   fmap f (RightSome r) = RightSome (fmap f r)-   fmap f (Both lr) = Both (fmap f lr)---- | Suspend the current 'Coroutine'.-suspend :: (Monad m, Functor s) => s (Coroutine s m x) -> Coroutine s m x-suspend s = Coroutine (return (Suspend s))---- | Suspend yielding a value.-yield :: forall m x. Monad m => x -> Coroutine (Yield x) m ()-yield x = suspend (Yield x (return ()))---- | Suspend until a value is provided.-await :: forall m x. Monad m => Coroutine (Await x) m x-await = suspend (Await return)---- | Convert a non-suspending 'Coroutine' to the base monad.-runCoroutine :: Monad m => Coroutine Naught m x -> m x-runCoroutine = pogoStick (error "runCoroutine can run only a non-suspending coroutine!")---- | Run a 'Coroutine', using a function that converts suspension to the resumption it wraps.-pogoStick :: (Functor s, Monad m) => (s (Coroutine s m x) -> Coroutine s m x) -> Coroutine s m x -> m x-pogoStick reveal t = resume t-                     >>= \s-> case s -                              of Done result -> return result-                                 Suspend c -> pogoStick reveal (reveal c)---- | Run a nested 'Coroutine' that can suspend both itself and the current 'Coroutine'.-pogoStickNested :: (Functor s1, Functor s2, Monad m) => -                   (s2 (Coroutine (EitherFunctor s1 s2) m x) -> Coroutine (EitherFunctor s1 s2) m x)-                   -> Coroutine (EitherFunctor s1 s2) m x -> Coroutine s1 m x-pogoStickNested reveal t = -   Coroutine{resume= resume t-                      >>= \s-> case s-                               of Done result -> return (Done result)-                                  Suspend (LeftF s) -> return (Suspend (fmap (pogoStickNested reveal) s))-                                  Suspend (RightF c) -> resume (pogoStickNested reveal (reveal c))-             }---- | Combines two values under two functors into a pair of values under a single 'NestedFunctor'.-nest :: (Functor a, Functor b) => a x -> b y -> NestedFunctor a b (x, y)-nest a b = NestedFunctor $ fmap (\x-> fmap ((,) x) b) a---- | Weaves two coroutines into one.-couple :: (Monad m, Functor s1, Functor s2) => -          (forall x y r. (x -> y -> m r) -> m x -> m y -> m r)-       -> Coroutine s1 m x -> Coroutine s2 m y -> Coroutine (SomeFunctor s1 s2) m (x, y)-couple runPair t1 t2 = Coroutine{resume= runPair proceed (resume t1) (resume t2)} where-   proceed (Done x) (Done y) = return $ Done (x, y)-   proceed (Suspend s1) (Suspend s2) = return $ Suspend $ fmap (uncurry (couple runPair)) (Both $ nest s1 s2)-   proceed (Done x) (Suspend s2) = return $ Suspend $ fmap (couple runPair (return x)) (RightSome s2)-   proceed (Suspend s1) (Done y) = return $ Suspend $ fmap (flip (couple runPair) (return y)) (LeftSome s1)---- | Weaves two nested coroutines into one.-coupleNested :: (Monad m, Functor s0, Functor s1, Functor s2) => -                (forall x y r. (x -> y -> m r) -> m x -> m y -> m r)-             -> Coroutine (EitherFunctor s0 s1) m x -> Coroutine (EitherFunctor s0 s2) m y-             -> Coroutine (EitherFunctor s0 (SomeFunctor s1 s2)) m (x, y)-coupleNested runPair = coupleNested' where-   coupleNested' t1 t2 = Coroutine{resume= runPair (\ st1 st2 -> return (proceed st1 st2)) (resume t1) (resume t2)}-   proceed (Done x) (Done y) = Done (x, y)-   proceed (Suspend (RightF s)) (Done y) = Suspend $ RightF $ fmap (flip coupleNested' (return y)) (LeftSome s)-   proceed (Done x) (Suspend (RightF s)) = Suspend $ RightF $ fmap (coupleNested' (return x)) (RightSome s)-   proceed (Suspend (RightF s1)) (Suspend (RightF s2)) =-      Suspend $ RightF $ fmap (uncurry coupleNested') (Both $ nest s1 s2)-   proceed (Suspend (LeftF s)) (Done y) = Suspend $ LeftF $ fmap (flip coupleNested' (return y)) s-   proceed (Done x) (Suspend (LeftF s)) = Suspend $ LeftF $ fmap (coupleNested' (return x)) s-   proceed (Suspend (LeftF s1)) (Suspend (LeftF s2)) = Suspend $ LeftF $ fmap (coupleNested' $ suspend $ LeftF s1) s2---- | A simple record containing the resolver functions for all possible coroutine pair suspensions.-data SeesawResolver s1 s2 = SeesawResolver {-   resumeLeft  :: forall t. s1 t -> t,    -- ^ resolves the left suspension functor into the resumption it contains-   resumeRight :: forall t. s2 t -> t,    -- ^ resolves the right suspension into its resumption-   -- | invoked when both coroutines are suspended, resolves both suspensions or either one-   resumeAny   :: forall t1 t2 r.-                  (t1 -> r)       --  ^ continuation to resume only the left suspended coroutine-               -> (t2 -> r)       --  ^ continuation to resume the right coroutine only-               -> (t1 -> t2 -> r) --  ^ continuation to resume both coroutines-               -> s1 t1           --  ^ left suspension-               -> s2 t2           --  ^ right suspension-               -> r-}---- | Runs two coroutines concurrently. The first argument is used to run the next step of each coroutine, the next to--- convert the left, right, or both suspensions into the corresponding resumptions.-seesaw :: (Monad m, Functor s1, Functor s2) => -          (forall x y r. (x -> y -> m r) -> m x -> m y -> m r)-       -> SeesawResolver s1 s2-       -> Coroutine s1 m x -> Coroutine s2 m y -> m (x, y)-seesaw runPair resolver t1 t2 = seesaw' t1 t2 where-   seesaw' t1 t2 = runPair proceed (resume t1) (resume t2)-   proceed (Done x) (Done y) = return (x, y)-   proceed (Done x) (Suspend s2) = seesaw' (return x) (resumeRight resolver s2)-   proceed (Suspend s1) (Done y) = seesaw' (resumeLeft resolver s1) (return y)-   proceed (Suspend s1) (Suspend s2) =-      resumeAny resolver (flip seesaw' (suspend s2)) (seesaw' (suspend s1)) seesaw' s1 s2---- | Like 'seesaw', but for nested coroutines that are allowed to suspend the current coroutine as well as themselves.-seesawNested :: (Monad m, Functor s0, Functor s1, Functor s2) =>-                (forall x y r. (x -> y -> m r) -> m x -> m y -> m r)-             -> SeesawResolver s1 s2-             -> Coroutine (EitherFunctor s0 s1) m x -> Coroutine (EitherFunctor s0 s2) m y -> Coroutine s0 m (x, y)-seesawNested runPair resolver t1 t2 = seesaw' t1 t2 where-   seesaw' t1 t2 = Coroutine{resume= bouncePair t1 t2}-   bouncePair t1 t2 = runPair proceed (resume t1) (resume t2)-   proceed (Suspend (LeftF s1)) state2 = return $ Suspend $ fmap ((flip seesaw' (Coroutine $ return state2))) s1-   proceed state1 (Suspend (LeftF s2)) = return $ Suspend $ fmap (seesaw' (Coroutine $ return state1)) s2-   proceed (Done x) (Done y) = return $ Done (x, y)-   proceed state1@(Done x) (Suspend (RightF s2)) = proceed state1 =<< resume (resumeRight resolver s2)-   proceed (Suspend (RightF s1)) state2@(Done y) = flip proceed state2 =<< resume (resumeLeft resolver s1)-   proceed state1@(Suspend (RightF s1)) state2@(Suspend (RightF s2)) =-      resumeAny resolver ((flip proceed state2 =<<) . resume) ((proceed state1 =<<) . resume) bouncePair s1 s2---- | Converts a coroutine into a nested one.-local :: forall m l r x. (Functor r, Monad m) => Coroutine r m x -> Coroutine (EitherFunctor l r) m x-local (Coroutine mr) = Coroutine (liftM inject mr)-   where inject :: CoroutineState r m x -> CoroutineState (EitherFunctor l r) m x-         inject (Done x) = Done x-         inject (Suspend r) = Suspend (RightF $ fmap local r)---- | Converts a coroutine into one that can contain nested coroutines.-out :: forall m l r x. (Functor l, Monad m) => Coroutine l m x -> Coroutine (EitherFunctor l r) m x-out (Coroutine ml) = Coroutine (liftM inject ml)-   where inject :: CoroutineState l m x -> CoroutineState (EitherFunctor l r) m x-         inject (Done x) = Done x-         inject (Suspend l) = Suspend (LeftF $ fmap out l)---- | Class of functors that can be lifted.-class (Functor a, Functor d) => AncestorFunctor a d where-   -- | Convert the ancestor functor into its descendant. The descendant functor typically contains the ancestor.-   liftFunctor :: a x -> d x--instance Functor a => AncestorFunctor a a where-   liftFunctor = id-instance (Functor a, Functor d', Functor d, d ~ EitherFunctor d' s, AncestorFunctor a d') => AncestorFunctor a d where-   liftFunctor = LeftF . (liftFunctor :: a x -> d' x)---- | Like 'out', working over multiple functors.-liftOut :: forall m a d x. (Monad m, Functor a, AncestorFunctor a d) => Coroutine a m x -> Coroutine d m x-liftOut (Coroutine ma) = Coroutine (liftM inject ma)-   where inject :: CoroutineState a m x -> CoroutineState d m x-         inject (Done x) = Done x-         inject (Suspend a) = Suspend (liftFunctor $ fmap liftOut a)

@@ -1,1101 +1,947 @@ {- -    Copyright 2008-2009 Mario Blazevic--    This file is part of the Streaming Component Combinators (SCC) project.--    The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public-    License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later-    version.--    SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty-    of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more details.--    You should have received a copy of the GNU General Public License along with SCC.  If not, see-    <http://www.gnu.org/licenses/>.--}--{-# LANGUAGE ScopedTypeVariables, Rank2Types, KindSignatures, EmptyDataDecls,-             MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, FunctionalDependencies, TypeFamilies #-}---- | The "Combinators" module defines combinators applicable to values of the 'Transducer' and 'Splitter' types defined--- in the "Control.Concurrent.SCC.Types" module.--module Control.Concurrent.SCC.Combinators-   (-- * Consumer, producer, and transducer combinators-    splitterToMarker,-    consumeBy, prepend, append, substitute,-    PipeableComponentPair (connect), JoinableComponentPair (join, sequence),-    -- * Pseudo-logic splitter combinators-    -- | Combinators '>&' and '>|' are only /pseudo/-logic. While the laws of double negation and De Morgan's laws hold,-    -- '>&' and '>|' are in general not commutative, associative, nor idempotent. In the special case when all argument-    -- splitters are stateless, such as those produced by 'Components.liftStatelessSplitter', these combinators do satisfy-    -- all laws of Boolean algebra.-    sNot, sAnd, sOr,-    -- ** Zipping logic combinators-    -- | The '&&' and '||' combinators run the argument splitters in parallel and combine their logical outputs using-    -- the corresponding logical operation on each output pair, in a manner similar to 'Prelude.zipWith'. They fully-    -- satisfy the laws of Boolean algebra.-    pAnd, pOr,-    -- * Flow-control combinators-    -- | The following combinators resemble the common flow-control programming language constructs. Combinators -    -- 'wherever', 'unless', and 'select' are just the special cases of the combinator 'ifs'.-    ---    --    * /transducer/ ``wherever`` /splitter/ = 'ifs' /splitter/ /transducer/ 'Components.asis'-    ---    --    * /transducer/ ``unless`` /splitter/ = 'ifs' /splitter/ 'Components.asis' /transducer/-    ---    --    * 'select' /splitter/ = 'ifs' /splitter/ 'Components.asis' 'Components.suppress'-    ---    ifs, wherever, unless, select,-    -- ** Recursive-    while, nestedIn,-    -- * Section-based combinators-    -- | All combinators in this section use their 'Splitter' argument to determine the structure of the input. Every-    -- contiguous portion of the input that gets passed to one or the other sink of the splitter is treated as one-    -- section in the logical structure of the input stream. What is done with the section depends on the combinator,-    -- but the sections, and therefore the logical structure of the input stream, are determined by the argument-    -- splitter alone.-    foreach, having, havingOnly, followedBy, even,-    -- ** first and its variants-    first, uptoFirst, prefix,-    -- ** last and its variants-    last, lastAndAfter, suffix,-    -- ** positional splitters-    startOf, endOf,-    -- ** input ranges-    between,-    -- * parser support-    parseRegions, parseNestedRegions,-    -- * grouping helpers-    groupMarks)-where--import Control.Concurrent.Coroutine-import Control.Concurrent.SCC.Streams-import Control.Concurrent.SCC.Types--import Prelude hiding (even, last, sequence, (||), (&&))-import qualified Prelude-import Control.Exception (assert)-import Control.Monad (liftM, when)-import qualified Control.Monad as Monad-import Control.Monad.Trans (lift)-import Data.Maybe (isJust, isNothing, fromJust)-import qualified Data.Foldable as Foldable-import qualified Data.Sequence as Seq-import Data.Sequence (Seq, (|>), (><), ViewL (EmptyL, (:<)))--import Debug.Trace (trace)---- | Converts a 'Consumer' into a 'Transducer' with no output.-consumeBy :: forall m x y r. (Monad m) => Consumer m x r -> Transducer m x y-consumeBy c = Transducer $ \ source _sink -> consume c source >> return []---- | Class 'PipeableComponentPair' applies to any two components that can be combined into a third component with the--- following properties:------    * The input of the result, if any, becomes the input of the first component.------    * The output produced by the first child component is consumed by the second child component.------    * The result output, if any, is the output of the second component.-class PipeableComponentPair (m :: * -> *) w c1 c2 c3 | c1 c2 -> c3, c1 c3 -> c2, c2 c3 -> c2,-                                                       c1 -> m w, c2 -> m w, c3 -> m-   where connect :: Bool -> c1 -> c2 -> c3--instance forall m x. (ParallelizableMonad m) =>-   PipeableComponentPair m x (Producer m x ()) (Consumer m x ()) (Performer m ())-   where connect parallel p c = let performPipe :: Coroutine Naught m ((), ())-                                    performPipe = pipePS parallel (produce p) (consume c)-                                in Performer (runCoroutine performPipe >> return ())--instance (ParallelizableMonad m)-   => PipeableComponentPair m y (Transducer m x y) (Consumer m y r) (Consumer m x r)-   where connect parallel t c = isolateConsumer $ \source-> -                                liftM snd $-                                pipePS parallel-                                   (transduce t source)-                                   (consume c)--instance (ParallelizableMonad m) => PipeableComponentPair m x (Producer m x r) (Transducer m x y) (Producer m y r)-   where connect parallel p t = isolateProducer $ \sink-> -                                liftM fst $-                                pipePS parallel-                                   (produce p)-                                   (\source-> transduce t source sink)--instance ParallelizableMonad m => PipeableComponentPair m y (Transducer m x y) (Transducer m y z) (Transducer m x z)-   where connect parallel t1 t2 = isolateTransducer $ \source sink-> -                                  liftM fst $-                                  pipePS parallel-                                     (transduce t1 source)-                                     (\source-> transduce t2 source sink)--class CompatibleSignature c cons (m :: * -> *) input output | c -> cons m--class AnyListOrUnit c--instance AnyListOrUnit [x]-instance AnyListOrUnit ()--instance (AnyListOrUnit x, AnyListOrUnit y) => CompatibleSignature (Performer m r)    (PerformerType r)  m x y-instance AnyListOrUnit y                    => CompatibleSignature (Consumer m x r)   (ConsumerType r)   m [x] y-instance AnyListOrUnit y                    => CompatibleSignature (Producer m x r)   (ProducerType r)   m y [x]-instance                                       CompatibleSignature (Transducer m x y)  TransducerType    m [x] [y]--data PerformerType r-data ConsumerType r-data ProducerType r-data TransducerType---- | Class 'JoinableComponentPair' applies to any two components that can be combined into a third component with the--- following properties:------    * if both argument components consume input, the input of the combined component gets distributed to both---      components in parallel,------    * if both argument components produce output, the output of the combined component is a concatenation of the---      complete output from the first component followed by the complete output of the second component, and------    * the 'join' method may apply the components in any order, the 'sequence' method makes sure its first argument---      has completed before using the second one.-class (Monad m, CompatibleSignature c1 t1 m x y, CompatibleSignature c2 t2 m x y, CompatibleSignature c3 t3 m x y)-   => JoinableComponentPair t1 t2 t3 m x y c1 c2 c3 | c1 c2 -> c3, c1 -> t1 m, c2 -> t2 m, c3 -> t3 m x y,-                                                      t1 m x y -> c1, t2 m x y -> c2, t3 m x y -> c3-   where join :: Bool -> c1 -> c2 -> c3-         sequence :: c1 -> c2 -> c3-         join = const sequence--instance forall m x r1 r2. Monad m =>-   JoinableComponentPair (ProducerType r1) (ProducerType r2) (ProducerType r2) m () [x]-                         (Producer m x r1) (Producer m x r2) (Producer m x r2)-   where sequence p1 p2 = Producer $ \sink-> produce p1 sink >> produce p2 sink--instance forall m x. ParallelizableMonad m =>-   JoinableComponentPair (ConsumerType ()) (ConsumerType ()) (ConsumerType ()) m [x] ()-                         (Consumer m x ()) (Consumer m x ()) (Consumer m x ())-   where join parallel c1 c2 = isolateConsumer $ \source->-                               pipePS parallel-                                  (\sink1-> pipe (tee source sink1) (consume c2))-                                  (consume c1)-                               >> return ()-         sequence c1 c2 = isolateConsumer $ \source->-                          pipe-                             (\buffer-> pipe (tee source buffer) (consume c1))-                             getList-                          >>= \(_, list)-> pipe (putList list) (consume c2)-                          >> return ()--instance forall m x y. (ParallelizableMonad m) =>-   JoinableComponentPair TransducerType TransducerType TransducerType m [x] [y]-                         (Transducer m x y) (Transducer m x y) (Transducer m x y)-   where join parallel t1 t2 = isolateTransducer $ \source sink->-                                  pipe-                                     (\buffer-> pipePS parallel-                                                   (\sink1-> pipe-                                                                (\sink2-> tee source sink1 sink2)-                                                                (\src-> transduce t2 src buffer))-                                                   (\source-> transduce t1 source sink))-                                     getList-                                  >>= \(_, list)-> putList list sink-                                  >> getList source-         sequence t1 t2 = isolateTransducer $ \source sink->-                             pipe-                                (\buffer-> pipe-                                              (tee source buffer)-                                              (\source-> transduce t1 source sink))-                                getList-                             >>= \(_, list)-> pipe-                                                 (\sink-> putList list sink-                                                          >>= whenNull (pour source sink-                                                                        >> return []))-                                                 (\source-> transduce t2 source sink)-                             >>= return . fst--instance forall m r1 r2. ParallelizableMonad m =>-   JoinableComponentPair (PerformerType r1) (PerformerType r2) (PerformerType r2) m () ()-                         (Performer m r1) (Performer m r2) (Performer m r2)-   where join parallel p1 p2 = Performer $ if parallel-                                           then bindM2 (const return) (perform p1) (perform p2)-                                           else perform p1 >> perform p2-         sequence p1 p2 = Performer $ perform p1 >> perform p2--instance forall m x r1 r2. (ParallelizableMonad m) =>-   JoinableComponentPair (PerformerType r1) (ProducerType r2) (ProducerType r2) m () [x]-                         (Performer m r1) (Producer m x r2) (Producer m x r2)-   where join parallel pe pr = Producer $ \sink-> if parallel-                                                  then bindM2 (const return) (lift (perform pe)) (produce pr sink)-                                                  else lift (perform pe) >> produce pr sink-         sequence pe pr = Producer $ \sink-> lift (perform pe) >> produce pr sink--instance forall m x r1 r2. (ParallelizableMonad m) =>-   JoinableComponentPair (ProducerType r1) (PerformerType r2) (ProducerType r2) m () [x]-                         (Producer m x r1) (Performer m r2) (Producer m x r2)-   where join parallel pr pe = Producer $ \sink-> if parallel-                                                  then bindM2 (const return) (produce pr sink) (lift (perform pe))-                                                  else produce pr sink >> lift (perform pe)-         sequence pr pe = Producer $ \sink-> produce pr sink >> lift (perform pe)--instance forall m x r1 r2. (ParallelizableMonad m) =>-   JoinableComponentPair (PerformerType r1) (ConsumerType r2) (ConsumerType r2) m [x] ()-                         (Performer m r1) (Consumer m x r2) (Consumer m x r2)-   where join parallel p c = Consumer $ \source-> if parallel-                                                  then bindM2 (const return) (lift (perform p)) (consume c source)-                                                  else lift (perform p) >> consume c source-         sequence p c = Consumer $ \source-> lift (perform p) >> consume c source--instance forall m x r1 r2. (ParallelizableMonad m) =>-   JoinableComponentPair (ConsumerType r1) (PerformerType r2) (ConsumerType r2) m [x] ()-                         (Consumer m x r1) (Performer m r2) (Consumer m x r2)-   where join parallel c p = Consumer $ \source-> if parallel-                                                  then bindM2 (const return) (consume c source) (lift (perform p))-                                                  else consume c source >> lift (perform p)-         sequence c p = Consumer $ \source-> consume c source >> lift (perform p)--instance forall m x y r. (ParallelizableMonad m) =>-   JoinableComponentPair (PerformerType r) TransducerType TransducerType m [x] [y]-                         (Performer m r) (Transducer m x y) (Transducer m x y)-   where join parallel p t = Transducer $ \ source sink -> if parallel-                                                           then bindM2 (const return)-                                                                   (lift (perform p)) (transduce t source sink)-                                                           else lift (perform p) >> transduce t source sink-         sequence p t = Transducer $ \ source sink -> lift (perform p) >> transduce t source sink--instance forall m x y r. (ParallelizableMonad m)-   => JoinableComponentPair TransducerType (PerformerType r) TransducerType m [x] [y]-                            (Transducer m x y) (Performer m r) (Transducer m x y)-   where join parallel t p = Transducer $ \ source sink -> if parallel-                                                           then bindM2 (const . return)-                                                                   (transduce t source sink) (lift (perform p))-                                                           else do result <- transduce t source sink-                                                                   lift (perform p)-                                                                   return result-         sequence t p = Transducer $ \ source sink -> do result <- transduce t source sink-                                                         lift (perform p)-                                                         return result--instance forall m x y. (ParallelizableMonad m) =>-   JoinableComponentPair (ProducerType ()) TransducerType TransducerType m [x] [y]-                         (Producer m y ()) (Transducer m x y) (Transducer m x y)-   where join parallel p t = if parallel-                             then isolateTransducer $ \source sink->-                                     do (rest, out) <- pipe-                                                          (\buffer-> bindM2 (const return)-                                                                        (produce p sink) (transduce t source buffer))-                                                          getList-                                        putList out sink-                                        return rest-                             else sequence p t-         sequence p t = Transducer $ \ source sink -> produce p sink >> transduce t source sink--instance forall m x y. (ParallelizableMonad m) =>-   JoinableComponentPair TransducerType (ProducerType ()) TransducerType m [x] [y]-                         (Transducer m x y) (Producer m y ()) (Transducer m x y)-   where join parallel t p = if parallel-                             then isolateTransducer $ \source sink->-                                     do (rest, out) <- pipe-                                                          (\buffer-> bindM2 (const . return)-                                                                        (transduce t source sink)-                                                                        (produce p buffer))-                                                          getList-                                        putList out sink-                                        return rest -                             else sequence t p-         sequence t p = Transducer $ \ source sink -> do result <- transduce t source sink-                                                         produce p sink-                                                         return result--instance forall m x y. (ParallelizableMonad m) =>-   JoinableComponentPair (ConsumerType ()) TransducerType TransducerType m [x] [y]-                         (Consumer m x ()) (Transducer m x y) (Transducer m x y)-   where join parallel c t = isolateTransducer $ \source sink->-                                liftM (snd . fst) $-                                pipePS parallel-                                   (\sink1-> pipe-                                                (tee source sink1)-                                                (\source-> transduce t source sink))-                                   (consume c)-         sequence c t = isolateTransducer $ \source sink->-                           pipe-                              (\buffer-> pipe-                                            (tee source buffer)-                                            (consume c))-                              getList-                           >>= \(_, list)-> pipe-                                               (\sink-> putList list sink-                                                        >>= whenNull (pour source sink >> return []))-                                               (\source-> transduce t source sink)-                           >>= return . fst--instance forall m x y. ParallelizableMonad m =>-   JoinableComponentPair TransducerType (ConsumerType ()) TransducerType m [x] [y]-                         (Transducer m x y) (Consumer m x ()) (Transducer m x y)-   where join parallel t c = join parallel c t-         sequence t c = isolateTransducer $ \source sink->-                           pipe-                              (\buffer-> pipe-                                            (tee source buffer)-                                            (\source-> transduce t source sink))-                              getList-                           >>= \(_, list)-> pipe-                                               (\sink-> putList list sink-                                                        >>= whenNull (pour source sink-                                                                      >> return []))-                                               (consume c)-                           >>= return . fst--instance forall m x y. (ParallelizableMonad m) =>-   JoinableComponentPair (ProducerType ()) (ConsumerType ()) TransducerType m [x] [y]-                         (Producer m y ()) (Consumer m x ()) (Transducer m x y)-   where join parallel p c = Transducer $ \ source sink ->-                             if parallel-                             then bindM2 (\ _ _ -> return []) (produce p sink) (consume c source)-                             else produce p sink >> consume c source >> return []-         sequence p c = Transducer $ \ source sink -> produce p sink >> consume c source >> return []--instance forall m x y. (ParallelizableMonad m) =>-   JoinableComponentPair (ConsumerType ()) (ProducerType ()) TransducerType m [x] [y]-                         (Consumer m x ()) (Producer m y ()) (Transducer m x y)-   where join parallel c p = join parallel p c-         sequence c p = Transducer $ \ source sink -> consume c source >> produce p sink >> return []---- | Combinator 'prepend' converts the given producer to transducer that passes all its input through unmodified, except--- | for prepending the output of the argument producer to it.--- | 'prepend' /prefix/ = 'join' ('substitute' /prefix/) 'asis'-prepend :: forall m x r. (Monad m) => Producer m x r -> Transducer m x x-prepend prefix = Transducer $ \ source sink -> produce prefix sink >> pour source sink >> return []---- | Combinator 'append' converts the given producer to transducer that passes all its input through unmodified, finally--- | appending to it the output of the argument producer.--- | 'append' /suffix/ = 'join' 'asis' ('substitute' /suffix/)-append :: forall m x r. (Monad m) => Producer m x r -> Transducer m x x-append suffix = Transducer $ \ source sink -> pour source sink >> produce suffix sink >> return []---- | The 'substitute' combinator converts its argument producer to a transducer that produces the same output, while--- | consuming its entire input and ignoring it.-substitute :: forall m x y r. (Monad m) => Producer m y r -> Transducer m x y-substitute feed = Transducer $ \ source sink -> consumeAndSuppress source >> produce feed sink >> return []---- | The 'snot' (streaming not) combinator simply reverses the outputs of the argument splitter. In other words, data--- that the argument splitter sends to its /true/ sink goes to the /false/ sink of the result, and vice versa.-sNot :: forall m x b. Monad m => Splitter m x b -> Splitter m x b-sNot splitter = isolateSplitter $ \ source true false edge -> suppressProducer (split splitter source false true)---- | The '>&' combinator sends the /true/ sink output of its left operand to the input of its right operand for further--- splitting. Both operands' /false/ sinks are connected to the /false/ sink of the combined splitter, but any input--- value to reach the /true/ sink of the combined component data must be deemed true by both splitters.-sAnd :: forall m x b1 b2. ParallelizableMonad m => Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)-sAnd parallel s1 s2 =-   isolateSplitter $ \ source true false edge ->-   liftM (fst . fst . fst . fst) $-   pipe-      (\edges-> pipe-                   (\edge1-> pipe-                                (\edge2-> pipePS parallel-                                             (\true-> split s1 source true false edge1)-                                             (\source-> split s2 source true false edge2))-                                (flip (pourMap Right) edges))-                   (flip (pourMap Left) edges))-      (flip intersectRegions edge)--intersectRegions source sink = next Nothing Nothing-   where next lastLeft lastRight = get source-                                   >>= maybe-                                          (return ())-                                          (either-                                              (flip pair lastRight . Just)-                                              (pair lastLeft . Just))-         pair l@(Just x) r@(Just y) = put sink (x, y)-                                      >>= flip when (next Nothing Nothing)-         pair l r = next l r---- | A '>|' combinator's input value can reach its /false/ sink only by going through both argument splitters' /false/--- sinks.-sOr :: forall m x b1 b2. ParallelizableMonad m =>-       Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x (Either b1 b2)-sOr parallel s1 s2 = isolateSplitter $ \ source true false edge ->-                        liftM (fst . fst . fst) $-                        pipe-                           (\edge1-> pipe-                                        (\edge2-> pipePS parallel-                                                     (\false-> split s1 source true false edge1)-                                                     (\source-> split s2 source true false edge2))-                                        (flip (pourMap Right) edge))-                           (flip (pourMap Left) edge)---- | Combinator '&&' is a pairwise logical conjunction of two splitters run in parallel on the same input.-pAnd :: forall m x b1 b2. ParallelizableMonad m => Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)-pAnd parallel s1 s2 = isolateSplitter $ \ source true false edge ->-                      liftM (\(x, y)-> y ++ x) $-                         pipePS parallel-                             (transduce (splittersToPairMarker parallel s1 s2) source)-                             (\source-> let split l r = get source-                                                        >>= maybe-                                                               (return [])-                                                               (test l r)-                                            test l r (Left (x, t1, t2))-                                               = (if t1 Prelude.&& t2 then put true x else put false x)-                                                 >>= cond-                                                        (split-                                                            (if t1 then l else Nothing)-                                                            (if t2 then r else Nothing))-                                                        (return [x])-                                            test _ Nothing (Right (Left l)) = split (Just l) Nothing-                                            test _ (Just r) (Right (Left l))-                                               = put edge (l, r) >> split (Just l) (Just r)-                                            test Nothing _ (Right (Right r)) = split Nothing (Just r)-                                            test (Just l) _ (Right (Right r))-                                               = put edge (l, r) >> split (Just l) (Just r)-                                        in split Nothing Nothing)---- | Combinator '||' is a pairwise logical disjunction of two splitters run in parallel on the same input.-pOr :: forall c m x b1 b2. ParallelizableMonad m =>-       Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x (Either b1 b2)-pOr = zipSplittersWith (Prelude.||) pour--ifs :: forall c m x b. (ParallelizableMonad m, Branching c m x [x]) => Bool -> Splitter m x b -> c -> c -> c-ifs parallel s c1 c2 = combineBranches if' parallel c1 c2-   where if' :: forall d. Bool -> (forall a d'. AncestorFunctor d d' => OpenConsumer m a d' x [x]) ->-                (forall a d'. AncestorFunctor d d' => OpenConsumer m a d' x [x]) ->-                forall a. OpenConsumer m a d x [x]-         if' parallel c1 c2 source = splitInputToConsumers parallel s source c1 c2--wherever :: forall m x b. ParallelizableMonad m => Bool -> Transducer m x x -> Splitter m x b -> Transducer m x x-wherever parallel t s = isolateTransducer $ \source sink->-                           splitInputToConsumers parallel s source-                              (\source-> transduce t source sink)-                              (\source-> pour source sink >> return [])--unless :: forall m x b. ParallelizableMonad m => Bool -> Transducer m x x -> Splitter m x b -> Transducer m x x-unless parallel t s = isolateTransducer $ \source sink->-                         splitInputToConsumers parallel s source-                            (\source-> pour source sink >> return [])-                            (\source-> transduce t source sink)--select :: forall m x b. Monad m => Splitter m x b -> Transducer m x x-select s = isolateTransducer $ \source sink-> suppressProducer (suppressProducer . split s source sink)---- | Converts a splitter into a parser.-parseRegions :: forall m x b. Monad m => Splitter m x b -> Parser m x b-parseRegions s = isolateTransducer $ \source sink->-                    liftM (\(x, y)-> y ++ x) $-                    pipe-                       (transduce (splitterToMarker s) source)-                       (\source-> wrapRegions source sink)-   where wrapRegions source sink = let wrap0 mb = get source-                                                  >>= maybe-                                                         (maybe (return True) flush mb >> return [])-                                                         (wrap1 mb)-                                       wrap1 Nothing (Left (x, _)) = put sink (Content x)-                                                                     >>= cond (wrap0 Nothing) (return [x])-                                       wrap1 (Just p) (Left (x, False)) = flush p-                                                                          >> put sink (Content x)-                                                                          >>= cond-                                                                                 (wrap0 Nothing)-                                                                                 (return [x])-                                       wrap1 (Just (b, t)) (Left (x, True))-                                          = (if t then return True else put sink (Markup (Start b)))-                                            >> put sink (Content x)-                                            >>= cond (wrap0 (Just (b, True))) (return [x])-                                       wrap1 (Just p) (Right b') = flush p >> wrap0 (Just (b', False))-                                       wrap1 Nothing (Right b) = wrap0 (Just (b, False))-                                       flush (b, t) = put sink $ Markup $ (if t then End else Point) b-                                   in wrap0 Nothing---- | Converts a boundary-marking splitter into a parser.-parseNestedRegions :: forall m x b. Monad m => Splitter m x (Boundary b) -> Parser m x b-parseNestedRegions s = isolateTransducer $ \source sink->-                          liftM (\(w, (), (), _)-> w) $-                          splitToConsumers s source-                             (flip (pourMap Content) sink)-                             (flip (pourMap Content) sink)-                             (flip (pourMap Markup) sink)---- | The recursive combinator 'while' feeds the true sink of the argument splitter back to itself, modified by the--- argument transducer. Data fed to the splitter's false sink is passed on unmodified.-while :: forall m x b. ParallelizableMonad m => [(Bool, (Transducer m x x, Splitter m x b))] -> Transducer m x x-while ((parallel, (t, s)) : rest) =-   isolateTransducer $ \source sink->-      splitInputToConsumers parallel s source-         (\source-> get source-                    >>= maybe-                           (return [])-                           (\x-> liftM (uncurry (++)) $-                                 pipe-                                    (\sink-> put sink x >>= cond (pour source sink >> return []) (return [x]))-                                    (\source-> transduce while' source sink)))-         (\source-> pour source sink >> return [])-   where while' = connect parallel t (while rest)---- | The recursive combinator 'nestedIn' combines two splitters into a mutually recursive loop acting as a single--- splitter.  The true sink of one of the argument splitters and false sink of the other become the true and false sinks--- of the loop.  The other two sinks are bound to the other splitter's source.  The use of 'nestedIn' makes sense only--- on hierarchically structured streams. If we gave it some input containing a flat sequence of values, and assuming--- both component splitters are deterministic and stateless, an input value would either not loop at all or it would--- loop forever.-nestedIn :: forall m x b. ParallelizableMonad m => [(Bool, (Splitter m x b, Splitter m x b))] -> Splitter m x b-nestedIn ((parallel, (s1, s2)) : rest) =-   isolateSplitter $ \ source true false edge ->-   liftM fst $-      pipePS parallel-         (\false-> split s1 source true false edge)-         (\source-> pipe-                       (\true-> pipe (split s2 source true false) consumeAndSuppress)-                       (\source-> get source-                                  >>= maybe-                                         (return ([], []))-                                         (\x-> pipe-                                                  (\sink-> put sink x-                                                           >>= cond-                                                                  (pour source sink >> return [])-                                                                  (return [x]))-                                                  (\source-> split (nestedIn rest) source true false edge))))---- | The 'foreach' combinator is similar to the combinator 'ifs' in that it combines a splitter and two transducers into--- another transducer. However, in this case the transducers are re-instantiated for each consecutive portion of the--- input as the splitter chunks it up. Each contiguous portion of the input that the splitter sends to one of its two--- sinks gets transducered through the appropriate argument transducer as that transducer's whole input. As soon as the--- contiguous portion is finished, the transducer gets terminated.-foreach :: forall m x b c. (ParallelizableMonad m, Branching c m x [x]) => Bool -> Splitter m x b -> c -> c -> c-foreach parallel s c1 c2 = combineBranches foreach' parallel c1 c2-   where foreach' :: forall d. Bool -> -                     (forall a d'. AncestorFunctor d d' => OpenConsumer m a d' x [x]) ->-                     (forall a d'. AncestorFunctor d d' => OpenConsumer m a d' x [x]) ->-                     forall a. OpenConsumer m a d x [x]-         foreach' parallel c1 c2 source =-            liftM fst $-            pipePS parallel-               (transduce (splitterToMarker s) (liftSource source :: Source m d x))-               (\source-> groupMarks source (maybe c2 (const c1)))---- | The 'having' combinator combines two pure splitters into a pure splitter. One splitter is used to chunk the input--- into contiguous portions. Its /false/ sink is routed directly to the /false/ sink of the combined splitter. The--- second splitter is instantiated and run on each portion of the input that goes to first splitter's /true/ sink. If--- the second splitter sends any output at all to its /true/ sink, the whole input portion is passed on to the /true/--- sink of the combined splitter, otherwise it goes to its /false/ sink.-having :: forall m x b1 b2. ParallelizableMonad m => Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x b1-having parallel s1 s2 = isolateSplitter s-   where s source true false edge = liftM fst $-                                    pipePS parallel-                                       (transduce (splitterToMarker s1) source)-                                       (flip groupMarks test)-            where test Nothing chunk = pour chunk false >> return []-                  test (Just mb) chunk = pipe-                                            (\sink1-> pipe (tee chunk sink1) getList)-                                            (\chunk-> splitToConsumers s2 chunk-                                                         (liftM isJust . get)-                                                         consumeAndSuppress-                                                         (liftM isJust . get))-                                         >>= \(((), prefix), (_, anyTrue, (), anyEdge))->-                                             if anyTrue Prelude.|| anyEdge-                                             then maybe (return True) (put edge) mb-                                                  >> putList prefix true-                                                  >>= whenNull (pour chunk true >> return [])-                                             else putList prefix false-                                                  >>= whenNull (pour chunk false >> return [])---- | The 'havingOnly' combinator is analogous to the 'having' combinator, but it succeeds and passes each chunk of the--- input to its /true/ sink only if the second splitter sends no part of it to its /false/ sink.-havingOnly :: forall m x b1 b2. ParallelizableMonad m => Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x b1-havingOnly parallel s1 s2 = isolateSplitter s-   where s source true false edge = liftM fst $-                                    pipePS parallel-                                       (transduce (splitterToMarker s1) source)-                                       (flip groupMarks test)-            where test Nothing chunk = pour chunk false >> return []-                  test (Just mb) chunk = pipe-                                            (\sink1-> pipe (tee chunk sink1) getList)-                                            (\chunk-> splitToConsumers s2 chunk-                                                         consumeAndSuppress-                                                         (liftM isJust . get)-                                                         consumeAndSuppress)-                                         >>= \(((), prefix), (_, (), anyFalse, ()))->-                                             if anyFalse-                                             then putList prefix false-                                                  >>= whenNull (pour chunk false >> return [])-                                             else maybe (return True) (put edge) mb-                                                  >> putList prefix true-                                                  >>= whenNull (pour chunk true >> return [])---- | The result of combinator 'first' behaves the same as the argument splitter up to and including the first portion of--- the input which goes into the argument's /true/ sink. All input following the first true portion goes into the--- /false/ sink.-first :: forall m x b. Monad m => Splitter m x b -> Splitter m x b-first splitter = isolateSplitter $ \ source true false edge ->-                 liftM (\(x, y)-> y ++ x) $-                 pipe-                    (transduce (splitterToMarker splitter) source)-                    (\source-> let get1 (Left (x, False)) = pass false x get1-                                   get1 (Left (x, True)) = pass true x get2-                                   get1 (Right b) = put edge b-                                                    >> get source-                                                    >>= maybe (return []) get2-                                   get2 b@Right{} = get3 b-                                   get2 (Left (x, True)) = pass true x get2-                                   get2 (Left (x, False)) = pass false x get3-                                   get3 (Left (x, _)) = pass false x get3-                                   get3 (Right _) = get source >>= maybe (return []) get3-                                   pass sink x next = put sink x-                                                      >>= cond-                                                             (get source-                                                              >>= maybe (return []) next)-                                                             (return [x])-                               in get source >>= maybe (return []) get1)---- | The result of combinator 'uptoFirst' takes all input up to and including the first portion of the input which goes--- into the argument's /true/ sink and feeds it to the result splitter's /true/ sink. All the rest of the input goes--- into the /false/ sink. The only difference between 'first' and 'uptoFirst' combinators is in where they direct the--- /false/ portion of the input preceding the first /true/ part.-uptoFirst :: forall m x b. Monad m => Splitter m x b -> Splitter m x b-uptoFirst splitter = isolateSplitter $ \ source true false edge ->-                     liftM (\(x, y)-> y ++ x) $-                     pipe-                        (transduce (splitterToMarker splitter) source)-                        (\source-> let get1 q (Left (x, False)) = let q' = q |> x-                                                                  in get source-                                                                        >>= maybe-                                                                               (putQueue q' false)-                                                                               (get1 q')-                                       get1 q p@(Left (_, True)) = putQueue q true-                                                                   >>= whenNull (get2 p)-                                       get1 q (Right b) = putQueue q true-                                                          >>= whenNull (put edge b-                                                                        >> get source-                                                                        >>= maybe (return []) get2)-                                       get2 b@Right{} = get3 b-                                       get2 (Left (x, True)) = pass true x get2-                                       get2 (Left (x, False)) = pass false x get3-                                       get3 (Left (x, _)) = pass false x get3-                                       get3 (Right _) = get source >>= maybe (return []) get3-                                       pass sink x next = put sink x-                                                          >>= cond-                                                                 (get source-                                                                  >>= maybe (return []) next)-                                                                 (return [x])-                                   in get source >>= maybe (return []) (get1 Seq.empty))---- | The result of the combinator 'last' is a splitter which directs all input to its /false/ sink, up to the last--- portion of the input which goes to its argument's /true/ sink. That portion of the input is the only one that goes to--- the resulting component's /true/ sink.  The splitter returned by the combinator 'last' has to buffer the previous two--- portions of its input, because it cannot know if a true portion of the input is the last one until it sees the end of--- the input or another portion succeeding the previous one.-last :: forall m x b. Monad m => Splitter m x b -> Splitter m x b-last splitter = isolateSplitter $ \ source true false edge ->-                liftM (\(x, y)-> y ++ x) $-                pipe-                   (transduce (splitterToMarker splitter) source)-                   (\source-> let get1 (Left (x, False)) = put false x-                                                           >>= cond (get source-                                                                     >>= maybe (return []) get1)-                                                                  (return [x])-                                  get1 p@(Left (x, True)) = get2 Nothing Seq.empty p-                                  get1 (Right b) = pass (get2 (Just b) Seq.empty)-                                  get2 mb q (Left (x, True)) = let q' = q |> x-                                                               in get source-                                                                  >>= maybe-                                                                         (flush mb q')-                                                                         (get2 mb q')-                                  get2 mb q p = get3 mb q Seq.empty p-                                  get3 mb qt qf (Left (x, False)) =-                                     let qf' = qf |> x-                                     in get source-                                        >>= maybe-                                               (flush mb qt >> putQueue qf' false)-                                               (get3 mb qt qf')-                                  get3 mb qt qf p = do rest1 <- putQueue qt false-                                                       rest2 <- putQueue qf false-                                                       if null rest1 Prelude.&& null rest2-                                                          then get1 p-                                                          else return (rest1 ++ rest2)-                                  flush mb q = maybe (return True) (put edge) mb-                                               >> putQueue q true-                                  pass succeed = get source >>= maybe (return []) succeed-                              in pass get1)---- | The result of the combinator 'lastAndAfter' is a splitter which directs all input to its /false/ sink, up to the--- last portion of the input which goes to its argument's /true/ sink. That portion and the remainder of the input is--- fed to the resulting component's /true/ sink. The difference between 'last' and 'lastAndAfter' combinators is where--- they feed the /false/ portion of the input, if any, remaining after the last /true/ part.-lastAndAfter :: forall m x b. Monad m => Splitter m x b -> Splitter m x b-lastAndAfter splitter = isolateSplitter $ \ source true false edge ->-                        liftM (\(x, y)-> y ++ x) $-                        pipe-                           (transduce (splitterToMarker splitter) source)-                           (\source-> let get1 (Left (x, False)) = put false x-                                                                   >>= cond-                                                                          (pass get1)-                                                                          (return [x])-                                          get1 p@(Left (x, True)) = get2 Nothing Seq.empty p-                                          get1 (Right b) = pass (get2 (Just b) Seq.empty)-                                          get2 mb q (Left (x, True)) = let q' = q |> x-                                                                       in get source-                                                                          >>= maybe-                                                                                 (flush mb q')-                                                                                 (get2 mb q')-                                          get2 mb q p = get3 mb q p-                                          get3 mb q (Left (x, False)) = let q' = q |> x-                                                                        in get source-                                                                           >>= maybe-                                                                                  (flush mb q')-                                                                                  (get3 mb q')-                                          get3 _ q p@(Left (x, True)) = putQueue q false-                                                                        >>= whenNull (get1 p)-                                          get3 _ q b'@Right{} = putQueue q false-                                                                >>= whenNull (get1 b')-                                          flush mb q = maybe (return True) (put edge) mb-                                                       >> putQueue q true-                                          pass succeed = get source >>= maybe (return []) succeed-                                      in pass get1)---- | The 'prefix' combinator feeds its /true/ sink only the prefix of the input that its argument feeds to its /true/--- sink.  All the rest of the input is dumped into the /false/ sink of the result.-prefix :: forall m x b. Monad m => Splitter m x b -> Splitter m x b-prefix splitter = isolateSplitter $ \ source true false edge ->-                  liftM (\(x, y)-> y ++ x) $-                  pipe-                     (transduce (splitterToMarker splitter) source)-                     (\source-> let get0 p@Left{} = get1 p-                                    get0 (Right b) = put edge b-                                                     >> get source-                                                     >>= maybe (return []) get1-                                    get1 (Left (x, False)) = pass false x get2-                                    get1 (Left (x, True)) = pass true x get1-                                    get1 (Right b) = get source >>= maybe (return []) get2-                                    get2 (Left (x, _)) = pass false x get2-                                    get2 Right{} = get source >>= maybe (return []) get2-                                    pass sink x next = put sink x-                                                       >>= cond-                                                              (get source-                                                               >>= maybe (return []) next)-                                                              (return [x])-                                in get source >>= maybe (return []) get0)---- | The 'suffix' combinator feeds its /true/ sink only the suffix of the input that its argument feeds to its /true/--- sink.  All the rest of the input is dumped into the /false/ sink of the result.-suffix :: forall m x b. Monad m => Splitter m x b -> Splitter m x b-suffix splitter = isolateSplitter $ \ source true false edge ->-                  liftM (\(x, y)-> y ++ x) $-                  pipe-                     (transduce (splitterToMarker splitter) source)-                     (\source-> let get1 (Left (x, False)) = put false x-                                                             >>= cond (p get1) (return [x])-                                    get1 (Left (x, True)) = get2 Nothing (Seq.singleton x)-                                    get1 (Right b) = get2 (Just b) Seq.empty-                                    get2 mb q = get source-                                                >>= maybe-                                                       (maybe (return True) (put edge) mb-                                                        >> putQueue q true)-                                                       (get3 mb q)-                                    get3 mb q (Left (x, True)) = get2 mb (q |> x)-                                    get3 mb q p@(Left (x, False)) =-                                       putQueue q false-                                       >>= \rest-> if null rest-                                                   then get1 p-                                                   else return (rest ++ [x])-                                    get3 mb q (Right b) = putQueue q false-                                                          >>= whenNull (get2 (Just b) Seq.empty)-                                    p succeed = get source >>= maybe (return []) succeed-                                in p get1)---- | The 'even' combinator takes every input section that its argument /splitter/ deems /true/, and feeds even ones into--- its /true/ sink. The odd sections and parts of input that are /false/ according to its argument splitter are fed to--- 'even' splitter's /false/ sink.-even :: forall m x b. Monad m => Splitter m x b -> Splitter m x b-even splitter = isolateSplitter $ \ source true false edge ->-                liftM (\(x, y)-> y ++ x) $-                   pipe-                      (transduce (splitterToMarker splitter) source)-                      (\source-> let get1 (Left (x, False)) = put false x-                                                              >>= cond (next get1) (return [x])-                                     get1 p@(Left (x, True)) = get2 p-                                     get1 (Right b) = next get2-                                     get2 (Left (x, True)) = put false x-                                                             >>= cond (next get2) (return [x])-                                     get2 p@(Left (x, False)) = get3 p-                                     get2 (Right b) = put edge b >> next get4-                                     get3 (Left (x, False)) = put false x-                                                              >>= cond (next get3) (return [x])-                                     get3 p@(Left (x, True)) = get4 p-                                     get3 (Right b) = put edge b >> next get4-                                     get4 (Left (x, True)) = put true x-                                                             >>= cond (next get4) (return [x])-                                     get4 p@(Left (x, False)) = get1 p-                                     get4 (Right b) = next get2-                                     next g = get source >>= maybe (return []) g-                                 in next get1)---- | Splitter 'startOf' issues an empty /true/ section at the beginning of every section considered /true/ by its--- argument splitter, otherwise the entire input goes into its /false/ sink.-startOf :: forall m x b. Monad m => Splitter m x b -> Splitter m x (Maybe b)-startOf splitter = isolateSplitter $ \ source true false edge ->-                   liftM (\(x, y)-> y ++ x) $-                   pipe-                      (transduce (splitterToMarker splitter) source)-                      (\source-> let get1 (Left (x, False)) = put false x-                                                              >>= cond-                                                                     (next get1)-                                                                     (return [x])-                                     get1 p@(Left (x, True)) = put edge Nothing >> get2 p-                                     get1 (Right b) = put edge (Just b)-                                                      >> next get2-                                     get2 (Left (x, True)) = put false x-                                                             >>= cond-                                                                    (next get2)-                                                                    (return [x])-                                     get2 p = get1 p-                                     next g = get source >>= maybe (return []) g-                                 in next get1)---- | Splitter 'endOf' issues an empty /true/ section at the end of every section considered /true/ by its argument--- splitter, otherwise the entire input goes into its /false/ sink.-endOf :: forall m x b. Monad m => Splitter m x b -> Splitter m x (Maybe b)-endOf splitter = isolateSplitter $ \ source true false edge ->-                 liftM (\(x, y)-> y ++ x) $-                 pipe-                    (transduce (splitterToMarker splitter) source)-                    (\source-> let get1 (Left (x, False)) = put false x-                                                            >>= cond-                                                                   (next get1)-                                                                   (return [x])-                                   get1 p@(Left (x, True)) = get2 Nothing p-                                   get1 (Right b) = next (get2 $ Just b)-                                   get2 mb (Left (x, True))-                                      = put false x-                                        >>= cond (next $ get2 mb) (return [x])-                                   get2 mb p@(Left (x, False)) = put edge mb >> get1 p-                                   get2 mb (Right b) = put edge mb >> next (get2 $ Just b)-                                   next g = get source >>= maybe (return []) g-                               in next get1)---- | Combinator 'followedBy' treats its argument 'Splitter's as patterns components and returns a 'Splitter' that--- matches their concatenation. A section of input is considered /true/ by the result iff its prefix is considered--- /true/ by argument /s1/ and the rest of the section is considered /true/ by /s2/. The splitter /s2/ is started anew--- after every section split to /true/ sink by /s1/.-followedBy :: forall m x b1 b2. ParallelizableMonad m =>-              Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)-followedBy parallel s1 s2 = -   isolateSplitter $ \ source true false edge ->-   liftM (\(x, y)-> y ++ x) $-   pipePS parallel-      (transduce (splitterToMarker s1) source)-      (\source-> let get0 q = case Seq.viewl q-                              of Seq.EmptyL -> get source >>= maybe (return []) get1-                                 (Left (x, False)) :< rest -> put false x-                                                              >>= cond-                                                                     (get0 rest)-                                                                     (return-                                                                      $ concatMap (either ((:[]) . fst) (const []))-                                                                           $ Foldable.toList $ Seq.viewl q)-                                 (Left (x, True)) :< rest -> get2 Nothing Seq.empty q-                                 (Right b) :< rest -> get2 (Just b) Seq.empty rest-                     get1 (Left (x, False)) = put false x-                                              >>= cond (get source >>= maybe (return []) get1)-                                                       (return [x])-                     get1 p@(Left (x, True)) = get2 Nothing Seq.empty (Seq.singleton p)-                     get1 (Right b) = get2 (Just b) Seq.empty Seq.empty-                     get2 mb q q' = case Seq.viewl q'-                                    of Seq.EmptyL -> get source-                                                     >>= maybe (testEnd mb q) (get2 mb q . Seq.singleton)-                                       (Left (x, True)) :< rest -> get2 mb (q |> x) rest-                                       (Left (x, False)) :< rest -> get3 mb q q'-                                       Right{} :< rest -> get3 mb q q'-                     get3 mb q q' = do ((q1, q2), n) <- pipe (get7 Seq.empty q') (test mb q)-                                       case n of Nothing -> putQueue q false-                                                            >>= whenNull (get0 (q1 >< q2))-                                                 Just 0 -> get0 (q1 >< q2)-                                                 Just n -> get8 (Just mb) n (q1 >< q2)-                     get7 q1 q2 sink = canPut sink-                                       >>= cond (case Seq.viewl q2-                                                 of Seq.EmptyL -> get source-                                                                  >>= maybe (return (q1, q2))-                                                                         (\p-> either-                                                                                  (put sink . fst)-                                                                                  (const $ return True)-                                                                                  p-                                                                               >> get7 (q1 |> p) q2 sink)-                                                    p :< rest -> either-                                                                    (put sink . fst)-                                                                    (const $ return True) p-                                                                 >> get7 (q1 |> p) rest sink)-                                                (return (q1, q2))-                     testEnd mb q = do ((), n) <- pipe (const $ return ()) (test mb q)-                                       case n of Nothing -> putQueue q false-                                                 _ -> return []-                     test mb q source = liftM snd $-                                        pipe-                                           (transduce (splitterToMarker s2) source)-                                           (\source-> let get4 (Left (_, False)) = return Nothing-                                                          get4 p@(Left (_, True)) = putQueue q true-                                                                                    >> get5 0 p-                                                          get4 p@(Right b) = maybe-                                                                                (return True)-                                                                                (\b1-> put edge (b1, b)) mb-                                                                             >> putQueue q true-                                                                             >> get6 0-                                                          get5 n (Left (x, True)) = put true x-                                                                                    >> get6 (succ n)-                                                          get5 n _ = return (Just n)-                                                          get6 n = get source-                                                                   >>= maybe-                                                                          (return $ Just n)-                                                                          (get5 n)-                                                      in get source >>= maybe (return Nothing) get4)-                     get8 Nothing 0 q = get0 q-                     get8 (Just mb) 0 q = get2 mb Seq.empty q-                     get8 mmb n q = case Seq.viewl q of Left (x, False) :< rest -> get8 Nothing (pred n) rest-                                                        Left (x, True) :< rest-                                                           -> get8 (maybe (Just Nothing) Just mmb) (pred n) rest-                                                        Right b :< rest -> get8 (Just (Just b)) n rest-                in get0 Seq.empty)---- | Combinator '...' tracks the running balance of difference between the number of preceding starts of sections--- considered /true/ according to its first argument and the ones according to its second argument. The combinator--- passes to /true/ all input values for which the difference balance is positive. This combinator is typically used--- with 'startOf' and 'endOf' in order to count entire input sections and ignore their lengths.-between :: forall m x b1 b2. ParallelizableMonad m => Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x b1-between parallel s1 s2 = isolateSplitter $ \ source true false edge ->-                         liftM (\(x, y)-> y ++ x) $-                         pipePS parallel-                            (transduce (splittersToPairMarker parallel s1 s2) source)-                            (\source-> let next n = get source >>= maybe (return []) (state n)-                                           pass n x = (if n > 0 then put true x else put false x)-                                                      >>= cond (next n) (return [x])-                                           pass' n x = (if n >= 0 then put true x else put false x)-                                                       >>= cond (next n) (return [x])-                                           state n (Left (x, True, False)) = pass (succ n) x-                                           state n (Left (x, False, True)) = pass' (pred n) x-                                           state n (Left (x, True, True)) = pass' n x-                                           state n (Left (x, False, False)) = pass n x-                                           state 0 (Right (Left b)) = put edge b >> next 1-                                           state n (Right (Left _)) = next (succ n)-                                           state n (Right (Right _)) = next (pred n)-                                       in next 0)---- Helper functions--splitterToMarker :: forall m x b. Monad m => Splitter m x b -> Transducer m x (Either (x, Bool) b)-splitterToMarker s = isolateTransducer $ \source sink->-                        let mark f source = canPut sink-                                            >>= cond-                                                   (get source-                                                    >>= maybe (return [])-                                                           (\x-> put sink (f x)-                                                                 >>= cond-                                                                        (mark f source)-                                                                        (return [x])))-                                                   (return [])-                        in liftM (\(x, y, z, _)-> z ++ y ++ x) $-                           splitToConsumers s source-                              (mark (\x-> Left (x, True)))-                              (mark (\x-> Left (x, False)))-                              (mark Right)--splittersToPairMarker :: forall m x b1 b2. (ParallelizableMonad m) => Bool -> Splitter m x b1 -> Splitter m x b2 ->-                         Transducer m x (Either (x, Bool, Bool) (Either b1 b2))-splittersToPairMarker parallel s1 s2 =-   let t source sink = -          liftM (\(((_, _), (x, _, _, _)), _)-> x) $-             pipe-                (\sync-> pipePS parallel-                            (\sink1-> pipe-                                         (tee source sink1)-                                         (\source2-> splitToConsumers s2 source2-                                                        (flip (pourMap (\x-> Left ((x, True), False))) sync)-                                                        (flip (pourMap (\x-> Left ((x, False), False))) sync)-                                                        (flip (pourMap (Right . Right)) sync)))-                            (\source1-> splitToConsumers s1 source1-                                           (flip (pourMap (\x-> Left ((x, True), True))) sync)-                                           (flip (pourMap (\x-> Left ((x, False), True))) sync)-                                           (flip (pourMap (Right. Left)) sync)))-                 (synchronizeMarks Nothing sink)-       -- synchronizeMarks :: Maybe (Seq (Either (x, Bool) (Either b1 b2)), Bool)-       --                  -> Sink m c (Either (x, Bool, Bool) (Either b1 b2))-       --                  -> Source m c (Either ((x, Bool), Bool) (Either b1 b2))-       --                  -> Coroutine c m [x]-       synchronizeMarks state sink source = get source-                                            >>= maybe-                                                   (assert (isNothing state) (return []))-                                                   (handleMark state sink source)-       -- handleMark :: Maybe (Seq (Either (x, Bool) (Either b1 b2)), Bool)-       --            -> Sink m c (Either (x, Bool, Bool) (Either b1 b2))-       --            -> Source m c (Either ((x, Bool), Bool) (Either b1 b2))-       --            -> Either ((x, Bool), Bool) (Either b1 b2) -> Coroutine c m [x]-       handleMark Nothing sink source (Right b) = put sink (Right b)-                                                  >> synchronizeMarks Nothing sink source-       handleMark Nothing sink source (Left (p, first))-          = synchronizeMarks (Just (Seq.singleton (Left p), first)) sink source-       handleMark state@(Just (q, first)) sink source (Left (p, first')) | first == first'-          = synchronizeMarks (Just (q |> Left p, first)) sink source-       handleMark state@(Just (q, True)) sink source (Right b@Left{})-          = synchronizeMarks (Just (q |> Right b, True)) sink source-       handleMark state@(Just (q, False)) sink source (Right b@Right{})-          = synchronizeMarks (Just (q |> Right b, False)) sink source-       handleMark state sink source (Right b) = put sink (Right b) >> synchronizeMarks state sink source-       handleMark state@(Just (q, pos')) sink source mark@(Left ((x, t), pos))-          = case Seq.viewl q-            of Seq.EmptyL -> synchronizeMarks (Just (Seq.singleton (Left (x, t)), pos)) sink source-               Right b :< rest -> put sink (Right b)-                                  >>= cond-                                         (handleMark-                                             (if Seq.null rest then Nothing else Just (rest, pos'))-                                             sink-                                             source-                                             mark)-                                         (returnQueuedList q)-               Left (y, t') :< rest -> put sink (Left $ if pos then (y, t, t') else (y, t', t))-                                       >>= cond-                                              (synchronizeMarks-                                                  (if Seq.null rest then Nothing else Just (rest, pos'))-                                                  sink-                                                  source)-                                              (returnQueuedList q)-       returnQueuedList q = return $ concatMap (either ((:[]) . fst) (const [])) $ Foldable.toList $ Seq.viewl q-   in isolateTransducer t--zipSplittersWith :: forall m x b1 b2 b. ParallelizableMonad m => -                    (Bool -> Bool -> Bool) -> -                    (forall a1 a2 d. (AncestorFunctor a1 d, AncestorFunctor a2 d) =>-                     Source m a1 (Either b1 b2) -> Sink m a2 b -> Coroutine d m ()) -> -                    Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x b-zipSplittersWith f boundaries parallel s1 s2-   = isolateSplitter $ \ source true false edge ->-     liftM (\((x, y), _)-> y ++ x) $-     pipe-        (\edge->-         pipePS parallel-            (transduce (splittersToPairMarker parallel s1 s2) source)-            (\source-> let split = get source-                                   >>= maybe-                                          (return [])-                                          (either-                                              test-                                              (\b-> put edge b >> split))-                           test (x, t1, t2) = (if f t1 t2 then put true x else put false x)-                                              >>= cond split (return [x])-                       in split))-        (flip boundaries edge)---- | Runs the second argument on every contiguous region of input source (typically produced by 'splitterToMarker')--- whose all values either match @Left (_, True)@ or @Left (_, False)@.-groupMarks :: (Monad m, AncestorFunctor a d, AncestorFunctor a (SinkFunctor d x)) =>-              Source m a (Either (x, Bool) b) ->-              (Maybe (Maybe b) -> Source m (SourceFunctor d x) x -> Coroutine (SourceFunctor d x) m r) ->-              Coroutine d m ()-groupMarks source getConsumer = start-   where start = getSuccess source (either startContent startRegion)-         startContent (x, False) = pipe (\sink-> pass False sink x) (getConsumer Nothing)-                                   >>= maybe (return ()) (either startContent startRegion) . fst-         startContent (x, True) = pipe (\sink-> pass True sink x) (getConsumer $ Just Nothing)-                                  >>= maybe (return ()) (either startContent startRegion) . fst-         startRegion b = pipe (next True) (getConsumer (Just $ Just b))-                         >>= maybe (return ()) (either startContent startRegion) . fst-         pass t sink x = put sink x >> next t sink-         next t sink = get source >>= maybe (return Nothing) (continue t sink)-         continue t sink (Left (x, t')) | t == t' = pass t sink x-         continue t sink p = return (Just p)---- | 'suppressProducer' runs the /producer/ argument with a new sink, suppressing everything 'put' in the sink.-suppressProducer :: forall m a x r. (Functor a, Monad m) => -                    (Sink m (SinkFunctor a x) x -> Coroutine (SinkFunctor a x) m r) -> Coroutine a m r-suppressProducer producer = liftM fst $ pipe producer consumeAndSuppress-+    Copyright 2008-2010 Mario Blazevic++    This file is part of the Streaming Component Combinators (SCC) project.++    The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public+    License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later+    version.++    SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty+    of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more details.++    You should have received a copy of the GNU General Public License along with SCC.  If not, see+    <http://www.gnu.org/licenses/>.+-}++{-# LANGUAGE ScopedTypeVariables, Rank2Types, KindSignatures, EmptyDataDecls,+             MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, FunctionalDependencies, TypeFamilies #-}++-- | The "Combinators" module defines combinators applicable to values of the 'Transducer' and 'Splitter' types defined+-- in the "Control.Concurrent.SCC.Types" module.++module Control.Concurrent.SCC.Combinators+   (-- * Consumer, producer, and transducer combinators+    splitterToMarker,+    consumeBy, prepend, append, substitute,+    PipeableComponentPair (compose), JoinableComponentPair (join, sequence),+    -- * Pseudo-logic splitter combinators+    -- | Combinators 'sAnd' and 'sOr' are only /pseudo/-logic. While the laws of double negation and De Morgan's laws+    -- hold, 'sAnd' and 'sOr' are in general not commutative, associative, nor idempotent. In the special case when all+    -- argument splitters are stateless, such as those produced by 'Control.Concurrent.SCC.Types.statelessSplitter',+    -- these combinators do satisfy all laws of Boolean algebra.+    sNot, sAnd, sOr,+    -- ** Zipping logic combinators+    -- | The 'pAnd' and 'pOr' combinators run the argument splitters in parallel and combine their logical outputs using+    -- the corresponding logical operation on each output pair, in a manner similar to 'Data.List.zipWith'. They fully+    -- satisfy the laws of Boolean algebra.+    pAnd, pOr,+    -- * Flow-control combinators+    -- | The following combinators resemble the common flow-control programming language constructs. Combinators +    -- 'wherever', 'unless', and 'select' are just the special cases of the combinator 'ifs'.+    --+    --    * /transducer/ ``wherever`` /splitter/ = 'ifs' /splitter/ /transducer/ 'Control.Category.id'+    --+    --    * /transducer/ ``unless`` /splitter/ = 'ifs' /splitter/ 'Control.Category.id' /transducer/+    --+    --    * 'select' /splitter/ = 'ifs' /splitter/ 'Control.Category.id'+    --    'Control.Concurrent.SCC.Primitives.suppress'+    --+    ifs, wherever, unless, select,+    -- ** Recursive+    while, nestedIn,+    -- * Section-based combinators+    -- | All combinators in this section use their 'Control.Concurrent.SCC.Splitter' argument to determine the structure+    -- of the input. Every contiguous portion of the input that gets passed to one or the other sink of the splitter is+    -- treated as one section in the logical structure of the input stream. What is done with the section depends on the+    -- combinator, but the sections, and therefore the logical structure of the input stream, are determined by the+    -- argument splitter alone.+    foreach, having, havingOnly, followedBy, even,+    -- ** first and its variants+    first, uptoFirst, prefix,+    -- ** last and its variants+    last, lastAndAfter, suffix,+    -- ** positional splitters+    startOf, endOf,+    -- ** input ranges+    between,+    -- * parser support+    parseRegions, parseNestedRegions,+    -- * helper functions+    groupMarks, findsTrueIn, findsFalseIn, teeConsumers)+where++import Control.Monad.Coroutine+import Control.Monad.Parallel (MonadParallel(..))++import Control.Concurrent.SCC.Streams+import Control.Concurrent.SCC.Types++import Prelude hiding (even, last, sequence)+import Control.Category ((>>>))+import Control.Monad (liftM, when)+import qualified Control.Monad as Monad+import Control.Monad.Trans (lift)+import Data.Maybe (isJust, isNothing, fromJust)+import qualified Data.Foldable as Foldable+import qualified Data.Sequence as Seq+import Data.Sequence (Seq, (|>), (><), ViewL (EmptyL, (:<)))++import qualified Control.Category+import qualified Data.List++-- | Converts a 'Consumer' into a 'Transducer' with no output.+consumeBy :: forall m x y r. (Monad m) => Consumer m x r -> Transducer m x y+consumeBy c = Transducer $ \ source _sink -> consume c source >> return ()++-- | Class 'PipeableComponentPair' applies to any two components that can be combined into a third component with the+-- following properties:+--+--    * The input of the result, if any, becomes the input of the first component.+--+--    * The output produced by the first child component is consumed by the second child component.+--+--    * The result output, if any, is the output of the second component.+class PipeableComponentPair (m :: * -> *) w c1 c2 c3 | c1 c2 -> c3, c1 c3 -> c2, c2 c3 -> c2,+                                                       c1 -> m w, c2 -> m w, c3 -> m+   where compose :: Bool -> c1 -> c2 -> c3++instance forall m x. (MonadParallel m) =>+   PipeableComponentPair m x (Producer m x ()) (Consumer m x ()) (Performer m ())+   where compose parallel p c = let performPipe :: Coroutine Naught m ((), ())+                                    performPipe = pipePS parallel (produce p) (consume c)+                                in Performer (runCoroutine performPipe >> return ())++instance (MonadParallel m)+   => PipeableComponentPair m y (Transducer m x y) (Consumer m y r) (Consumer m x r)+   where compose parallel t c = isolateConsumer $ \source-> +                                liftM snd $+                                pipePS parallel+                                   (transduce t source)+                                   (consume c)++instance (MonadParallel m) => PipeableComponentPair m x (Producer m x r) (Transducer m x y) (Producer m y r)+   where compose parallel p t = isolateProducer $ \sink-> +                                liftM fst $+                                pipePS parallel+                                   (produce p)+                                   (\source-> transduce t source sink)++instance MonadParallel m => PipeableComponentPair m y (Transducer m x y) (Transducer m y z) (Transducer m x z)+   where compose parallel t1 t2 = if parallel then t1 >|> t2 else t1 >>> t2++class CompatibleSignature c cons (m :: * -> *) input output | c -> cons m++class AnyListOrUnit c++instance AnyListOrUnit [x]+instance AnyListOrUnit ()++instance (AnyListOrUnit x, AnyListOrUnit y) => CompatibleSignature (Performer m r)    (PerformerType r)  m x y+instance AnyListOrUnit y                    => CompatibleSignature (Consumer m x r)   (ConsumerType r)   m [x] y+instance AnyListOrUnit y                    => CompatibleSignature (Producer m x r)   (ProducerType r)   m y [x]+instance                                       CompatibleSignature (Transducer m x y)  TransducerType    m [x] [y]++data PerformerType r+data ConsumerType r+data ProducerType r+data TransducerType++-- | Class 'JoinableComponentPair' applies to any two components that can be combined into a third component with the+-- following properties:+--+--    * if both argument components consume input, the input of the combined component gets distributed to both+--      components in parallel,+--+--    * if both argument components produce output, the output of the combined component is a concatenation of the+--      complete output from the first component followed by the complete output of the second component, and+--+--    * the 'join' method may apply the components in any order, the 'sequence' method makes sure its first argument+--      has completed before using the second one.+class (Monad m, CompatibleSignature c1 t1 m x y, CompatibleSignature c2 t2 m x y, CompatibleSignature c3 t3 m x y)+   => JoinableComponentPair t1 t2 t3 m x y c1 c2 c3 | c1 c2 -> c3, c1 -> t1 m, c2 -> t2 m, c3 -> t3 m x y,+                                                      t1 m x y -> c1, t2 m x y -> c2, t3 m x y -> c3+   where join :: Bool -> c1 -> c2 -> c3+         sequence :: c1 -> c2 -> c3+         join = const sequence++instance forall m x r1 r2. Monad m =>+   JoinableComponentPair (ProducerType r1) (ProducerType r2) (ProducerType r2) m () [x]+                         (Producer m x r1) (Producer m x r2) (Producer m x r2)+   where sequence p1 p2 = Producer $ \sink-> produce p1 sink >> produce p2 sink++instance forall m x. MonadParallel m =>+   JoinableComponentPair (ConsumerType ()) (ConsumerType ()) (ConsumerType ()) m [x] ()+                         (Consumer m x ()) (Consumer m x ()) (Consumer m x ())+   where join parallel c1 c2 = Consumer (liftM (const ()) . teeConsumers parallel (consume c1) (consume c2))+         sequence c1 c2 = Consumer $ \source->+                          teeConsumers False (consume c1) getList source+                          >>= \((), list)-> pipe (putList list) (consume c2)+                          >> return ()++instance forall m x y. (MonadParallel m) =>+   JoinableComponentPair TransducerType TransducerType TransducerType m [x] [y]+                         (Transducer m x y) (Transducer m x y) (Transducer m x y)+   where join parallel t1 t2 = isolateTransducer $ \source sink->+                               pipe+                                  (\buffer-> teeConsumers parallel+                                                (\source-> transduce t1 source sink)+                                                (\source-> transduce t2 source buffer)+                                                source)+                                  getList+                               >>= \(_, list)-> putList list sink+         sequence t1 t2 = isolateTransducer $ \source sink->+                          teeConsumers False (flip (transduce t1) sink) getList source+                          >>= \(_, list)-> pipe (putList list) (\source-> transduce t2 source sink)+                          >> return ()++instance forall m r1 r2. MonadParallel m =>+   JoinableComponentPair (PerformerType r1) (PerformerType r2) (PerformerType r2) m () ()+                         (Performer m r1) (Performer m r2) (Performer m r2)+   where join parallel p1 p2 = Performer $ if parallel+                                           then bindM2 (const return) (perform p1) (perform p2)+                                           else perform p1 >> perform p2+         sequence p1 p2 = Performer $ perform p1 >> perform p2++instance forall m x r1 r2. (MonadParallel m) =>+   JoinableComponentPair (PerformerType r1) (ProducerType r2) (ProducerType r2) m () [x]+                         (Performer m r1) (Producer m x r2) (Producer m x r2)+   where join parallel pe pr = Producer $ \sink-> if parallel+                                                  then bindM2 (const return) (lift (perform pe)) (produce pr sink)+                                                  else lift (perform pe) >> produce pr sink+         sequence pe pr = Producer $ \sink-> lift (perform pe) >> produce pr sink++instance forall m x r1 r2. (MonadParallel m) =>+   JoinableComponentPair (ProducerType r1) (PerformerType r2) (ProducerType r2) m () [x]+                         (Producer m x r1) (Performer m r2) (Producer m x r2)+   where join parallel pr pe = Producer $ \sink-> if parallel+                                                  then bindM2 (const return) (produce pr sink) (lift (perform pe))+                                                  else produce pr sink >> lift (perform pe)+         sequence pr pe = Producer $ \sink-> produce pr sink >> lift (perform pe)++instance forall m x r1 r2. (MonadParallel m) =>+   JoinableComponentPair (PerformerType r1) (ConsumerType r2) (ConsumerType r2) m [x] ()+                         (Performer m r1) (Consumer m x r2) (Consumer m x r2)+   where join parallel p c = Consumer $ \source-> if parallel+                                                  then bindM2 (const return) (lift (perform p)) (consume c source)+                                                  else lift (perform p) >> consume c source+         sequence p c = Consumer $ \source-> lift (perform p) >> consume c source++instance forall m x r1 r2. (MonadParallel m) =>+   JoinableComponentPair (ConsumerType r1) (PerformerType r2) (ConsumerType r2) m [x] ()+                         (Consumer m x r1) (Performer m r2) (Consumer m x r2)+   where join parallel c p = Consumer $ \source-> if parallel+                                                  then bindM2 (const return) (consume c source) (lift (perform p))+                                                  else consume c source >> lift (perform p)+         sequence c p = Consumer $ \source-> consume c source >> lift (perform p)++instance forall m x y r. (MonadParallel m) =>+   JoinableComponentPair (PerformerType r) TransducerType TransducerType m [x] [y]+                         (Performer m r) (Transducer m x y) (Transducer m x y)+   where join parallel p t = Transducer $ \ source sink -> if parallel+                                                           then bindM2 (const return)+                                                                   (lift (perform p)) (transduce t source sink)+                                                           else lift (perform p) >> transduce t source sink+         sequence p t = Transducer $ \ source sink -> lift (perform p) >> transduce t source sink++instance forall m x y r. (MonadParallel m)+   => JoinableComponentPair TransducerType (PerformerType r) TransducerType m [x] [y]+                            (Transducer m x y) (Performer m r) (Transducer m x y)+   where join parallel t p = Transducer $ \ source sink -> if parallel+                                                           then bindM2 (const . return)+                                                                   (transduce t source sink) (lift (perform p))+                                                           else do result <- transduce t source sink+                                                                   lift (perform p)+                                                                   return result+         sequence t p = Transducer $ \ source sink -> do result <- transduce t source sink+                                                         lift (perform p)+                                                         return result++instance forall m x y. (MonadParallel m) =>+   JoinableComponentPair (ProducerType ()) TransducerType TransducerType m [x] [y]+                         (Producer m y ()) (Transducer m x y) (Transducer m x y)+   where join parallel p t = if parallel+                             then isolateTransducer $ \source sink->+                                     do (rest, out) <- pipe+                                                          (\buffer-> bindM2 (const return)+                                                                        (produce p sink) (transduce t source buffer))+                                                          getList+                                        putList out sink+                                        return rest+                             else sequence p t+         sequence p t = Transducer $ \ source sink -> produce p sink >> transduce t source sink++instance forall m x y. (MonadParallel m) =>+   JoinableComponentPair TransducerType (ProducerType ()) TransducerType m [x] [y]+                         (Transducer m x y) (Producer m y ()) (Transducer m x y)+   where join parallel t p = if parallel+                             then isolateTransducer $ \source sink->+                                     do (rest, out) <- pipe+                                                          (\buffer-> bindM2 (const . return)+                                                                        (transduce t source sink)+                                                                        (produce p buffer))+                                                          getList+                                        putList out sink+                                        return rest +                             else sequence t p+         sequence t p = Transducer $ \ source sink -> do result <- transduce t source sink+                                                         produce p sink+                                                         return result++instance forall m x y. (MonadParallel m) =>+   JoinableComponentPair (ConsumerType ()) TransducerType TransducerType m [x] [y]+                         (Consumer m x ()) (Transducer m x y) (Transducer m x y)+   where join parallel c t = isolateTransducer $ \source sink->+                             teeConsumers parallel (consume c) (\source-> transduce t source sink) source+                             >> return ()+         sequence c t = isolateTransducer $ \source sink->+                        teeConsumers False (consume c) getList source+                        >>= \(_, list)-> pipe (putList list) (\source-> transduce t source sink)+                        >> return ()++instance forall m x y. MonadParallel m =>+   JoinableComponentPair TransducerType (ConsumerType ()) TransducerType m [x] [y]+                         (Transducer m x y) (Consumer m x ()) (Transducer m x y)+   where join parallel t c = join parallel c t+         sequence t c = isolateTransducer $ \source sink->+                        teeConsumers False (\source-> transduce t source sink) getList source+                        >>= \(_, list)-> pipe (putList list) (consume c)+                        >> return ()++instance forall m x y. (MonadParallel m) =>+   JoinableComponentPair (ProducerType ()) (ConsumerType ()) TransducerType m [x] [y]+                         (Producer m y ()) (Consumer m x ()) (Transducer m x y)+   where join parallel p c = Transducer $ \ source sink ->+                             if parallel+                             then bindM2 (\ _ _ -> return ()) (produce p sink) (consume c source)+                             else produce p sink >> consume c source+         sequence p c = Transducer $ \ source sink -> produce p sink >> consume c source++instance forall m x y. (MonadParallel m) =>+   JoinableComponentPair (ConsumerType ()) (ProducerType ()) TransducerType m [x] [y]+                         (Consumer m x ()) (Producer m y ()) (Transducer m x y)+   where join parallel c p = join parallel p c+         sequence c p = Transducer $ \ source sink -> consume c source >> produce p sink++-- | Combinator 'prepend' converts the given producer to a 'Control.Concurrent.SCC.Types.Transducer' that passes all its+-- input through unmodified, except for prepending the output of the argument producer to it. The following law holds: @+-- 'prepend' /prefix/ = 'join' ('substitute' /prefix/) 'Control.Category.id' @+prepend :: forall m x r. (Monad m) => Producer m x r -> Transducer m x x+prepend prefix = Transducer $ \ source sink -> produce prefix sink >> pour source sink++-- | Combinator 'append' converts the given producer to a 'Control.Concurrent.SCC.Types.Transducer' that passes all its+-- input through unmodified, finally appending the output of the argument producer to it. The following law holds: @+-- 'append' /suffix/ = 'join' 'Control.Category.id' ('substitute' /suffix/) @+append :: forall m x r. (Monad m) => Producer m x r -> Transducer m x x+append suffix = Transducer $ \ source sink -> pour source sink >> produce suffix sink >> return ()++-- | The 'substitute' combinator converts its argument producer to a 'Control.Concurrent.SCC.Types.Transducer' that+-- produces the same output, while consuming its entire input and ignoring it.+substitute :: forall m x y r. (Monad m) => Producer m y r -> Transducer m x y+substitute feed = Transducer $ \ source sink -> mapMStream_ (const $ return ()) source >> produce feed sink >> return ()++-- | The 'sNot' (streaming not) combinator simply reverses the outputs of the argument splitter. In other words, data+-- that the argument splitter sends to its /true/ sink goes to the /false/ sink of the result, and vice versa.+sNot :: forall m x b. Monad m => Splitter m x b -> Splitter m x b+sNot splitter = isolateSplitter $ \ source true false edge -> suppressProducer (split splitter source false true)++-- | The 'sAnd' combinator sends the /true/ sink output of its left operand to the input of its right operand for+-- further splitting. Both operands' /false/ sinks are connected to the /false/ sink of the combined splitter, but any+-- input value to reach the /true/ sink of the combined component data must be deemed true by both splitters.+sAnd :: forall m x b1 b2. MonadParallel m => Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)+sAnd parallel s1 s2 =+   isolateSplitter $ \ source true false edge ->+   liftM (fst . fst) $+   pipe+      (\edges-> pipePS parallel+                   (\true-> split s1 source true false (mapSink Left edges))+                   (\source-> split s2 source true false (mapSink Right edges)))+      (flip intersectRegions edge)++intersectRegions source sink = next Nothing Nothing+   where next lastLeft lastRight = getWith+                                      (either+                                          (flip pair lastRight . Just)+                                          (pair lastLeft . Just))+                                      source+         pair l@(Just x) r@(Just y) = put sink (x, y)+                                      >> next Nothing Nothing+         pair l r = next l r++-- | A 'sOr' combinator's input value can reach its /false/ sink only by going through both argument splitters' /false/+-- sinks.+sOr :: forall m x b1 b2. MonadParallel m =>+       Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x (Either b1 b2)+sOr parallel s1 s2 = isolateSplitter $ \ source true false edge ->+                     liftM fst $+                     pipePS parallel+                        (\false-> split s1 source true false (mapSink Left edge))+                        (\source-> split s2 source true false (mapSink Right edge))++-- | Combinator 'pAnd' is a pairwise logical conjunction of two splitters run in parallel on the same input.+pAnd :: forall m x b1 b2. MonadParallel m => Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)+pAnd parallel s1 s2 = isolateSplitter $ \ source true false edge ->+                         pipePS parallel+                             (transduce (splittersToPairMarker parallel s1 s2) source)+                             (\source-> let split l r = getWith (test l r) source+                                            test l r (Left (x, t1, t2))+                                               = (if t1 && t2 then put true x else put false x)+                                                 >> split+                                                       (if t1 then l else Nothing)+                                                       (if t2 then r else Nothing)+                                            test _ Nothing (Right (Left l)) = split (Just l) Nothing+                                            test _ (Just r) (Right (Left l))+                                               = put edge (l, r) >> split (Just l) (Just r)+                                            test Nothing _ (Right (Right r)) = split Nothing (Just r)+                                            test (Just l) _ (Right (Right r))+                                               = put edge (l, r) >> split (Just l) (Just r)+                                        in split Nothing Nothing)+                         >> return ()++-- | Combinator 'pOr' is a pairwise logical disjunction of two splitters run in parallel on the same input.+pOr :: forall c m x b1 b2. MonadParallel m =>+       Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x (Either b1 b2)+pOr = zipSplittersWith (||) pour++ifs :: forall c m x b. (MonadParallel m, Branching c m x ()) => Bool -> Splitter m x b -> c -> c -> c+ifs parallel s c1 c2 = combineBranches if' parallel c1 c2+   where if' :: forall d. Bool -> (forall a d'. AncestorFunctor d d' => OpenConsumer m a d' x ()) ->+                (forall a d'. AncestorFunctor d d' => OpenConsumer m a d' x ()) ->+                forall a. OpenConsumer m a d x ()+         if' parallel c1 c2 source = splitInputToConsumers parallel s source c1 c2++wherever :: forall m x b. MonadParallel m => Bool -> Transducer m x x -> Splitter m x b -> Transducer m x x+wherever parallel t s = isolateTransducer wherever'+   where wherever' :: forall d. Functor d => Source m d x -> Sink m d x -> Coroutine d m ()+         wherever' source sink = pipePS parallel+                                    (\true-> split s source true sink (nullSink :: Sink m d b))+                                    (flip (transduce t) sink)+                                 >> return ()++unless :: forall m x b. MonadParallel m => Bool -> Transducer m x x -> Splitter m x b -> Transducer m x x+unless parallel t s = wherever parallel t (sNot s)++select :: forall m x b. Monad m => Splitter m x b -> Transducer m x x+select s = isolateTransducer $ \source sink-> suppressProducer (suppressProducer . split s source sink)++-- | Converts a splitter into a parser.+parseRegions :: forall m x b. Monad m => Splitter m x b -> Parser m x b+parseRegions s = isolateTransducer $ \source sink->+                    pipe+                       (transduce (splitterToMarker s) source)+                       (\source-> wrapRegions source sink)+                    >> return ()+   where wrapRegions source sink = let wrap Nothing (Left (x, _)) = put sink (Content x)+                                                                    >> return Nothing+                                       wrap (Just p) (Left (x, False)) = flush p+                                                                         >> put sink (Content x)+                                                                         >> return Nothing+                                       wrap (Just (b, t)) (Left (x, True)) =+                                          do Monad.unless t (put sink (Markup (Start b)))+                                             put sink (Content x)+                                             return (Just (b, True))+                                       wrap (Just p) (Right b') = flush p >> return (Just (b', False))+                                       wrap Nothing (Right b) = return (Just (b, False))+                                       flush (b, t) = put sink $ Markup $ (if t then End else Point) b+                                   in foldMStream wrap Nothing source >>= maybe (return ()) flush++-- | Converts a boundary-marking splitter into a parser.+parseNestedRegions :: forall m x b. Monad m => Splitter m x (Boundary b) -> Parser m x b+parseNestedRegions s = isolateTransducer $ \source sink->+                       split s source (mapSink Content sink) (mapSink Content sink) (mapSink Markup sink)++-- | The recursive combinator 'while' feeds the true sink of the argument splitter back to itself, modified by the+-- argument transducer. Data fed to the splitter's false sink is passed on unmodified.+while :: forall m x b. MonadParallel m => [(Bool, (Transducer m x x, Splitter m x b))] -> Transducer m x x+while ((parallel, (t, s)) : rest) = isolateTransducer while'+   where while' :: forall d. Functor d => Source m d x -> Sink m d x -> Coroutine d m ()+         while' source sink =+            pipePS parallel+               (\true-> split s source true sink (nullSink :: Sink m d b))+               (\source-> getWith+                       (\x-> liftM fst $+                             pipe+                                (\sink-> put sink x >> pour source sink)+                                (\source-> transduce while'' source sink))+                       source)+            >> return ()+         while'' = compose parallel t (while rest)++-- | The recursive combinator 'nestedIn' combines two splitters into a mutually recursive loop acting as a single+-- splitter.  The true sink of one of the argument splitters and false sink of the other become the true and false sinks+-- of the loop.  The other two sinks are bound to the other splitter's source.  The use of 'nestedIn' makes sense only+-- on hierarchically structured streams. If we gave it some input containing a flat sequence of values, and assuming+-- both component splitters are deterministic and stateless, an input value would either not loop at all or it would+-- loop forever.+nestedIn :: forall m x b. MonadParallel m => [(Bool, (Splitter m x b, Splitter m x b))] -> Splitter m x b+nestedIn ((parallel, (s1, s2)) : rest) =+   isolateSplitter $ \ source true false edge ->+   liftM fst $+      pipePS parallel+         (\false-> split s1 source true false edge)+         (\source-> pipe+                       (\true-> split s2 source true false (filterMSink (const $ return False) edge))+                       (\source-> get source+                                  >>= maybe+                                         (return ((), ()))+                                         (\x-> pipe+                                                  (\sink-> put sink x >> pour source sink)+                                                  (\source-> split (nestedIn rest) source true false edge))))++-- | The 'foreach' combinator is similar to the combinator 'ifs' in that it combines a splitter and two transducers into+-- another transducer. However, in this case the transducers are re-instantiated for each consecutive portion of the+-- input as the splitter chunks it up. Each contiguous portion of the input that the splitter sends to one of its two+-- sinks gets transducered through the appropriate argument transducer as that transducer's whole input. As soon as the+-- contiguous portion is finished, the transducer gets terminated.+foreach :: forall m x b c. (MonadParallel m, Branching c m x ()) => Bool -> Splitter m x b -> c -> c -> c+foreach parallel s c1 c2 = combineBranches foreach' parallel c1 c2+   where foreach' :: forall d. Bool -> +                     (forall a d'. AncestorFunctor d d' => OpenConsumer m a d' x ()) ->+                     (forall a d'. AncestorFunctor d d' => OpenConsumer m a d' x ()) ->+                     forall a. OpenConsumer m a d x ()+         foreach' parallel c1 c2 source =+            liftM fst $+            pipePS parallel+               (transduce (splitterToMarker s) (liftSource source :: Source m d x))+               (\source-> groupMarks source (maybe c2 (const c1)))++-- | The 'having' combinator combines two pure splitters into a pure splitter. One splitter is used to chunk the input+-- into contiguous portions. Its /false/ sink is routed directly to the /false/ sink of the combined splitter. The+-- second splitter is instantiated and run on each portion of the input that goes to first splitter's /true/ sink. If+-- the second splitter sends any output at all to its /true/ sink, the whole input portion is passed on to the /true/+-- sink of the combined splitter, otherwise it goes to its /false/ sink.+having :: forall m x b1 b2. MonadParallel m => Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x b1+having parallel s1 s2 = isolateSplitter s+   where s source true false edge = pipePS parallel+                                       (transduce (splitterToMarker s1) source)+                                       (flip groupMarks test)+                                    >> return ()+            where test Nothing chunk = pour chunk false+                  test (Just mb) chunk = teeConsumers False getList (findsTrueIn s2) chunk+                                         >>= \(chunk, maybeFound)->+                                             if isJust maybeFound+                                             then maybe (return ()) (put edge) mb+                                                  >> putList chunk true+                                             else putList chunk false++-- | The 'havingOnly' combinator is analogous to the 'having' combinator, but it succeeds and passes each chunk of the+-- input to its /true/ sink only if the second splitter sends no part of it to its /false/ sink.+havingOnly :: forall m x b1 b2. MonadParallel m => Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x b1+havingOnly parallel s1 s2 = isolateSplitter s+   where s source true false edge = pipePS parallel+                                       (transduce (splitterToMarker s1) source)+                                       (flip groupMarks test)+                                    >> return ()+            where test Nothing chunk = pour chunk false+                  test (Just mb) chunk = teeConsumers False getList (findsFalseIn s2) chunk+                                         >>= \(chunk, anyFalse)->+                                             if anyFalse+                                             then putList chunk false+                                             else maybe (return ()) (put edge) mb+                                                  >> putList chunk true++-- | The result of combinator 'first' behaves the same as the argument splitter up to and including the first portion of+-- the input which goes into the argument's /true/ sink. All input following the first true portion goes into the+-- /false/ sink.+first :: forall m x b. Monad m => Splitter m x b -> Splitter m x b+first splitter = wrapMarkedSplitter splitter $+                 \source true false edge->+                 let split 1 (Left (x, False)) = put false x >> return 1+                     split 1 (Left (x, True)) = put true x >> return 2+                     split 1 (Right b) = put edge b >> return 2+                     split 2 b@Right{} = return 3+                     split 2 (Left (x, True)) = put true x >> return 2+                     split 2 (Left (x, False)) = put false x >> return 3+                     split 3 (Left (x, _)) = put false x >> return 3+                     split 3 (Right _) = return 3+                 in foldMStream_ split 1 source++-- | The result of combinator 'uptoFirst' takes all input up to and including the first portion of the input which goes+-- into the argument's /true/ sink and feeds it to the result splitter's /true/ sink. All the rest of the input goes+-- into the /false/ sink. The only difference between 'first' and 'uptoFirst' combinators is in where they direct the+-- /false/ portion of the input preceding the first /true/ part.+uptoFirst :: forall m x b. Monad m => Splitter m x b -> Splitter m x b+uptoFirst splitter = wrapMarkedSplitter splitter $+                     \source true false edge->+                     let split (Left q) (Left (x, False)) = return (Left (q |> x))+                         split (Left q) (Left (x, True)) = putQueue q true+                                                           >> put true x+                                                           >> return (Right True)+                         split (Left q) (Right b) = putQueue q true+                                                    >> put edge b+                                                    >> return (Right True)+                         split (Right True) Right{} = return (Right False)+                         split (Right True) (Left (x, True)) = put true x >> return (Right True)+                         split (Right True) (Left (x, False)) = put false x >> return (Right False)+                         split (Right False) (Left (x, _)) = put false x >> return (Right False)+                         split (Right False) (Right _) = return (Right False)+                     in foldMStream split (Left Seq.empty) source+                           >>= either (flip putQueue false) (const $ return ())++-- | The result of the combinator 'last' is a splitter which directs all input to its /false/ sink, up to the last+-- portion of the input which goes to its argument's /true/ sink. That portion of the input is the only one that goes to+-- the resulting component's /true/ sink.  The splitter returned by the combinator 'last' has to buffer the previous two+-- portions of its input, because it cannot know if a true portion of the input is the last one until it sees the end of+-- the input or another portion succeeding the previous one.+last :: forall m x b. Monad m => Splitter m x b -> Splitter m x b+last splitter = wrapMarkedSplitter splitter $+                \source true false edge->+                let get1 (Left (x, False)) = put false x+                                             >> getWith get1 source+                    get1 p@(Left (x, True)) = get2 Nothing Seq.empty p+                    get1 (Right b) = getWith (get2 (Just b) Seq.empty) source+                    get2 mb q (Left (x, True)) = let q' = q |> x+                                                 in get source+                                                    >>= maybe+                                                           (flush mb q')+                                                           (get2 mb q')+                    get2 mb q p = get3 mb q Seq.empty p+                    get3 mb qt qf (Left (x, False)) =+                       let qf' = qf |> x+                       in get source+                          >>= maybe+                                 (flush mb qt >> putQueue qf' false)+                                 (get3 mb qt qf')+                    get3 mb qt qf p = do putQueue qt false+                                         putQueue qf false+                                         get1 p+                    flush mb q = maybe (return ()) (put edge) mb+                                 >> putQueue q true+                in getWith get1 source++-- | The result of the combinator 'lastAndAfter' is a splitter which directs all input to its /false/ sink, up to the+-- last portion of the input which goes to its argument's /true/ sink. That portion and the remainder of the input is+-- fed to the resulting component's /true/ sink. The difference between 'last' and 'lastAndAfter' combinators is where+-- they feed the /false/ portion of the input, if any, remaining after the last /true/ part.+lastAndAfter :: forall m x b. Monad m => Splitter m x b -> Splitter m x b+lastAndAfter splitter = wrapMarkedSplitter splitter $+                        \source true false edge->+                        let get1 (Left (x, False)) = put false x+                                                     >> getWith get1 source+                            get1 p@(Left (x, True)) = get2 Nothing Seq.empty p+                            get1 (Right b) = getWith (get2 (Just b) Seq.empty) source+                            get2 mb q (Left (x, True)) = let q' = q |> x+                                                         in get source+                                                            >>= maybe+                                                                   (flush mb q')+                                                                   (get2 mb q')+                            get2 mb q p = get3 mb q p+                            get3 mb q (Left (x, False)) = let q' = q |> x+                                                          in get source+                                                             >>= maybe+                                                                    (flush mb q')+                                                                    (get3 mb q')+                            get3 _ q p@(Left (x, True)) = putQueue q false+                                                          >> get1 p+                            get3 _ q b'@Right{} = putQueue q false+                                                  >> get1 b'+                            flush mb q = maybe (return ()) (put edge) mb+                                         >> putQueue q true+                        in getWith get1 source++-- | The 'prefix' combinator feeds its /true/ sink only the prefix of the input that its argument feeds to its /true/+-- sink.  All the rest of the input is dumped into the /false/ sink of the result.+prefix :: forall m x b. Monad m => Splitter m x b -> Splitter m x b+prefix splitter = wrapMarkedSplitter splitter $+                  \source true false edge->+                  let split 0 p@Left{} = split 1 p+                      split 0 (Right b) = put edge b >> return 1+                      split 1 (Left (x, False)) = put false x >> return 2+                      split 1 (Left (x, True)) = put true x >> return 1+                      split 1 (Right b) = return 2+                      split 2 (Left (x, _)) = put false x >> return 2+                      split 2 Right{} = return 2+                  in foldMStream_ split 0 source++-- | The 'suffix' combinator feeds its /true/ sink only the suffix of the input that its argument feeds to its /true/+-- sink.  All the rest of the input is dumped into the /false/ sink of the result.+suffix :: forall m x b. Monad m => Splitter m x b -> Splitter m x b+suffix splitter = wrapMarkedSplitter splitter $+                  \source true false edge->+                  let split Nothing (Left (x, False)) = put false x >> return Nothing+                      split Nothing (Left (x, True)) = return (Just (Nothing, Seq.singleton x))+                      split Nothing (Right b) = return (Just (Just b, Seq.empty))+                      split (Just (mb, q)) (Left (x, True)) = return (Just (mb, q |> x))+                      split (Just (mb, q)) (Left (x, False)) = putQueue q false+                                                               >> put false x+                                                               >> return Nothing+                      split (Just (mb, q)) (Right b) = putQueue q false+                                                       >> return (Just (Just b, Seq.empty))+                  in foldMStream split Nothing source+                        >>= \r-> case r of Nothing -> return ()+                                           Just (Nothing, q) -> putQueue q true+                                           Just (Just b, q) -> put edge b >> putQueue q true++-- | The 'even' combinator takes every input section that its argument /splitter/ deems /true/, and feeds even ones into+-- its /true/ sink. The odd sections and parts of input that are /false/ according to its argument splitter are fed to+-- 'even' splitter's /false/ sink.+even :: forall m x b. Monad m => Splitter m x b -> Splitter m x b+even splitter = wrapMarkedSplitter splitter $+                \source true false edge->+                let split 1 (Left (x, False)) = put false x >> return 1+                    split 1 p@(Left (x, True)) = split 2 p+                    split 1 (Right b) = return 2+                    split 2 (Left (x, True)) = put false x >> return 2+                    split 2 p@(Left (x, False)) = split 3 p+                    split 2 (Right b) = put edge b >> return 4+                    split 3 (Left (x, False)) = put false x >> return 3+                    split 3 p@(Left (x, True)) = split 4 p+                    split 3 (Right b) = put edge b >> return 4+                    split 4 (Left (x, True)) = put true x >> return 4+                    split 4 p@(Left (x, False)) = split 1 p+                    split 4 (Right b) = return 2+                in foldMStream_ split 1 source++-- | Splitter 'startOf' issues an empty /true/ section at the beginning of every section considered /true/ by its+-- argument splitter, otherwise the entire input goes into its /false/ sink.+startOf :: forall m x b. Monad m => Splitter m x b -> Splitter m x (Maybe b)+startOf splitter = wrapMarkedSplitter splitter $+                   \source true false edge->+                   let split 1 (Left (x, False)) = put false x >> return 1+                       split 1 p@(Left (x, True)) = put edge Nothing >> split 2 p+                       split 1 (Right b) = put edge (Just b) >> return 2+                       split 2 (Left (x, True)) = put false x >> return 2+                       split 2 p = split 1 p+                   in foldMStream_ split 1 source++-- | Splitter 'endOf' issues an empty /true/ section at the end of every section considered /true/ by its argument+-- splitter, otherwise the entire input goes into its /false/ sink.+endOf :: forall m x b. Monad m => Splitter m x b -> Splitter m x (Maybe b)+endOf splitter = wrapMarkedSplitter splitter $+                 \source true false edge->+                 let split Nothing (Left (x, False)) = put false x >> return Nothing+                     split Nothing p@(Left (x, True)) = split (Just Nothing) p+                     split Nothing (Right b) = return (Just (Just b))+                     split (Just mb) (Left (x, True)) = put false x >> return (Just mb)+                     split (Just mb) p@(Left (x, False)) = put edge mb >> split Nothing p+                     split (Just mb) (Right b) = put edge mb >> return (Just $ Just b)+                 in foldMStream split Nothing source >>= maybe (return ()) (put edge)++-- | Combinator 'followedBy' treats its argument 'Splitter's as patterns components and returns a 'Splitter' that+-- matches their concatenation. A section of input is considered /true/ by the result iff its prefix is considered+-- /true/ by argument /s1/ and the rest of the section is considered /true/ by /s2/. The splitter /s2/ is started anew+-- after every section split to /true/ sink by /s1/.+followedBy :: forall m x b1 b2. MonadParallel m =>+              Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)+followedBy parallel s1 s2 = +   isolateSplitter $ \ source true false edge ->+   pipePS parallel+      (transduce (splitterToMarker s1) source)+      (\source-> let get0 q = case Seq.viewl q+                              of Seq.EmptyL -> getWith get1 source+                                 (Left (x, False)) :< rest -> put false x+                                                              >> get0 rest+                                 (Left (x, True)) :< rest -> get2 Nothing Seq.empty q+                                 (Right b) :< rest -> get2 (Just b) Seq.empty rest+                     get1 (Left (x, False)) = put false x+                                              >> getWith get1 source+                     get1 p@(Left (x, True)) = get2 Nothing Seq.empty (Seq.singleton p)+                     get1 (Right b) = get2 (Just b) Seq.empty Seq.empty+                     get2 mb q q' = case Seq.viewl q'+                                    of Seq.EmptyL -> get source+                                                     >>= maybe (testEnd mb q) (get2 mb q . Seq.singleton)+                                       (Left (x, True)) :< rest -> get2 mb (q |> x) rest+                                       (Left (x, False)) :< rest -> get3 mb q q'+                                       Right{} :< rest -> get3 mb q q'+                     get3 mb q q' = do ((q1, q2), n) <- pipe (get7 Seq.empty q') (test mb q)+                                       case n of Nothing -> putQueue q false+                                                            >> get0 (q1 >< q2)+                                                 Just 0 -> get0 (q1 >< q2)+                                                 Just n -> get8 (Just mb) n (q1 >< q2)+                     get7 q1 q2 sink = case Seq.viewl q2+                                       of Seq.EmptyL -> get source+                                                        >>= maybe (return (q1, q2))+                                                               (\p-> either+                                                                        (put sink . fst)+                                                                        (const $ return ())+                                                                        p+                                                                     >> get7 (q1 |> p) q2 sink)+                                          p :< rest -> either+                                                          (put sink . fst)+                                                          (const $ return ()) p+                                                       >> get7 (q1 |> p) rest sink+                     testEnd mb q = do ((), n) <- pipe (const $ return ()) (test mb q)+                                       case n of Nothing -> putQueue q false+                                                 _ -> return ()+                     test mb q source = liftM snd $+                                        pipe+                                           (transduce (splitterToMarker s2) source)+                                           (\source-> let get4 (Left (_, False)) = return Nothing+                                                          get4 p@(Left (_, True)) = putQueue q true+                                                                                    >> get5 0 p+                                                          get4 p@(Right b) = maybe+                                                                                (return ())+                                                                                (\b1-> put edge (b1, b))+                                                                                mb+                                                                             >> putQueue q true+                                                                             >> get6 0+                                                          get5 n (Left (x, True)) = put true x+                                                                                    >> get6 (succ n)+                                                          get5 n _ = return (Just n)+                                                          get6 n = get source+                                                                   >>= maybe+                                                                          (return $ Just n)+                                                                          (get5 n)+                                                      in get source >>= maybe (return Nothing) get4)+                     get8 Nothing 0 q = get0 q+                     get8 (Just mb) 0 q = get2 mb Seq.empty q+                     get8 mmb n q = case Seq.viewl q of Left (x, False) :< rest -> get8 Nothing (pred n) rest+                                                        Left (x, True) :< rest+                                                           -> get8 (maybe (Just Nothing) Just mmb) (pred n) rest+                                                        Right b :< rest -> get8 (Just (Just b)) n rest+                in get0 Seq.empty)+   >> return ()++-- | Combinator '...' tracks the running balance of difference between the number of preceding starts of sections+-- considered /true/ according to its first argument and the ones according to its second argument. The combinator+-- passes to /true/ all input values for which the difference balance is positive. This combinator is typically used+-- with 'startOf' and 'endOf' in order to count entire input sections and ignore their lengths.+between :: forall m x b1 b2. MonadParallel m => Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x b1+between parallel s1 s2 = isolateSplitter $ \ source true false edge ->+                         pipePS parallel+                            (transduce (splittersToPairMarker parallel s1 s2) source)+                            (let pass n x = (if n > 0 then put true x else put false x)+                                            >> return n+                                 pass' n x = (if n >= 0 then put true x else put false x)+                                             >> return n+                                 state n (Left (x, True, False)) = pass (succ n) x+                                 state n (Left (x, False, True)) = pass' (pred n) x+                                 state n (Left (x, True, True)) = pass' n x+                                 state n (Left (x, False, False)) = pass n x+                                 state 0 (Right (Left b)) = put edge b >> return 1+                                 state n (Right (Left _)) = return (succ n)+                                 state n (Right (Right _)) = return (pred n)+                             in foldMStream_ state 0)+                         >> return ()++-- Helper functions++wrapMarkedSplitter ::+   forall m x b1 b2. Monad m =>+   Splitter m x b1+   -> (forall a1 a2 a3 a4 d. (AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d, AncestorFunctor a4 d) =>+       Source m a1 (Either (x, Bool) b1) -> Sink m a2 x -> Sink m a3 x -> Sink m a4 b2 -> Coroutine d m ())+   -> Splitter m x b2+wrapMarkedSplitter splitter splitMarked = isolateSplitter $ \ source true false edge ->+                                          pipe+                                             (transduce (splitterToMarker splitter) source)+                                             (\source-> splitMarked source true false edge)+                                          >> return ()++splitterToMarker :: forall m x b. Monad m => Splitter m x b -> Transducer m x (Either (x, Bool) b)+splitterToMarker s = isolateTransducer $ \source sink->+                     split s source+                        (mapSink (\x-> Left (x, True)) sink)+                        (mapSink (\x-> Left (x, False)) sink)+                        (mapSink Right sink)++splittersToPairMarker :: forall m x b1 b2. (MonadParallel m) => Bool -> Splitter m x b1 -> Splitter m x b2 ->+                         Transducer m x (Either (x, Bool, Bool) (Either b1 b2))+splittersToPairMarker parallel s1 s2 =+   let t source sink = +          pipe+             (\sync-> teeConsumers parallel+                         (\source1-> split s1 source1+                                        (mapSink (\x-> Left ((x, True), True)) sync)+                                        (mapSink (\x-> Left ((x, False), True)) sync)+                                        (mapSink (Right. Left) sync))+                         (\source2-> split s2 source2+                                        (mapSink (\x-> Left ((x, True), False)) sync)+                                        (mapSink (\x-> Left ((x, False), False)) sync)+                                        (mapSink (Right . Right) sync))+                         source)+              (synchronizeMarks sink)+          >> return ()+       synchronizeMarks :: forall m a1 a2 d. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d) =>+                           Sink m a1 (Either (x, Bool, Bool) (Either b1 b2))+                        -> Source m a2 (Either ((x, Bool), Bool) (Either b1 b2))+                        -> Coroutine d m ()+       synchronizeMarks sink source = foldMStream handleMark Nothing source >>= \Nothing-> return () where+          handleMark Nothing (Right b) = put sink (Right b) >> return Nothing+          handleMark Nothing (Left (p, first)) = return (Just (Seq.singleton (Left p), first))+          handleMark state@(Just (q, first)) (Left (p, first')) | first == first' = return (Just (q |> Left p, first))+          handleMark state@(Just (q, True)) (Right b@Left{}) = return (Just (q |> Right b, True))+          handleMark state@(Just (q, False)) (Right b@Right{}) = return (Just (q |> Right b, False))+          handleMark state (Right b) = put sink (Right b) >> return state+          handleMark state@(Just (q, pos')) mark@(Left ((x, t), pos))+             = case Seq.viewl q+               of Seq.EmptyL -> return (Just (Seq.singleton (Left (x, t)), pos))+                  Right b :< rest -> put sink (Right b)+                                     >> handleMark (if Seq.null rest then Nothing else Just (rest, pos')) mark+                  Left (y, t') :< rest -> put sink (Left $ if pos then (y, t, t') else (y, t', t))+                                          >> return (if Seq.null rest then Nothing else Just (rest, pos'))+       returnQueuedList q = return $ concatMap (either ((:[]) . fst) (const [])) $ Foldable.toList $ Seq.viewl q+   in isolateTransducer t++zipSplittersWith :: forall m x b1 b2 b. MonadParallel m => +                    (Bool -> Bool -> Bool) -> +                    (forall a1 a2 d. (AncestorFunctor a1 d, AncestorFunctor a2 d) =>+                     Source m a1 (Either b1 b2) -> Sink m a2 b -> Coroutine d m ()) -> +                    Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x b+zipSplittersWith f boundaries parallel s1 s2+   = isolateSplitter $ \ source true false edge ->+     pipe+        (\edge->+         pipePS parallel+            (transduce (splittersToPairMarker parallel s1 s2) source)+            (mapMStream_+                (either+                    (\(x, t1, t2)-> if f t1 t2 then put true x else put false x)+                    (put edge))))+        (flip boundaries edge)+     >> return ()++-- | Runs the second argument on every contiguous region of input source (typically produced by 'splitterToMarker')+-- whose all values either match @Left (_, True)@ or @Left (_, False)@.+groupMarks :: (Monad m, AncestorFunctor a d, AncestorFunctor a (SinkFunctor d x)) =>+              Source m a (Either (x, Bool) b) ->+              (Maybe (Maybe b) -> Source m (SourceFunctor d x) x -> Coroutine (SourceFunctor d x) m r) ->+              Coroutine d m ()+groupMarks source getConsumer = start+   where start = getWith (either startContent startRegion) source+         startContent (x, False) = pipe (\sink-> pass False sink x) (getConsumer Nothing)+                                   >>= maybe (return ()) (either startContent startRegion) . fst+         startContent (x, True) = pipe (\sink-> pass True sink x) (getConsumer $ Just Nothing)+                                  >>= maybe (return ()) (either startContent startRegion) . fst+         startRegion b = pipe (next True) (getConsumer (Just $ Just b))+                         >>= maybe (return ()) (either startContent startRegion) . fst+         pass t sink x = put sink x >> next t sink+         next t sink = get source >>= maybe (return Nothing) (continue t sink)+         continue t sink (Left (x, t')) | t == t' = pass t sink x+         continue t sink p = return (Just p)++-- | 'suppressProducer' runs the /producer/ argument with a new sink, suppressing everything 'put' in the sink.+suppressProducer :: forall m a x r. (Functor a, Monad m) => (Sink m a x -> Coroutine a m r) -> Coroutine a m r+suppressProducer producer = producer (nullSink :: Sink m a x)++findsTrueIn :: forall m a d x b. (Monad m, AncestorFunctor a d)+               => Splitter m x b -> Source m a x -> Coroutine d m (Maybe (Maybe b))+findsTrueIn splitter source = pipe+                                 (\testTrue-> pipe+                                                 (split splitter (liftSource source :: Source m d x)+                                                     testTrue+                                                     (nullSink :: Sink m d x))+                                                 get)+                                 get+                              >>= \(((), maybeEdge), maybeTrue)-> return $+                                                                  case maybeEdge+                                                                  of Nothing -> fmap (const Nothing) maybeTrue+                                                                     _ -> Just maybeEdge++findsFalseIn :: forall m a d x b. (Monad m, AncestorFunctor a d) => Splitter m x b -> Source m a x -> Coroutine d m Bool+findsFalseIn splitter source = pipe+                                  (\testFalse-> split splitter (liftSource source :: Source m d x)+                                                   (nullSink :: Sink m d x)+                                                   testFalse+                                                   (nullSink :: Sink m d b))+                                  get+                               >>= \((), maybeFalse)-> return (isJust maybeFalse)++teeConsumers :: forall m a d x r1 r2. MonadParallel m+                => Bool -> (forall a. OpenConsumer m a (SinkFunctor d x) x r1)+                        -> (forall a. OpenConsumer m a (SourceFunctor d x) x r2)+             -> OpenConsumer m a d x (r1, r2)+teeConsumers parallel c1 c2 source = pipePS parallel consume1 c2+   where consume1 sink = c1 (teeSource sink source' :: Source m (SinkFunctor d x) x)+         source' :: Source m d x+         source' = liftSource source

@@ -1,5 +1,5 @@ {- -    Copyright 2008-2009 Mario Blazevic+    Copyright 2008-2010 Mario Blazevic      This file is part of the Streaming Component Combinators (SCC) project. @@ -22,8 +22,11 @@  module Control.Concurrent.SCC.Components where -import Control.Concurrent.Coroutine+import Control.Monad.Coroutine+import Control.Monad.Parallel (MonadParallel(..))+ import Control.Concurrent.SCC.Types+import Control.Concurrent.SCC.Types as Types import qualified Control.Concurrent.SCC.Combinators as Combinator import qualified Control.Concurrent.SCC.Primitives as Primitive import qualified Control.Concurrent.SCC.XML as XML@@ -31,7 +34,8 @@ import Control.Concurrent.SCC.XML (Token) import Control.Concurrent.Configuration -import Prelude hiding (appendFile, even, last, sequence, (||), (&&))+import Prelude hiding (appendFile, even, id, last, sequence, (||), (&&))+import qualified Control.Category import Control.Monad (liftM)  import System.IO (Handle)@@ -65,7 +69,7 @@ toList = atomic "toList" 1 Primitive.toList  -- | 'fromList' produces the contents of the given list argument.-fromList :: forall m x. Monad m => [x] -> ProducerComponent m x [x]+fromList :: forall m x. Monad m => [x] -> ProducerComponent m x () fromList l = atomic "fromList" 1 (Primitive.fromList l)  -- | ConsumerComponent 'toStdOut' copies the given source into the standard output.@@ -98,9 +102,9 @@ toHandle :: Handle -> Bool -> ConsumerComponent IO Char () toHandle handle doClose = atomic "toHandle" ioCost (Primitive.toHandle handle doClose) --- | TransducerComponent 'asis' passes its input through unmodified.-asis :: forall m x. Monad m => TransducerComponent m x x-asis = atomic "asis" 1 Primitive.asis+-- | TransducerComponent 'id' passes its input through unmodified.+id :: forall m x. Monad m => TransducerComponent m x x+id = atomic "id" 1 Control.Category.id  -- | TransducerComponent 'unparse' removes all markup from its input and passes the content through. unparse :: forall m x y. Monad m => TransducerComponent m (Markup y x) x@@ -226,7 +230,7 @@ --    * The result output, if any, is the output of the second component.  (>->) :: Combinator.PipeableComponentPair m w c1 c2 c3 => Component c1 -> Component c2 -> Component c3-(>->) = liftParallelPair ">->" Combinator.connect+(>->) = liftParallelPair ">->" Combinator.compose  class CompatibleSignature c cons (m :: * -> *) input output | c -> cons m @@ -287,35 +291,35 @@ -- | The '>&' combinator sends the /true/ sink output of its left operand to the input of its right operand for further -- splitting. Both operands' /false/ sinks are connected to the /false/ sink of the combined splitter, but any input -- value to reach the /true/ sink of the combined component data must be deemed true by both splitters.-(>&) :: forall m x b1 b2. ParallelizableMonad m =>+(>&) :: forall m x b1 b2. MonadParallel m =>         SplitterComponent m x b1 -> SplitterComponent m x b2 -> SplitterComponent m x (b1, b2) (>&) = liftParallelPair ">&" Combinator.sAnd  -- | A '>|' combinator's input value can reach its /false/ sink only by going through both argument splitters' /false/ -- sinks.-(>|) :: forall m x b1 b2. ParallelizableMonad m =>+(>|) :: forall m x b1 b2. MonadParallel m =>         SplitterComponent m x b1 -> SplitterComponent m x b2 -> SplitterComponent m x (Either b1 b2) (>|) = liftParallelPair ">&" Combinator.sOr  -- | Combinator '&&' is a pairwise logical conjunction of two splitters run in parallel on the same input.-(&&) :: forall m x b1 b2. ParallelizableMonad m =>+(&&) :: forall m x b1 b2. MonadParallel m =>         SplitterComponent m x b1 -> SplitterComponent m x b2 -> SplitterComponent m x (b1, b2) (&&) = liftParallelPair "&&" Combinator.pAnd  -- | Combinator '||' is a pairwise logical disjunction of two splitters run in parallel on the same input.-(||) :: (ParallelizableMonad m)+(||) :: (MonadParallel m)         => SplitterComponent m x b1 -> SplitterComponent m x b2 -> SplitterComponent m x (Either b1 b2) (||) = liftParallelPair "||" Combinator.pOr -ifs :: forall c m x b. (ParallelizableMonad m, Branching c m x [x]) =>+ifs :: forall c m x b. (MonadParallel m, Branching c m x ()) =>        SplitterComponent m x b -> Component c -> Component c -> Component c ifs = parallelRouterAndBranches "ifs" Combinator.ifs -wherever :: forall m x b. ParallelizableMonad m =>+wherever :: forall m x b. MonadParallel m =>             TransducerComponent m x x -> SplitterComponent m x b -> TransducerComponent m x x wherever = liftParallelPair "wherever" Combinator.wherever -unless :: forall m x b. ParallelizableMonad m =>+unless :: forall m x b. MonadParallel m =>           TransducerComponent m x x -> SplitterComponent m x b -> TransducerComponent m x x unless = liftParallelPair "unless" Combinator.unless @@ -327,13 +331,13 @@ parseRegions = lift 1 "parseRegions" Combinator.parseRegions  -- | Converts a boundary-marking splitter into a parser.-parseNestedRegions :: forall m x b. ParallelizableMonad m =>+parseNestedRegions :: forall m x b. MonadParallel m =>                       SplitterComponent m x (Boundary b) -> ParserComponent m x b parseNestedRegions = lift 1 "parseNestedRegions" Combinator.parseNestedRegions  -- | The recursive combinator 'while' feeds the true sink of the argument splitter back to itself, modified by the -- argument transducer. Data fed to the splitter's false sink is passed on unmodified.-while :: forall m x b. ParallelizableMonad m =>+while :: forall m x b. MonadParallel m =>          TransducerComponent m x x -> SplitterComponent m x b -> TransducerComponent m x x while t s = recursiveComponentTree "while" Combinator.while $ liftSequentialPair "pair" (,) t s @@ -343,7 +347,7 @@ -- on hierarchically structured streams. If we gave it some input containing a flat sequence of values, and assuming -- both component splitters are deterministic and stateless, an input value would either not loop at all or it would -- loop forever.-nestedIn :: forall m x b. ParallelizableMonad m =>+nestedIn :: forall m x b. MonadParallel m =>             SplitterComponent m x b -> SplitterComponent m x b -> SplitterComponent m x b nestedIn s1 s2 = recursiveComponentTree "nestedIn" Combinator.nestedIn $ liftSequentialPair "pair" (,) s1 s2 @@ -352,7 +356,7 @@ -- input as the splitter chunks it up. Each contiguous portion of the input that the splitter sends to one of its two -- sinks gets transducered through the appropriate argument transducer as that transducer's whole input. As soon as the -- contiguous portion is finished, the transducer gets terminated.-foreach :: forall m x b c. (ParallelizableMonad m, Branching c m x [x]) =>+foreach :: forall m x b c. (MonadParallel m, Branching c m x ()) =>            SplitterComponent m x b -> Component c -> Component c -> Component c foreach = parallelRouterAndBranches "foreach" Combinator.foreach @@ -361,13 +365,13 @@ -- second splitter is instantiated and run on each portion of the input that goes to first splitter's /true/ sink. If -- the second splitter sends any output at all to its /true/ sink, the whole input portion is passed on to the /true/ -- sink of the combined splitter, otherwise it goes to its /false/ sink.-having :: forall m x b1 b2. ParallelizableMonad m =>+having :: forall m x b1 b2. MonadParallel m =>           SplitterComponent m x b1 -> SplitterComponent m x b2 -> SplitterComponent m x b1 having = liftParallelPair "having" Combinator.having  -- | The 'havingOnly' combinator is analogous to the 'having' combinator, but it succeeds and passes each chunk of the -- input to its /true/ sink only if the second splitter sends no part of it to its /false/ sink.-havingOnly :: forall m x b1 b2. ParallelizableMonad m =>+havingOnly :: forall m x b1 b2. MonadParallel m =>               SplitterComponent m x b1 -> SplitterComponent m x b2 -> SplitterComponent m x b1 havingOnly = liftParallelPair "havingOnly" Combinator.havingOnly @@ -422,14 +426,14 @@  -- | SplitterComponent 'endOf' issues an empty /true/ section at the end of every section considered /true/ by its -- argument splitter, otherwise the entire input goes into its /false/ sink.-endOf :: forall m x b. ParallelizableMonad m => SplitterComponent m x b -> SplitterComponent m x (Maybe b)+endOf :: forall m x b. MonadParallel m => SplitterComponent m x b -> SplitterComponent m x (Maybe b) endOf = lift 2 "endOf" Combinator.endOf  -- | Combinator 'followedBy' treats its argument 'SplitterComponent's as patterns components and returns a 'SplitterComponent' that -- matches their concatenation. A section of input is considered /true/ by the result iff its prefix is considered -- /true/ by argument /s1/ and the rest of the section is considered /true/ by /s2/. The splitter /s2/ is started anew -- after every section split to /true/ sink by /s1/.-followedBy :: forall m x b1 b2. ParallelizableMonad m =>+followedBy :: forall m x b1 b2. MonadParallel m =>               SplitterComponent m x b1 -> SplitterComponent m x b2 -> SplitterComponent m x (b1, b2) followedBy = liftParallelPair "followedBy" Combinator.followedBy @@ -437,7 +441,7 @@ -- considered /true/ according to its first argument and the ones according to its second argument. The combinator -- passes to /true/ all input values for which the difference balance is positive. This combinator is typically used -- with 'startOf' and 'endOf' in order to count entire input sections and ignore their lengths.-(...) :: forall m x b1 b2. ParallelizableMonad m =>+(...) :: forall m x b1 b2. MonadParallel m =>          SplitterComponent m x b1 -> SplitterComponent m x b2 -> SplitterComponent m x b1 (...) = liftParallelPair "..." Combinator.between @@ -455,7 +459,7 @@  -- | Similiar to @('Control.Concurrent.SCC.Combinators.having' 'element')@, except it runs the argument splitter -- only on each element's start tag, not on the entire element with its content.-xmlElementHavingTag :: forall m b. ParallelizableMonad m =>+xmlElementHavingTag :: forall m b. MonadParallel m =>                        SplitterComponent m (Markup Token Char) b -> SplitterComponent m (Markup Token Char) b xmlElementHavingTag = lift 2 "XML.elementHavingTag" XML.elementHavingTag @@ -476,12 +480,12 @@ xmlAttributeValue :: Monad m => SplitterComponent m (Markup Token Char) () xmlAttributeValue = atomic "XML.attributeValue" 1 XML.attributeValue -xmlHavingText :: forall m b1 b2. ParallelizableMonad m =>+xmlHavingText :: forall m b1 b2. MonadParallel m =>               SplitterComponent m (Markup Token Char) b1 -> SplitterComponent m Char b2 ->               SplitterComponent m (Markup Token Char) b1 xmlHavingText = liftParallelPair "XML.havingText" XML.havingText -xmlHavingOnlyText :: forall m b1 b2. ParallelizableMonad m =>+xmlHavingOnlyText :: forall m b1 b2. MonadParallel m =>                      SplitterComponent m (Markup Token Char) b1 -> SplitterComponent m Char b2 ->                      SplitterComponent m (Markup Token Char) b1 xmlHavingOnlyText = liftParallelPair "XML.havingOnlyText" XML.havingOnlyText

@@ -1,5 +1,5 @@ {- -    Copyright 2008-2009 Mario Blazevic+    Copyright 2008-2010 Mario Blazevic      This file is part of the Streaming Component Combinators (SCC) project. @@ -31,13 +31,13 @@     -- * Generic consumers     suppress, erroneous,     -- * Generic transducers-    asis, parse, unparse, parseSubstring,+    parse, unparse, parseSubstring,     -- * Generic splitters     everything, nothing, marked, markedContent, markedWith, contentMarkedWith, one, substring,     -- * List transducers     -- | The following laws hold:     ---    --    * 'group' '>->' 'concatenate' == 'asis'+    --    * 'group' '>>>' 'concatenate' == 'id'     --     --    * 'concatenate' == 'concatSeparate' []     group, concatenate, concatSeparate,@@ -50,7 +50,7 @@  import Prelude hiding (appendFile) -import Control.Concurrent.Coroutine+import Control.Monad.Coroutine import Control.Concurrent.SCC.Streams import Control.Concurrent.SCC.Types @@ -74,25 +74,16 @@ toList = Consumer getList  -- | 'fromList' produces the contents of the given list argument.-fromList :: forall m x. Monad m => [x] -> Producer m x [x]+fromList :: forall m x. Monad m => [x] -> Producer m x () fromList l = Producer (putList l)  -- | Consumer 'toStdOut' copies the given source into the standard output. toStdOut :: Consumer IO Char ()-toStdOut = Consumer $-           \source-> let c = get source-                             >>= maybe (return ()) (\x-> lift (putChar x) >> c)-                     in c+toStdOut = Consumer (mapMStream_ (\x-> lift (putChar x)))  -- | Producer 'fromStdIn' feeds the given sink from the standard input. fromStdIn :: Producer IO Char ()-fromStdIn = Producer $-            \sink-> let p = do readyInput <- liftM not (lift isEOF)-                               readyOutput <- canPut sink-                               when (readyInput && readyOutput) (lift getChar-                                                                 >>= put sink-                                                                 >> p)-                    in p+fromStdIn = Producer (unmapMStream_ (lift isEOF >>= cond (return Nothing) (lift (liftM Just getChar))))  -- | Producer 'fromFile' opens the named file and feeds the given sink from its contents. fromFile :: String -> Producer IO Char ()@@ -102,14 +93,10 @@ -- | Producer 'fromHandle' feeds the given sink from the open file /handle/. The argument /doClose/ determines -- | if /handle/ should be closed when the handle is consumed or the sink closed. fromHandle :: Handle -> Bool -> Producer IO Char ()-fromHandle handle doClose = Producer $-                            \sink-> (canPut sink-                                     >>= flip when (let p = do eof <- lift (hIsEOF handle)-                                                               when (not eof) (lift (hGetChar handle)-                                                                               >>= put sink-                                                                               >>= flip when p)-                                                    in p)-                                     >> when doClose (lift $ hClose handle))+fromHandle handle doClose = Producer (\sink-> unmapMStream_ (lift hGetCharMaybe) sink+                                              >> when doClose (lift $ hClose handle))+   where hGetCharMaybe = hIsEOF handle >>= cond (return Nothing) (liftM Just $ hGetChar handle)+              -- | Consumer 'toFile' opens the named file and copies the given source into it. toFile :: String -> Consumer IO Char ()@@ -124,16 +111,8 @@ -- | Consumer 'toHandle' copies the given source into the open file /handle/. The argument /doClose/ determines -- | if /handle/ should be closed once the entire source is consumed and copied. toHandle :: Handle -> Bool -> Consumer IO Char ()-toHandle handle doClose = Consumer $-                          \source-> let c = get source-                                            >>= maybe-                                                   (when doClose $ lift $ hClose handle)-                                                   (\x-> lift (hPutChar handle x) >> c)-                                    in c---- | Transducer 'asis' passes its input through unmodified.-asis :: forall m x. Monad m => Transducer m x x-asis = oneToOneTransducer id+toHandle handle doClose = Consumer (\source-> mapMStream_ (lift . hPutChar handle) source+                                              >> when doClose (lift $ hClose handle))  -- | Transducer 'unparse' removes all markup from its input and passes the content through. unparse :: forall m x y. Monad m => Transducer m (Markup y x) x@@ -147,12 +126,11 @@  -- | The 'suppress' consumer suppresses all input it receives. It is equivalent to 'substitute' [] suppress :: forall m x y. Monad m => Consumer m x ()-suppress = Consumer consumeAndSuppress+suppress = Consumer (mapMStream_ (const $ return ()))  -- | The 'erroneous' consumer reports an error if any input reaches it. erroneous :: forall m x. Monad m => String -> Consumer m x ()-erroneous message = Consumer $-                    \source-> get source >>= maybe (return ()) (const (error message))+erroneous message = Consumer (getWith (const (error message)))  -- | The 'lowercase' transforms all uppercase letters in the input to lowercase, leaving the rest unchanged. lowercase :: forall m. Monad m => Transducer m Char Char@@ -164,7 +142,7 @@  -- | The 'count' transducer counts all its input values and outputs the final tally. count :: forall m x. Monad m => Transducer m x Integer-count = foldingTransducer (\count _-> succ count) 0 id+count = Transducer (\source sink-> foldStream (\count _-> succ count) 0 source >>= put sink)  -- | Converts each input value @x@ to @show x@. toString :: forall m x. (Monad m, Show x) => Transducer m x String@@ -172,7 +150,7 @@  -- | Transducer 'group' collects all its input values into a single list. group :: forall m x. Monad m => Transducer m x [x]-group = foldingTransducer (|>) Seq.empty Foldable.toList+group = Transducer (\source sink-> foldStream (|>) Seq.empty source >>= put sink . Foldable.toList)  -- | Transducer 'concatenate' flattens the input stream of lists of values into the output stream of values. concatenate :: forall m x. Monad m => Transducer m [x] x@@ -181,7 +159,7 @@ -- | Same as 'concatenate' except it inserts the given separator list between every two input lists. concatSeparate :: forall m x. Monad m => [x] -> Transducer m [x] x concatSeparate separator = statefulTransducer (\seen list-> (True, if seen then separator ++ list else list))-                                                  False +                                              False  -- | Splitter 'whitespace' feeds all white-space characters into its /true/ sink, all others into /false/. whitespace :: forall m. Monad m => Splitter m Char ()@@ -204,59 +182,29 @@ -- line-end can be formed by any of the character sequences \"\\n\", \"\\r\", \"\\r\\n\", or \"\\n\\r\". line :: forall m. Monad m => Splitter m Char () line = Splitter $-       \source true false boundaries-> let split0 = get source >>= maybe (return []) split1-                                           split1 x = if x == '\n' || x == '\r'-                                                      then split2 x-                                                      else lineChar x-                                           split2 x = put false x-                                                      >>= cond-                                                             (get source-                                                              >>= maybe-                                                                     (return [])-                                                                     (\y-> if x == y-                                                                           then emptyLine x-                                                                           else if y == '\n' || y == '\r'-                                                                                then split3 x-                                                                                else lineChar y))-                                                             (return [x])-                                           split3 x = put false x-                                                      >>= cond-                                                             (get source-                                                              >>= maybe-                                                                     (return [])-                                                                     (\y-> if y == '\n' || y == '\r'-                                                                           then emptyLine y-                                                                           else lineChar y))-                                                             (return [x])-                                           emptyLine x = put boundaries () >>= cond (split2 x) (return [])-                                           lineChar x = put true x >>= cond split0 (return [x])-                                       in split0+       \source true false boundaries-> let split Nothing x = put boundaries () >> handle x+                                           split (Just '\n') x@'\r' = put false x >> return Nothing+                                           split (Just '\r') x@'\n' = put false x >> return Nothing+                                           split (Just '\n') x = split Nothing x+                                           split (Just '\r') x = split Nothing x+                                           split (Just _) x = handle x+                                           handle x = (if x == '\n' || x == '\r'+                                                       then put false x+                                                       else put true x)+                                                      >> return (Just x)+                                       in foldMStream_ split Nothing source  -- | Splitter 'everything' feeds its entire input into its /true/ sink. everything :: forall m x. Monad m => Splitter m x ()-everything = Splitter $-             \source true false edge-> do put edge ()-                                          pour source true-                                          return []+everything = Splitter (\source true false edge-> put edge () >> pour source true)  -- | Splitter 'nothing' feeds its entire input into its /false/ sink. nothing :: forall m x. Monad m => Splitter m x ()-nothing = Splitter $-          \source true false edge-> do pour source false-                                       return []+nothing = Splitter (\source true false edge-> pour source false)  -- | Splitter 'one' feeds all input values to its /true/ sink, treating every value as a separate section. one :: forall m x. Monad m => Splitter m x ()-one = Splitter $-      \source true false edge-> let s = get source-                                        >>= maybe-                                               (return [])-                                               (\x-> put edge ()-                                                     >>= cond-                                                            (put true x-                                                             >>= cond s (return [x]))-                                                            (return [x]))-                                in s+one = Splitter (\source true false edge-> mapMStream_ (\x-> put edge () >> put true x) source)  -- | Splitter 'marked' passes all marked-up input sections to its /true/ sink, and all unmarked input to its -- /false/ sink.@@ -305,12 +253,9 @@ -- | Performs the same task as the 'substring' splitter, but instead of splitting it outputs the input as @'Markup' x -- 'OccurenceTag'@ in order to distinguish overlapping strings. parseSubstring :: forall m x y. (Monad m, Eq x) => [x] -> Parser m x OccurenceTag-parseSubstring [] = Transducer $-                    \ source sink -> let next = get source-                                                >>= maybe (return []) wrap-                                         wrap x = put sink (Content x) >>= cond prepend (return [x])-                                         prepend = put sink (Markup (Point (toEnum 1))) >>= cond next (return [])-                                     in prepend+parseSubstring [] = Transducer $ \ source sink ->+                    put sink marker >> mapMStream_ (\x-> put sink (Content x) >> put sink marker) source+   where marker = Markup (Point (toEnum 1)) parseSubstring list    = Transducer $      \ source sink ->@@ -324,30 +269,21 @@                                               in if x == head                                                  then if null tail                                                       then put sink (Markup (Start (toEnum id')))-                                                           >>= cond-                                                                  (put sink qh-                                                                   >>= cond-                                                                          (fallback id' (qt-                                                                                         |> Markup (End (toEnum id'))))-                                                                          (return $ remainingContent q'))-                                                                  (return $ remainingContent q')+                                                           >> put sink qh+                                                           >> (fallback id' (qt |> Markup (End (toEnum id'))))                                                       else getNext id tail q'                                                  else fallback id q'             fallback id q = case Seq.viewl q                             of EmptyL -> getNext id list q                                head@(Markup (End id')) :< tail -> put sink head-                                                                  >>= cond-                                                                         (fallback-                                                                             (if id == fromEnum id' then 0 else id)-                                                                             tail)-                                                                         (return $ remainingContent tail)+                                                                  >> fallback+                                                                        (if id == fromEnum id' then 0 else id)+                                                                        tail                                view@(head@Content{} :< tail) -> case stripPrefix (remainingContent q) list                                                                 of Just rest -> getNext id rest q                                                                    Nothing -> put sink head-                                                                              >>= cond-                                                                                     (fallback id tail)-                                                                                     (return $ remainingContent q)-            flush q = liftM extractContent $ putList (Foldable.toList $ Seq.viewl q) sink+                                                                              >> fallback id tail+            flush q = putQueue q sink             remainingContent :: Seq (Markup OccurenceTag x) -> [x]             remainingContent q = extractContent (Seq.viewl q)             extractContent :: Foldable.Foldable f => f (Markup b x) -> [x]@@ -358,10 +294,7 @@ -- argument. If two overlapping parts of the input both match the argument, both are sent to /true/ and each is preceded -- by an edge. substring :: forall m x. (Monad m, Eq x) => [x] -> Splitter m x ()-substring [] = Splitter $-               \ source true false edge -> do rest <- split one source false true edge-                                              put edge ()-                                              return rest+substring [] = Splitter $ \ source true false edge -> split one source false true edge >> put edge () substring list    = Splitter $      \ source true false edge ->@@ -376,9 +309,7 @@                                                   then if null tail                                                        then put edge ()                                                             >> put true qqh-                                                            >>= cond-                                                                   (fallback qqt Seq.empty)-                                                                   (return $ Foldable.toList view)+                                                            >> fallback qqt Seq.empty                                                       else getNext tail qt qf'                                                  else fallback qt qf'             fallback qt qf = case Seq.viewl (qt >< qf)@@ -387,11 +318,7 @@                                                        of Just rest -> getNext rest qt qf                                                           Nothing -> if Seq.null qt                                                                      then put false head-                                                                             >>= cond-                                                                                    (fallback Seq.empty tail)-                                                                                    (return $ Foldable.toList view)+                                                                          >> fallback Seq.empty tail                                                                      else put true head-                                                                             >>= cond-                                                                                    (fallback (Seq.drop 1 qt) qf)-                                                                                    (return $ Foldable.toList view)+                                                                          >> fallback (Seq.drop 1 qt) qf         in getNext list Seq.empty Seq.empty

@@ -15,12 +15,12 @@ -}  -- | This module defines 'Source' and 'Sink' types and 'pipe' functions that create them. The method 'get' on 'Source'--- abstracts away 'Control.Concurrent.SCC.Coroutine.await', and the method 'put' on 'Sink' is a higher-level--- abstraction of 'Control.Concurrent.SCC.Coroutine.yield'. With this arrangement, a single coroutine can yield values+-- abstracts away 'Control.Concurrent.Coroutine.await', and the method 'put' on 'Sink' is a higher-level abstraction of+-- 'Control.Concurrent.Coroutine.SuspensionFunctors.yield'. With this arrangement, a single coroutine can yield values -- to multiple sinks and await values from multiple sources with no need to change the--- 'Control.Concurrent.SCC.Coroutine.Coroutine' functor; the only requirement is for each funtor of the sources and--- sinks the coroutine uses to be an 'Control.Concurrent.SCC.Coroutine.AncestorFunctor' of the coroutine's--- functor. For example, coroutine /zip/ that takes two sources and one sink would be declared like this:+-- 'Control.Concurrent.Coroutine.Coroutine' functor; the only requirement is for each funtor of the sources and sinks+-- the coroutine uses to be an 'Control.Concurrent.Coroutine.AncestorFunctor' of the coroutine's functor. For example,+-- coroutine /zip/ that takes two sources and one sink would be declared like this: --  -- @ -- zip :: forall m a1 a2 a3 d x y. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d)@@ -37,8 +37,8 @@ -- add :: forall m a1 a2 a3 d. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d) --        => Source m a1 Integer -> Source m a2 Integer -> Sink m a3 Integer -> Coroutine d m () -- add source1 source2 sink = do pipe---                                  (\pairSink-> zip source1 source2 pairSink)            -- producer coroutine---                                  (\pairSource-> pourMap (uncurry (+)) pairSource sink) -- consumer coroutine+--                                  (\pairSink-> zip source1 source2 pairSink)              -- producer coroutine+--                                  (\pairSource-> mapStream (uncurry (+)) pairSource sink) -- consumer coroutine --                               return () -- @ @@ -47,64 +47,76 @@ module Control.Concurrent.SCC.Streams    (     -- * Sink and Source types-    Sink(put, canPut), Source(get),-    SinkFunctor, SourceFunctor,-    -- * Various pipe functions-    pipe, pipeP, pipePS,-    -- * Utility functions-    get', getSuccess,+    Sink, Source, SinkFunctor, SourceFunctor, AncestorFunctor,+    -- * Sink and Source constructors+    pipe, pipeP, pipePS, nullSink, nullSource,+    -- * Operations on sinks and sources+    -- ** Singleton operations+    get, put, getWith,+    -- ** Lifting functions     liftSink, liftSource,-    consumeAndSuppress, tee, pour, pourMap, getList, putList, putQueue,-    cond, whenNull+    -- ** Bulk operations+    pour, tee, teeSink, teeSource,+    mapStream, mapSource, mapSink, mapMStream, mapMSource, mapMSink, mapMStream_,+    mapMaybeStream, mapMaybeSink, mapMaybeSource,+    filterMStream, filterMSource, filterMSink,+    foldStream, foldMStream, foldMStream_, mapAccumStream, partitionStream,+    unfoldMStream, unmapMStream_,+    zipWithMStream, parZipWithMStream,+    getList, putList, putQueue,+    -- * Utility functions+    cond    ) where -import Control.Concurrent.Coroutine+import qualified Control.Monad+import qualified Data.List+import qualified Data.Maybe -import Control.Monad (when)+import Control.Monad (liftM, when) import Data.Foldable (toList) import Data.Sequence (Seq, viewl) -type TryYield x = EitherFunctor (Yield x) (Await Bool)--tryYield :: forall m x. Monad m => x -> Coroutine (TryYield x) m Bool-tryYield x = suspend (LeftF (Yield x (suspend (RightF (Await return)))))--canYield :: forall m x. Monad m => Coroutine (TryYield x) m Bool-canYield = suspend (RightF (Await return))+import Control.Monad.Parallel (MonadParallel(..))+import Control.Monad.Coroutine+import Control.Monad.Coroutine.SuspensionFunctors (Await(Await), Yield(Yield), EitherFunctor(..), await, yield)+import Control.Monad.Coroutine.Nested (AncestorFunctor(..), liftOut, seesawNested)  type SourceFunctor a x = EitherFunctor a (Await (Maybe x))-type SinkFunctor a x = EitherFunctor a (TryYield x)+type SinkFunctor a x = EitherFunctor a (Yield x)  -- | A 'Sink' can be used to yield values from any nested `Coroutine` computation whose functor provably descends from--- the functor /a/. It's the write-only end of a 'Pipe' communication channel.-data Sink (m :: * -> *) a x =+-- the functor /a/. It's the write-only end of a communication channel created by 'pipe'.+newtype Sink (m :: * -> *) a x =    Sink    {-   -- | Function 'put' tries to put a value into the given `Sink`. The intervening 'Coroutine' computations suspend up-   -- to the 'pipe' invocation that has created the argument sink. The result of 'put' indicates whether the operation-   -- succeded.-   put :: forall d. (AncestorFunctor a d) => x -> Coroutine d m Bool,-   -- | Function 'canPut' checks if the argument `Sink` accepts values, i.e., whether a 'put' operation would succeed on-   -- the sink.-   canPut :: forall d. (AncestorFunctor a d) => Coroutine d m Bool+   -- | This function puts a value into the given `Sink`. The intervening 'Coroutine' computations suspend up+   -- to the 'pipe' invocation that has created the argument sink.+   put :: forall d. AncestorFunctor a d => x -> Coroutine d m ()    }  -- | A 'Source' can be used to read values into any nested `Coroutine` computation whose functor provably descends from--- the functor /a/. It's the read-only end of a 'Pipe' communication channel.+-- the functor /a/. It's the read-only end of a communication channel created by 'pipe'. newtype Source (m :: * -> *) a x =    Source    {    -- | Function 'get' tries to get a value from the given 'Source' argument. The intervening 'Coroutine' computations    -- suspend all the way to the 'pipe' function invocation that created the source. The function returns 'Nothing' if    -- the argument source is empty.-   get :: forall d. (AncestorFunctor a d) => Coroutine d m (Maybe x)+   get :: forall d. AncestorFunctor a d => Coroutine d m (Maybe x)    } +-- | A disconnected sink that ignores all values 'put' into it.+nullSink :: forall m a x. Monad m => Sink m a x+nullSink = Sink{put= const (return ())}++-- | An empty source whose 'get' always returns Nothing.+nullSource :: forall m a x. Monad m => Source m a x+nullSource = Source{get= return Nothing}+ -- | Converts a 'Sink' on the ancestor functor /a/ into a sink on the descendant functor /d/. liftSink :: forall m a d x. (Monad m, AncestorFunctor a d) => Sink m a x -> Sink m d x-liftSink s = Sink {put= liftOut . (put s :: x -> Coroutine d m Bool),-                   canPut= liftOut (canPut s :: Coroutine d m Bool)}+liftSink s = Sink {put= liftOut . (put s :: x -> Coroutine d m ())}  -- | Converts a 'Source' on the ancestor functor /a/ into a source on the descendant functor /d/. liftSource :: forall m a d x. (Monad m, AncestorFunctor a d) => Source m a x -> Source m d x@@ -117,13 +129,13 @@         (Sink m a1 x -> Coroutine a1 m r1) -> (Source m a2 x -> Coroutine a2 m r2) -> Coroutine a m (r1, r2) pipe = pipeG (\ f mx my -> do {x <- mx; y <- my; f x y}) --- | The 'pipeP' function is equivalent to 'pipe', except the /producer/ and /consumer/ are run in parallel.-pipeP :: forall m a a1 a2 x r1 r2. (ParallelizableMonad m, Functor a, a1 ~ SinkFunctor a x, a2 ~ SourceFunctor a x) =>+-- | The 'pipeP' function is equivalent to 'pipe', except it runs the /producer/ and the /consumer/ in parallel.+pipeP :: forall m a a1 a2 x r1 r2. (MonadParallel m, Functor a, a1 ~ SinkFunctor a x, a2 ~ SourceFunctor a x) =>          (Sink m a1 x -> Coroutine a1 m r1) -> (Source m a2 x -> Coroutine a2 m r2) -> Coroutine a m (r1, r2) pipeP = pipeG bindM2  -- | The 'pipePS' function acts either as 'pipeP' or as 'pipe', depending on the argument /parallel/.-pipePS :: forall m a a1 a2 x r1 r2. (ParallelizableMonad m, Functor a, a1 ~ SinkFunctor a x, a2 ~ SourceFunctor a x) =>+pipePS :: forall m a a1 a2 x r1 r2. (MonadParallel m, Functor a, a1 ~ SinkFunctor a x, a2 ~ SourceFunctor a x) =>           Bool -> (Sink m a1 x -> Coroutine a1 m r1) -> (Source m a2 x -> Coroutine a2 m r2) ->           Coroutine a m (r1, r2) pipePS parallel = if parallel then pipeP else pipe@@ -134,81 +146,211 @@       -> (Sink m a1 x -> Coroutine a1 m r1) -> (Source m a2 x -> Coroutine a2 m r2)       -> Coroutine a m (r1, r2) pipeG run2 producer consumer =-   seesawNested run2 resolver (producer sink) (consumer source)-   where sink = Sink {put= liftOut . (local . tryYield :: x -> Coroutine a1 m Bool),-                      canPut= liftOut (local canYield :: Coroutine a1 m Bool)} :: Sink m a1 x-         source = Source (liftOut (local await :: Coroutine a2 m (Maybe x))) :: Source m a2 x+   liftM (uncurry (flip (,))) $ seesawNested run2 resolver (consumer source) (producer sink)+   where sink = Sink {put= liftOut . (mapSuspension RightF . yield :: x -> Coroutine a1 m ())} :: Sink m a1 x+         source = Source (liftOut (mapSuspension RightF await :: Coroutine a2 m (Maybe x))) :: Source m a2 x          resolver = SeesawResolver {-                      resumeLeft= \s-> case s of (LeftF (Yield _ c))-> c-                                                 (RightF (Await c))-> c False,-                      resumeRight = \(Await c)-> c Nothing,-                      resumeAny= \ resumeProducer _ resumeBoth s (Await cc) ->-                                 case s of LeftF (Yield x cp) -> resumeBoth cp (cc (Just x))-                                           RightF (Await cp) -> resumeProducer (cp True)+                      resumeLeft = \(Await c)-> c Nothing,+                      resumeRight= \(Yield _ c)-> c,+                      resumeAny= \ _ resumeProducer resumeBoth (Await cc) (Yield x cp) -> resumeBoth (cc (Just x)) cp                     } -getSuccess :: forall m a d x . (Monad m, AncestorFunctor a d)-              => Source m a x -> (x -> Coroutine d m ()) {- ^ Success continuation -} -> Coroutine d m ()-getSuccess source succeed = get source >>= maybe (return ()) succeed---- | Function 'get'' assumes that the argument source is not empty and returns the value the source yields. If the--- source is empty, the function throws an error.-get' :: forall m a d x . (Monad m, AncestorFunctor a d) => Source m a x -> Coroutine d m x-get' source = get source >>= maybe (error "get' failed") return+-- | Invokes its first argument with the value it gets from the source, if there is any to get.+getWith :: forall m a d x. (Monad m, AncestorFunctor a d) => (x -> Coroutine d m ()) -> Source m a x -> Coroutine d m ()+getWith consumer source = get source >>= maybe (return ()) consumer --- | 'pour' copies all data from the /source/ argument into the /sink/ argument, as long as there is anything to copy--- and the sink accepts it.+-- | 'pour' copies all data from the /source/ argument into the /sink/ argument. pour :: forall m a1 a2 d x . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)         => Source m a1 x -> Sink m a2 x -> Coroutine d m ()-pour source sink = fill'-   where fill' = canPut sink >>= flip when (getSuccess source (\x-> put sink x >> fill'))+pour source sink = mapMStream_ (put sink) source --- | 'pourMap' is like 'pour' that applies the function /f/ to each argument before passing it into the /sink/.-pourMap :: forall m a1 a2 d x y . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)+-- | 'mapStream' is like 'pour' that applies the function /f/ to each argument before passing it into the /sink/.+mapStream :: forall m a1 a2 d x y . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)            => (x -> y) -> Source m a1 x -> Sink m a2 y -> Coroutine d m ()-pourMap f source sink = loop-   where loop = canPut sink >>= flip when (get source >>= maybe (return ()) (\x-> put sink (f x) >> loop))+mapStream f source sink = mapMStream_ (put sink . f) source --- | 'pourMapMaybe' is to 'pourMap' like 'Data.Maybe.mapMaybe' is to 'Data.List.Map'.-pourMapMaybe :: forall m a1 a2 d x y . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)+-- | An equivalent of 'Data.List.map' that works on a 'Source' instead of a list. The argument function is applied to+-- every value after it's read from the source argument.+mapSource :: forall m a x y. Monad m => (x -> y) -> Source m a x -> Source m a y+mapSource f source = Source{get= liftM (fmap f) (get source)}++-- | An equivalent of 'Data.List.map' that works on a 'Sink' instead of a list. The argument function is applied to+-- every value vefore it's written to the sink argument.+mapSink :: forall m a x y. Monad m => (x -> y) -> Sink m a y -> Sink m a x+mapSink f sink = Sink{put= put sink . f}++-- | 'mapMaybeStream' is to 'mapStream' like 'Data.Maybe.mapMaybe' is to 'Data.List.map'.+mapMaybeStream :: forall m a1 a2 d x y . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)                 => (x -> Maybe y) -> Source m a1 x -> Sink m a2 y -> Coroutine d m ()-pourMapMaybe f source sink = loop-   where loop = canPut sink >>= flip when (get source >>= maybe (return ()) (\x-> maybe (return False) (put sink) (f x) >> loop))+mapMaybeStream f source sink = mapMStream_ (maybe (return ()) (put sink) . f) source --- | 'tee' is similar to 'pour' except it distributes every input value from the /source/ arguments into both /sink1/--- and /sink2/.+-- | 'mapMaybeSink' is to 'mapSink' like 'Data.Maybe.mapMaybe' is to 'Data.List.map'.+mapMaybeSink :: forall m a x y . Monad m => (x -> Maybe y) -> Sink m a y -> Sink m a x+mapMaybeSink f sink = Sink{put= maybe (return ()) (put sink) . f}++-- | 'mapMaybeSource' is to 'mapSource' like 'Data.Maybe.mapMaybe' is to 'Data.List.map'.+mapMaybeSource :: forall m a x y . Monad m => (x -> Maybe y) -> Source m a x -> Source m a y+mapMaybeSource f source = Source{get= next}+   where next :: forall d. AncestorFunctor a d => Coroutine d m (Maybe y)+         next = get source+                >>= maybe (return Nothing) (maybe next (return . Just) . f)++-- | 'mapMStream' is similar to 'Control.Monad.mapM'. It draws the values from a 'Source' instead of a list, writes the+-- mapped values to a 'Sink', and returns a 'Coroutine'.+mapMStream :: forall m a1 a2 d x y . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)+              => (x -> Coroutine d m y) -> Source m a1 x -> Sink m a2 y -> Coroutine d m ()+mapMStream f source sink = loop+   where loop = getWith (\x-> f x >>= put sink >> loop) source++-- | An equivalent of 'Control.Monad.mapM' that works on a 'Source' instead of a list. Similar to 'mapSource', except+-- the function argument is monadic and may have perform effects.+mapMSource :: forall m a x y. Monad m+              => (forall d. AncestorFunctor a d => x -> Coroutine d m y) -> Source m a x -> Source m a y+mapMSource f source = Source{get= get source >>= maybe (return Nothing) (liftM Just . f)}++-- | An equivalent of 'Control.Monad.mapM' that works on a 'Sink' instead of a list. Similar to 'mapSink', except the+-- function argument is monadic and may have perform effects.+mapMSink :: forall m a x y. Monad m+            => (forall d. AncestorFunctor a d => x -> Coroutine d m y) -> Sink m a y -> Sink m a x+mapMSink f sink = Sink{put= (put sink =<<) . f}++-- | 'mapMStream_' is similar to 'Control.Monad.mapM_' except it draws the values from a 'Source' instead of a list and+-- works with 'Coroutine' instead of an arbitrary monad.+mapMStream_ :: forall m a d x . (Monad m, AncestorFunctor a d)+              => (x -> Coroutine d m ()) -> Source m a x -> Coroutine d m ()+mapMStream_ f source = loop+   where loop = getWith (\x-> f x >> loop) source++-- | An equivalent of 'Control.Monad.filterM'. Draws the values from a 'Source' instead of a list, writes the filtered+-- values to a 'Sink', and returns a 'Coroutine'.+filterMStream :: forall m a1 a2 d x . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)+              => (x -> Coroutine d m Bool) -> Source m a1 x -> Sink m a2 x -> Coroutine d m ()+filterMStream f source sink = mapMStream_ (\x-> f x >>= cond (put sink x) (return ())) source++-- | An equivalent of 'Control.Monad.filterM'; filters a 'Source' instead of a list.+filterMSource :: forall m a x y . Monad m+                 => (forall d. AncestorFunctor a d => x -> Coroutine d m Bool) -> Source m a x -> Source m a x+filterMSource f source = Source{get= find}+   where find :: forall d. AncestorFunctor a d => Coroutine d m (Maybe x)+         find = get source >>= maybe (return Nothing) (\x-> f x >>= cond (return (Just x)) find)++-- | An equivalent of 'Control.Monad.filterM'; filters a 'Sink' instead of a list.+filterMSink :: forall m a x y . Monad m+               => (forall d. AncestorFunctor a d => x -> Coroutine d m Bool) -> Sink m a x -> Sink m a x+filterMSink f sink = Sink{put= \x-> f x >>= cond (put sink x) (return ())}++-- | Similar to 'Data.List.foldl', but reads the values from a 'Source' instead of a list.+foldStream :: forall m a d x acc . (Monad m, AncestorFunctor a d)+              => (acc -> x -> acc) -> acc -> Source m a x -> Coroutine d m acc+foldStream f s source = loop s+   where loop s = get source >>= maybe (return s) (\x-> loop (f s x))++-- | 'foldMStream' is similar to 'Control.Monad.foldM' except it draws the values from a 'Source' instead of a list and+-- works with 'Coroutine' instead of an arbitrary monad.+foldMStream :: forall m a d x acc . (Monad m, AncestorFunctor a d)+              => (acc -> x -> Coroutine d m acc) -> acc -> Source m a x -> Coroutine d m acc+foldMStream f acc source = loop acc+   where loop acc = get source >>= maybe (return acc) (\x-> f acc x >>= loop)++-- | A version of 'foldMStream' that ignores the final result value.+foldMStream_ :: forall m a d x acc . (Monad m, AncestorFunctor a d)+                => (acc -> x -> Coroutine d m acc) -> acc -> Source m a x -> Coroutine d m ()+foldMStream_ f acc source = loop acc+   where loop acc = getWith (\x-> f acc x >>= loop) source++-- | 'unfoldMStream' is a version of 'Data.List.unfoldr' that writes the generated values into a 'Sink' instead of+-- returning a list.+unfoldMStream :: forall m a d x acc . (Monad m, AncestorFunctor a d)+                 => (acc -> Coroutine d m (Maybe (x, acc))) -> acc -> Sink m a x -> Coroutine d m acc+unfoldMStream f acc sink = loop acc+   where loop acc = f acc >>= maybe (return acc) (\(x, acc')-> put sink x >> loop acc')++-- | 'unmapMStream_' is opposite of 'mapMStream_'; it takes a 'Sink' instead of a 'Source' argument and writes the+-- generated values into it.+unmapMStream_ :: forall m a d x . (Monad m, AncestorFunctor a d)+                 => Coroutine d m (Maybe x) -> Sink m a x -> Coroutine d m ()+unmapMStream_ f sink = loop+   where loop = f >>= maybe (return ()) (\x-> put sink x >> loop)++-- | 'mapAccumStream' is similar to 'Data.List.mapAccumL' except it reads the values from a 'Source' instead of a list+-- and writes the mapped values into a 'Sink' instead of returning another list.+mapAccumStream :: forall m a1 a2 d x y acc . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)+                  => (acc -> x -> (acc, y)) -> acc -> Source m a1 x -> Sink m a2 y -> Coroutine d m acc+mapAccumStream f acc source sink = loop acc+   where loop acc = get source >>= maybe (return acc) (\x-> let (acc', y) = f acc x in put sink y >> loop acc')++-- | Equivalent to 'Data.List.partition'. Takes a 'Source' instead of a list argument and partitions its contents into+-- the two 'Sink' arguments.+partitionStream :: forall m a1 a2 a3 d x . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d)+                   => (x -> Bool) -> Source m a1 x -> Sink m a2 x -> Sink m a3 x -> Coroutine d m ()+partitionStream f source true false = mapMStream_ (\x-> if f x then put true x else put false x) source++-- | 'zipWithMStream' is similar to 'Control.Monad.zipWithM' except it draws the values from two 'Source' arguments+-- instead of two lists, sends the results into a 'Sink', and works with 'Coroutine' instead of an arbitrary monad.+zipWithMStream :: forall m a1 a2 a3 d x y z. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d)+                  => (x -> y -> Coroutine d m z) -> Source m a1 x -> Source m a2 y -> Sink m a3 z -> Coroutine d m ()+zipWithMStream f source1 source2 sink = loop+   where loop = do mx <- get source1+                   my <- get source2+                   case (mx, my) of (Just x, Just y) -> f x y >>= put sink >> loop+                                    _ -> return ()++-- | 'parZipWithMStream' is equivalent to 'zipWithMStream', but it consumes the two sources in parallel.+parZipWithMStream :: forall m a1 a2 a3 d x y z.+                     (MonadParallel m, AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d)+                     => (x -> y -> Coroutine d m z) -> Source m a1 x -> Source m a2 y -> Sink m a3 z -> Coroutine d m ()+parZipWithMStream f source1 source2 sink = loop+   where loop = bindM2 zip (get source1) (get source2)+         zip (Just x) (Just y) = f x y >>= put sink >> loop+         zip _ _ = return ()++-- | 'tee' is similar to 'pour' except it distributes every input value from its source argument into its both sink+-- arguments. tee :: forall m a1 a2 a3 d x . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d)        => Source m a1 x -> Sink m a2 x -> Sink m a3 x -> Coroutine d m () tee source sink1 sink2 = distribute-   where distribute = do c1 <- canPut sink1-                         c2 <- canPut sink2-                         when (c1 && c2)-                            (get source >>= maybe (return ()) (\x-> put sink1 x >> put sink2 x >> distribute))+   where distribute = get source >>= maybe (return ()) (\x-> put sink1 x >> put sink2 x >> distribute) --- | 'putList' puts entire list into its /sink/ argument, as long as the sink accepts it. The remainder that wasn't--- accepted by the sink is the result value.-putList :: forall m a d x. (Monad m, AncestorFunctor a d) => [x] -> Sink m a x -> Coroutine d m [x]-putList [] sink = return []-putList l@(x:rest) sink = put sink x >>= cond (putList rest sink) (return l)+-- | Every value 'put' into a 'teeSink' result sink goes into its both argument sinks: @put (teeSink s1 s2) x@ is+-- equivalent to @put s1 x >> put s2 x@.+teeSink :: forall m a1 a2 a3 x . (Monad m, AncestorFunctor a1 a3, AncestorFunctor a2 a3)+           => Sink m a1 x -> Sink m a2 x -> Sink m a3 x+teeSink s1 s2 = Sink{put= tee}+   where tee :: forall d. AncestorFunctor a3 d => x -> Coroutine d m ()+         tee x = put s1' x >> put s2' x+         s1' :: Sink m a3 x+         s1' = liftSink s1+         s2' :: Sink m a3 x+         s2' = liftSink s2 +-- | The 'Source' returned by 'teeSource' writes every value read from its argument source into the argument sink before+-- providing it back.+teeSource :: forall m a1 a2 a3 x . (Monad m, AncestorFunctor a1 a3, AncestorFunctor a2 a3)+             => Sink m a1 x -> Source m a2 x -> Source m a3 x+teeSource sink source = Source{get= tee}+   where tee :: forall d. AncestorFunctor a3 d => Coroutine d m (Maybe x)+         tee = do mx <- get source'+                  maybe (return ()) (put sink') mx+                  return mx+         sink' :: Sink m a3 x+         sink' = liftSink sink+         source' :: Source m a3 x+         source' = liftSource source++-- | 'putList' puts entire list into its /sink/ argument.+putList :: forall m a d x. (Monad m, AncestorFunctor a d) => [x] -> Sink m a x -> Coroutine d m ()+putList [] sink = return ()+putList l@(x:rest) sink = put sink x >> putList rest sink+ -- | 'getList' returns the list of all values generated by the source. getList :: forall m a d x. (Monad m, AncestorFunctor a d) => Source m a x -> Coroutine d m [x] getList source = getList' return    where getList' f = get source >>= maybe (f []) (\x-> getList' (f . (x:))) --- | 'consumeAndSuppress' consumes the entire source ignoring the values it generates.-consumeAndSuppress :: forall m a d x. (Monad m, AncestorFunctor a d) => Source m a x -> Coroutine d m ()-consumeAndSuppress source = get source-                            >>= maybe (return ()) (const (consumeAndSuppress source))- -- | A utility function wrapping if-then-else, useful for handling monadic truth values cond :: a -> a -> Bool -> a cond x y test = if test then x else y --- | A utility function, useful for handling monadic list values where empty list means success-whenNull :: forall a m. Monad m => m [a] -> [a] -> m [a]-whenNull action list = if null list then action else return list- -- | Like 'putList', except it puts the contents of the given 'Data.Sequence.Seq' into the sink.-putQueue :: forall m a d x. (Monad m, AncestorFunctor a d) => Seq x -> Sink m a x -> Coroutine d m [x]+putQueue :: forall m a d x. (Monad m, AncestorFunctor a d) => Seq x -> Sink m a x -> Coroutine d m () putQueue q sink = putList (toList (viewl q)) sink

@@ -14,7 +14,7 @@     <http://www.gnu.org/licenses/>. -} --- | This module defines various 'Control.Concurrent.SCC.Coroutine.Coroutine' types that operate on+-- | This module defines various 'Control.Concurrent.SCC.Coroutine' types that operate on -- 'Control.Concurrent.SCC.Streams.Sink' and 'Control.Concurrent.SCC.Streams.Source' values. The simplest of the bunch -- are 'Consumer' and 'Producer' types, which respectively operate on a single source or sink. A 'Transducer' has access -- both to a 'Control.Concurrent.SCC.Streams.Source' to read from and a 'Control.Concurrent.SCC.Streams.Sink' to write@@ -35,55 +35,56 @@     Branching (combineBranches),      -- * Constructors     isolateConsumer, isolateProducer, isolateTransducer, isolateSplitter,-    oneToOneTransducer, statelessTransducer, foldingTransducer, statefulTransducer,+    oneToOneTransducer, statelessTransducer, statefulTransducer,     statelessSplitter, statefulSplitter,     -- * Utility functions-    splitToConsumers, splitInputToConsumers, pipePS+    splitToConsumers, splitInputToConsumers, pipePS, (>|>), (<|<)    ) where -import Control.Concurrent.Coroutine+import Control.Monad.Coroutine+import Control.Monad.Parallel (MonadParallel(..))+ import Control.Concurrent.SCC.Streams +import Control.Category (Category(..)) import Control.Monad (liftM, when) import Data.Maybe (maybe)  type OpenConsumer m a d x r = AncestorFunctor a d => Source m a x -> Coroutine d m r type OpenProducer m a d x r = AncestorFunctor a d => Sink m a x -> Coroutine d m r-type OpenTransducer m a1 a2 d x y = -   (AncestorFunctor a1 d, AncestorFunctor a2 d) => Source m a1 x -> Sink m a2 y -> Coroutine d m [x]-type OpenSplitter m a1 a2 a3 a4 d x b =+type OpenTransducer m a1 a2 d x y r = +   (AncestorFunctor a1 d, AncestorFunctor a2 d) => Source m a1 x -> Sink m a2 y -> Coroutine d m r+type OpenSplitter m a1 a2 a3 a4 d x b r =    (AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d, AncestorFunctor a4 d) =>-   Source m a1 x -> Sink m a2 x -> Sink m a3 x -> Sink m a4 b -> Coroutine d m [x]+   Source m a1 x -> Sink m a2 x -> Sink m a3 x -> Sink m a4 b -> Coroutine d m r --- | A component that performs a computation with no inputs nor outputs.+-- | A coroutine that has no inputs nor outputs - and therefore may not suspend at all, which means it's not really a+-- /co/routine. newtype Performer m r = Performer {perform :: m r} --- | A component that consumes values from a 'Control.Concurrent.SCC.Streams.Source'.+-- | A coroutine that consumes values from a 'Control.Concurrent.SCC.Streams.Source'. newtype Consumer m x r = Consumer {consume :: forall a d. OpenConsumer m a d x r} --- | A component that produces values and puts them into a 'Control.Concurrent.SCC.Streams.Sink'.+-- | A coroutine that produces values and puts them into a 'Control.Concurrent.SCC.Streams.Sink'. newtype Producer m x r = Producer {produce :: forall a d. OpenProducer m a d x r} --- | The 'Transducer' type represents computations that transform a data stream.  Execution of 'transduce' must continue+-- | The 'Transducer' type represents coroutines that transform a data stream.  Execution of 'transduce' must continue -- consuming the given 'Control.Concurrent.SCC.Streams.Source' and feeding the 'Control.Concurrent.SCC.Streams.Sink' as--- long both can be resumed. If the sink dies first, 'transduce' should return the list of all values it has consumed--- from the source but hasn't managed to process and write into the sink.-newtype Transducer m x y = Transducer {transduce :: forall a1 a2 d. OpenTransducer m a1 a2 d x y}+-- long as there is any data in the source.+newtype Transducer m x y = Transducer {transduce :: forall a1 a2 d. OpenTransducer m a1 a2 d x y ()} --- | The 'SplitterComponent' type represents computations that distribute the input stream acording to some criteria. A--- splitter should distribute only the original input data, and feed it into the sinks in the same order it has been--- read from the source. Furthermore, the input source should be entirely consumed and fed into the first two sinks. The--- third sink can be used to supply extra information at arbitrary points in the input. If any of the sinks dies before--- all data is fed to them, 'split' should return the list of all values it has consumed from the source but hasn't--- managed to write into the sinks.+-- | The 'Splitter' type represents coroutines that distribute the input stream acording to some criteria. A splitter+-- should distribute only the original input data, and feed it into the sinks in the same order it has been read from+-- the source. Furthermore, the input source should be entirely consumed and fed into the first two sinks. The third+-- sink can be used to supply extra information at arbitrary points in the input. --  -- A splitter can be used in two ways: as a predicate to determine which portions of its input stream satisfy a certain -- property, or as a chunker to divide the input stream into chunks. In the former case, the predicate is considered -- true for exactly those parts of the input that are written to its /true/ sink. In the latter case, a chunk is a -- contiguous section of the input stream that is written exclusively to one sink, either true or false. Anything -- written to the third sink also terminates the chunk.-newtype Splitter m x b = Splitter {split :: forall a1 a2 a3 a4 d. OpenSplitter m a1 a2 a3 a4 d x b}+newtype Splitter m x b = Splitter {split :: forall a1 a2 a3 a4 d. OpenSplitter m a1 a2 a3 a4 d x b ()}  -- | A 'Markup' value is produced to mark either a 'Start' and 'End' of a region of data, or an arbitrary -- 'Point' in data. A 'Point' is semantically equivalent to a 'Start' immediately followed by 'End'. The 'Content'@@ -105,6 +106,24 @@    showsPrec p (Content x) s = x : s    showsPrec p (Markup b) s = '[' : shows b (']' : s) +instance Monad m => Category (Transducer m) where+   id = Transducer pour+   t1 . t2 = isolateTransducer $ \source sink-> +             pipe (transduce t2 source) (\source-> transduce t1 source sink)+             >> return ()++-- | Same as 'Control.Category.>>>' except it runs the two transducers in parallel.+(>|>) :: MonadParallel m => Transducer m x y -> Transducer m y z -> Transducer m x z+t1 >|> t2 = isolateTransducer $ \source sink-> +            pipeP (transduce t1 source) (\source-> transduce t2 source sink)+            >> return ()++-- | Same as 'Control.Category.<<<' except it runs the two transducers in parallel.+(<|<) :: MonadParallel m => Transducer m y z -> Transducer m x y -> Transducer m x z+t1 <|< t2 = isolateTransducer $ \source sink-> +            pipeP (transduce t2 source) (\source-> transduce t1 source sink)+            >> return ()+ -- | Creates a proper 'Consumer' from a function that is, but can't be proven to be, an 'OpenConsumer'. isolateConsumer :: forall m x r. Monad m => (forall d. Functor d => Source m d x -> Coroutine d m r) -> Consumer m x r isolateConsumer consume = Consumer consume'@@ -123,9 +142,9 @@  -- | Creates a proper 'Transducer' from a function that is, but can't be proven to be, an 'OpenTransducer'. isolateTransducer :: forall m x y. Monad m => -                     (forall d. Functor d => Source m d x -> Sink m d y -> Coroutine d m [x]) -> Transducer m x y+                     (forall d. Functor d => Source m d x -> Sink m d y -> Coroutine d m ()) -> Transducer m x y isolateTransducer transduce = Transducer transduce'-   where transduce' :: forall a1 a2 d. OpenTransducer m a1 a2 d x y+   where transduce' :: forall a1 a2 d. OpenTransducer m a1 a2 d x y ()          transduce' source sink = let source' :: Source m d x                                       source' = liftSource source                                       sink' :: Sink m d y@@ -135,10 +154,10 @@ -- | Creates a proper 'Splitter' from a function that is, but can't be proven to be, an 'OpenSplitter'. isolateSplitter :: forall m x b. Monad m =>                     (forall d. Functor d => -                    Source m d x -> Sink m d x -> Sink m d x -> Sink m d b -> Coroutine d m [x]) +                    Source m d x -> Sink m d x -> Sink m d x -> Sink m d b -> Coroutine d m ())                     -> Splitter m x b isolateSplitter split = Splitter split'-   where split' :: forall a1 a2 a3 a4 d. OpenSplitter m a1 a2 a3 a4 d x b+   where split' :: forall a1 a2 a3 a4 d. OpenSplitter m a1 a2 a3 a4 d x b ()          split' source true false edge = let source' :: Source m d x                                              source' = liftSource source                                              true' :: Sink m d x@@ -163,17 +182,9 @@ instance forall m x r. Monad m => Branching (Consumer m x r) m x r where    combineBranches combinator parallel c1 c2 = Consumer $ combinator parallel (consume c1) (consume c2) -instance forall m x. Monad m => Branching (Consumer m x ()) m x [x] where-   combineBranches combinator parallel c1 c2-      = Consumer $-        liftM (const ())-        . combinator parallel-             (\source-> consume c1 source >> return [])-             (\source-> consume c2 source >> return [])--instance forall m x y. Monad m => Branching (Transducer m x y) m x [x] where+instance forall m x y. Monad m => Branching (Transducer m x y) m x () where    combineBranches combinator parallel t1 t2-      = let transduce' :: forall a1 a2 d. OpenTransducer m a1 a2 d x y+      = let transduce' :: forall a1 a2 d. OpenTransducer m a1 a2 d x y ()             transduce' source sink = combinator parallel                                         (\source-> transduce t1 source sink')                                         (\source-> transduce t2 source sink')@@ -182,9 +193,9 @@                      sink' = liftSink sink         in Transducer transduce' -instance forall m x b. (ParallelizableMonad m) => Branching (Splitter m x b) m x [x] where+instance forall m x b. (MonadParallel m) => Branching (Splitter m x b) m x () where    combineBranches combinator parallel s1 s2-      = let split' :: forall a1 a2 a3 a4 d. OpenSplitter m a1 a2 a3 a4 d x b+      = let split' :: forall a1 a2 a3 a4 d. OpenSplitter m a1 a2 a3 a4 d x b ()             split' source true false edge = combinator parallel                                                (\source-> split s1 source true' false' edge')                                                (\source-> split s2 source true' false' edge')@@ -200,62 +211,32 @@ -- | Function 'oneToOneTransducer' takes a function that maps one input value to one output value each, and lifts it -- into a 'Transducer'. oneToOneTransducer :: Monad m => (x -> y) -> Transducer m x y-oneToOneTransducer f = Transducer $-                      \source sink-> let t = canPut sink-                                             >>= flip when (getSuccess source (\x-> put sink (f x) >> t))-                                     in t >> return []+oneToOneTransducer f = Transducer (mapStream f)  -- | Function 'statelessTransducer' takes a function that maps one input value into a list of output values, and -- lifts it into a 'Transducer'. statelessTransducer :: Monad m => (x -> [y]) -> Transducer m x y-statelessTransducer f = Transducer $-                            \source sink-> let t = canPut sink-                                                   >>= flip when (getSuccess source (\x-> putList (f x) sink >> t))-                                           in t >> return []---- | Function 'foldingTransducer' creates a stateful transducer that produces only one output value after consuming the--- entire input. Similar to 'Data.List.foldl'-foldingTransducer :: Monad m => (s -> x -> s) -> s -> (s -> y) -> Transducer m x y-foldingTransducer f s0 w = Transducer $-                            \source sink-> let t s = canPut sink-                                                     >>= flip when (get source-                                                                    >>= maybe-                                                                           (put sink (w s) >> return ())-                                                                           (t . f s))-                                           in t s0 >> return []+statelessTransducer f = Transducer (\source sink-> mapMStream_ (\x-> putList (f x) sink) source)  -- | Function 'statefulTransducer' constructs a 'Transducer' from a state-transition function and the initial -- state. The transition function may produce arbitrary output at any transition step. statefulTransducer :: Monad m => (state -> x -> (state, [y])) -> state -> Transducer m x y-statefulTransducer f s0 = Transducer $-                              \source sink-> let t s = canPut sink-                                                       >>= flip when (getSuccess source-                                                                      (\x-> let (s', ys) = f s x-                                                                            in putList ys sink >> t s'))-                                             in t s0 >> return []+statefulTransducer f s0 = +   Transducer (\source sink-> foldMStream_ (\ s x -> let (s', ys) = f s x in putList ys sink >> return s') s0 source)  -- | Function 'statelessSplitter' takes a function that assigns a Boolean value to each input item and lifts it into -- a 'Splitter'. statelessSplitter :: Monad m => (x -> Bool) -> Splitter m x b-statelessSplitter f = Splitter (\source true false edge->-                                    let s = get source-                                            >>= maybe-                                                   (return [])-                                                   (\x-> (if f x then put true x else put false x)-                                                         >>= cond s (return [x]))-                                    in s)+statelessSplitter f = Splitter (\source true false edge-> partitionStream f source true false)  -- | Function 'statefulSplitter' takes a state-converting function that also assigns a Boolean value to each input -- item and lifts it into a 'Splitter'. statefulSplitter :: Monad m => (state -> x -> (state, Bool)) -> state -> Splitter m x ()-statefulSplitter f s0 = Splitter (\source true false edge->-                                      let split s = get source-                                                    >>= maybe-                                                           (return [])-                                                           (\x-> let (s', truth) = f s x-                                                                 in (if truth then put true x else put false x)-                                                                    >>= cond (split s') (return [x]))-                                      in split s0)+statefulSplitter f s0 = +   Splitter (\source true false edge-> +              foldMStream_ +                 (\ s x -> let (s', truth) = f s x in (if truth then put true x else put false x) >> return s')+                 s0 source)  -- | Given a 'Splitter', a 'Source', and three consumer functions, 'splitToConsumers' runs the splitter on the source -- and feeds the splitter's outputs to its /true/, /false/, and /edge/ sinks, respectively, to the three consumers.@@ -266,7 +247,7 @@                     (Source m (SourceFunctor d1 x) x -> Coroutine (SourceFunctor d1 x) m r2) ->                     (Source m (SourceFunctor (SinkFunctor d1 x) b) b                      -> Coroutine (SourceFunctor (SinkFunctor d1 x) b) m r3) ->-                    Coroutine d m ([x], r1, r2, r3)+                    Coroutine d m ((), r1, r2, r3) splitToConsumers s source trueConsumer falseConsumer edgeConsumer    = pipe         (\true-> pipe@@ -279,21 +260,17 @@  -- | Given a 'Splitter', a 'Source', and two consumer functions, 'splitInputToConsumers' runs the splitter on the source -- and feeds the splitter's /true/ and /false/ outputs, respectively, to the two consumers.-splitInputToConsumers :: forall m a d d1 x b. (ParallelizableMonad m, d1 ~ SinkFunctor d x, AncestorFunctor a d) =>+splitInputToConsumers :: forall m a d d1 x b. (MonadParallel m, d1 ~ SinkFunctor d x, AncestorFunctor a d) =>                          Bool -> Splitter m x b -> Source m a x ->-                         (Source m (SourceFunctor d1 x) x -> Coroutine (SourceFunctor d1 x) m [x]) ->-                         (Source m (SourceFunctor d x) x -> Coroutine (SourceFunctor d x) m [x]) ->-                         Coroutine d m [x]+                         (Source m (SourceFunctor d1 x) x -> Coroutine (SourceFunctor d1 x) m ()) ->+                         (Source m (SourceFunctor d x) x -> Coroutine (SourceFunctor d x) m ()) ->+                         Coroutine d m () splitInputToConsumers parallel s source trueConsumer falseConsumer    = pipePS parallel         (\false-> pipePS parallel-                     (\true-> pipePS parallel-                                 (split s source' true false)-                                 consumeAndSuppress)+                     (\true-> split s source' true false (nullSink :: Sink m d b))                      trueConsumer)         falseConsumer-     >>= \(((extra, _), xs1), xs2)-> return (prependCommonPrefix xs1 xs2 extra)-   where prependCommonPrefix (x:xs) (y:ys) tail = x : prependCommonPrefix xs ys tail-         prependCommonPrefix _ _ tail = tail-         source' :: Source m d x+     >> return ()+   where source' :: Source m d x          source' = liftSource source

@@ -1,5 +1,5 @@ {- -    Copyright 2009 Mario Blazevic+    Copyright 2009-2010 Mario Blazevic      This file is part of the Streaming Component Combinators (SCC) project. @@ -32,22 +32,26 @@ ) where +import Prelude hiding (mapM) import Control.Exception (assert)-import Control.Monad (liftM, when)+import Control.Monad (join, liftM, when) import Data.Char import qualified Data.Map as Map import Data.Maybe (fromJust, isJust, mapMaybe) import Data.List (find, stripPrefix) import qualified Data.Sequence as Seq import Data.Sequence ((|>))+import Data.Traversable (Traversable, mapM) import Numeric (readDec, readHex) import Debug.Trace (trace) -import Control.Concurrent.Coroutine+import Control.Monad.Coroutine+import Control.Monad.Parallel (MonadParallel(..))+ import Control.Concurrent.SCC.Streams import Control.Concurrent.SCC.Types-import Control.Concurrent.SCC.Combinators (groupMarks, splitterToMarker, parseNestedRegions)-import Control.Concurrent.SCC.Primitives (unparse)+import Control.Concurrent.SCC.Combinators (groupMarks, splitterToMarker, parseNestedRegions,+                                           findsTrueIn, findsFalseIn, teeConsumers)   data Token = StartTag | EndTag | EmptyTag@@ -91,148 +95,164 @@ tokens :: Monad m => Splitter m Char (Boundary Token) tokens = Splitter $          \source true false edge->-         let getContent = get source-                          >>= maybe (return []) content-             content '<' = get source-                           >>= maybe (return "<") (\x-> tag x >> get source >>= maybe (return []) content)-             content '&' = entity >> next content+         let getContent = getWith content source+             content '<' = getWith (\x-> tag x >> getWith content source) source+             content '&' = entity >> getWith content source              content x = put false x-                         >>= cond getContent (return [x])-             tag '?' = put edge (Start ProcessingInstruction)-                       >> putList "<?" true-                       >>= whenNull (put edge (Start ProcessingInstructionText)-                                     >> processingInstruction)+                         >> getContent+             tag '?' = do put edge (Start ProcessingInstruction)+                          putList "<?" true+                          put edge (Start ProcessingInstructionText)+                          processingInstruction              tag '!' = dispatchOnString source-                          (\other-> put edge (Point (ErrorToken ("Expecting <![CDATA[ or <!--, received "-                                                                 ++ show ("<![" ++ other))))-                                    >> return ("<!" ++ other))+                          (\other-> put edge (Point (errorBadDeclarationType other)))                           [("--",-                            \match-> put edge (Start Comment)-                                     >> putList match true-                                     >>= whenNull (put edge (Start CommentText)-                                                   >> comment)),+                            \match-> do put edge (Start Comment)+                                        putList match true+                                        put edge (Start CommentText)+                                        comment),                            ("[CDATA[",-                            \match-> put edge (Start StartMarkedSectionCDATA)-                                     >> putList match true-                                     >>= whenNull (put edge (End StartMarkedSectionCDATA)-                                                   >> markedSection))]+                            \match-> do put edge (Start StartMarkedSectionCDATA)+                                        putList match true+                                        put edge (End StartMarkedSectionCDATA)+                                        markedSection)]              tag '/' = {-# SCC "EndTag" #-}                        do put edge (Start EndTag)                           put true '<'                           put true '/'-                          x <- next (name ElementName)-                          put true x-                          when (x /= '>')-                               (put edge (Point (ErrorToken ("Invalid character " ++ show x ++ " in end tag")))-                                >> return ())+                          next errorInputEndInEndTag+                               (\x-> name ElementName x+                                        >>= maybe+                                               (put edge (Point errorInputEndInEndTag))+                                               (\x-> do put true x+                                                        when (x /= '>') (put edge (Point (errorBadEndTag x)))))                           put edge (End EndTag)-                          return []-             tag x | isNameStart x-                   = {-# SCC "StartTag" #-}-                     do put edge (Start StartTag)-                        put true '<'-                        y <- name ElementName x-                        z <- attributes y-                        w <- if z == '/'-                                then put true z >> put edge (Point EmptyTag)-                                     >> get source+             tag x | isNameStart x = {-# SCC "StartTag" #-}+                                     put edge (Start StartTag)+                                     >> put true '<'+                                     >> name ElementName x                                      >>= maybe-                                            (put edge (Point (ErrorToken ("Missing '>' at the end of start tag.")))-                                             >> return '>')-                                            return-                                else return z-                        put true w-                        when (w /= '>') (put edge (Point (ErrorToken ("Invalid character " ++ show w-                                                                      ++ " in start tag")))-                                         >> return ())-                        put edge (End StartTag)-                        return []-             tag x = put edge (Point (ErrorToken "Unescaped character '<' in content"))+                                            (put edge (Point errorInputEndInStartTag))+                                            (\y-> attributes y+                                                  >>= maybe+                                                         (put edge (Point errorInputEndInStartTag))+                                                         startTagEnd)+                                     >> put edge (End StartTag)+             tag x = put edge (Point errorUnescapedContentLT)                      >> put false '<'                      >> put false x-                     >> return []-             attributes x | isSpace x = put true x >> next attributes+             startTagEnd '/' = put true '/'+                               >> put edge (Point EmptyTag)+                               >> next errorInputEndInStartTag+                                     (\x-> put true x >> when (x /= '>') (put edge (Point (errorBadStartTag x))))+             startTagEnd '>' = put true '>'+             startTagEnd x = put true x+                             >> put edge (Point (errorBadStartTag x))+             attributes x | isSpace x = put true x >> get source >>= mapJoinM attributes              attributes x | isNameStart x-                = do y <- name AttributeName x-                     when (y /= '=') (put edge (Point (ErrorToken ("Invalid character " ++ show y-                                                                   ++ " following attribute name")))-                                      >> return ())-                     q <- if y == '"' || y == '\''-                          then return y-                          else put true y >> get source-                               >>= maybe (put edge (Point (ErrorToken ("Truncated input after attribute name")))-                                          >> return '"')-                                         return-                     when-                        (q /= '"' && q /= '\'')-                        (put edge (Point (ErrorToken ("Invalid quote character " ++ show q)))-                         >> return ())-                     put true q-                     put edge (Start AttributeValue)-                     next (attributeValue q)-                     next attributes-             attributes x = return x+                = name AttributeName x+                  >>= mapJoinM+                         (\y-> do when (y /= '=') (put edge (Point (errorBadAttribute y)))+                                  q <- if y == '"' || y == '\''+                                       then return y+                                       else put true y >> get source+                                            >>= maybe+                                                   (put edge (Point errorInputEndInAttributeValue)+                                                    >> return '"')+                                                   return+                                  when (q /= '"' && q /= '\'') (put edge (Point (errorBadQuoteCharacter q)))+                                  put true q+                                  put edge (Start AttributeValue)+                                  get source+                                         >>= maybe+                                                (put edge (Point errorInputEndInAttributeValue)+                                                 >> put edge (End AttributeValue))+                                                (attributeValue q)+                                  get source >>= mapJoinM attributes)+             attributes x = return (Just x)              attributeValue q x | q == x = do put edge (End AttributeValue)                                               put true x-             attributeValue q '<' = do put edge (Start (ErrorToken "Invalid character '<' in attribute value."))+             attributeValue q '<' = do put edge (Start errorUnescapedAttributeLT)                                        put true '<'-                                       put edge (End (ErrorToken "Invalid character '<' in attribute value."))-                                       next (attributeValue q)-             attributeValue q '&' = entity >> next (attributeValue q)-             attributeValue q x = put true x >> next (attributeValue q)+                                       put edge (End errorUnescapedAttributeLT)+                                       next errorInputEndInAttributeValue (attributeValue q)+             attributeValue q '&' = entity >> next errorInputEndInAttributeValue (attributeValue q)+             attributeValue q x = put true x >> next errorInputEndInAttributeValue (attributeValue q)              processingInstruction = {-# SCC "PI" #-}                                      dispatchOnString source                                         (\other-> if null other-                                                  then (put edge (Point (ErrorToken "Unterminated processing instruction"))-                                                        >> return [])-                                                  else putList other true >>= whenNull processingInstruction)+                                                  then put edge (Point errorInputEndInProcessingInstruction)+                                                  else putList other true >> processingInstruction)                                         [("?>",-                                          \match-> put edge (End ProcessingInstructionText)-                                                   >> putList match true-                                                   >>= whenNull (put edge (End ProcessingInstruction)-                                                                 >> getContent))]+                                          \match-> do put edge (End ProcessingInstructionText)+                                                      putList match true+                                                      put edge (End ProcessingInstruction)+                                                      getContent)]              comment = {-# SCC "comment" #-}                        dispatchOnString source                           (\other-> if null other-                                    then (put edge (Point (ErrorToken "Unterminated comment"))-                                          >> return [])-                                    else putList other true >>= whenNull comment)+                                    then put edge (Point errorInputEndInComment)+                                    else putList other true >> comment)                           [("-->",-                            \match-> put edge (End CommentText)-                                     >> putList match true-                                     >>= whenNull (put edge (End Comment)-                                                   >> getContent))]+                            \match-> do put edge (End CommentText)+                                        putList match true+                                        put edge (End Comment)+                                        getContent)]              markedSection = {-# SCC "<![CDATA[" #-}                              dispatchOnString source                                 (\other-> if null other-                                          then (put edge (Point (ErrorToken "Unterminated marked section"))-                                                >> return [])-                                          else putList other true >>= whenNull markedSection)+                                          then put edge (Point errorInputEndInMarkedSection)+                                          else putList other true >> markedSection)                                 [("]]>",-                                  \match-> put edge (Start EndMarkedSection)-                                           >> putList match true-                                           >>= whenNull (put edge (End EndMarkedSection)-                                                         >> getContent))]-             entity = do put edge (Start EntityReferenceToken)-                         put true '&'-                         x <- next (name EntityName)-                         when (x /= ';') (put edge (Point (ErrorToken ("Invalid character " ++ show x-                                                                       ++ " ends entity name.")))-                                          >> return ())-                         put true x-                         put edge (End EntityReferenceToken)-             name token x | isNameStart x = {-# SCC "name" #-} -                                            do put edge (Start token)-                                               put true x-                                               next (nameTail token)-             name _ x = do put edge (Point (ErrorToken ("Invalid character " ++ show x ++ " in attribute value.")))-                           return x+                                  \match-> do put edge (Start EndMarkedSection)+                                              putList match true+                                              put edge (End EndMarkedSection)+                                              getContent)]+             entity = put edge (Start EntityReferenceToken)+                      >> put true '&'+                      >> next errorInputEndInEntityReference+                            (\x-> name EntityName x+                                  >>= maybe +                                         (put edge (Point errorInputEndInEntityReference))+                                         (\x-> do when (x /= ';') (put edge (Point (errorBadEntityReference x)))+                                                  put true x))+                      >> put edge (End EntityReferenceToken)+             name token x | isNameStart x = {-# SCC "name" #-}+                                            put edge (Start token)+                                            >> put true x+                                            >> get source+                                            >>= maybe+                                                   (put edge (End token) >> return Nothing)+                                                   (nameTail token)+             name _ x = return (Just x)              nameTail token x = if isNameChar x || x == ':'-                                then put true x >> next (nameTail token)-                                else put edge (End token) >> return x-             next f = {-# SCC "next" #-} get' source >>= f+                                then put true x+                                     >> get source+                                     >>= maybe+                                            (put edge (End token) >> return Nothing)+                                            (nameTail token)+                                else put edge (End token) >> return (Just x)+             next error f = get source+                            >>= maybe (put edge (Point error)) f          in getContent +errorInputEndInComment = ErrorToken "Unterminated comment"+errorInputEndInMarkedSection = ErrorToken "Unterminated marked section"+errorInputEndInStartTag = ErrorToken "Missing '>' at the end of start tag."+errorInputEndInEndTag = ErrorToken "End of input in end tag"+errorInputEndInAttributeValue = ErrorToken "Truncated input after attribute name"+errorInputEndInEntityReference = ErrorToken "End of input in entity reference"+errorInputEndInProcessingInstruction = ErrorToken "Unterminated processing instruction"+errorBadQuoteCharacter q = ErrorToken ("Invalid quote character " ++ show q)+errorBadStartTag x = ErrorToken ("Invalid character " ++ show x ++ " in start tag")+errorBadEndTag x = ErrorToken ("Invalid character " ++ show x ++ " in end tag")+errorBadAttribute x = ErrorToken ("Invalid character " ++ show x ++ " following attribute name")+errorBadAttributeValue x = ErrorToken ("Invalid character " ++ show x ++ " in attribute value.")+errorBadEntityReference x = ErrorToken ("Invalid character " ++ show x ++ " ends entity name.")+errorBadDeclarationType other = ErrorToken ("Expecting <![CDATA[ or <!--, received " ++ show ("<![" ++ other))+errorUnescapedContentLT = ErrorToken "Unescaped character '<' in content"+errorUnescapedAttributeLT = ErrorToken "Invalid character '<' in attribute value."+ -- | The XML token parser. This parser converts plain text to parsed text, which is a precondition for using the -- remaining XML components. parseTokens :: Monad m => Parser m Char Token@@ -282,16 +302,16 @@ pourRestOfRegion :: forall m a1 a2 a3 d. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d) =>                     Token -> Source m a1 (Markup Token Char)                           -> Sink m a2 (Markup Token Char) -> Sink m a3 (Markup Token Char)-                 -> Coroutine d m (Maybe [Markup Token Char])+                 -> Coroutine d m Bool pourRestOfRegion token source sink endSink    = get source      >>= maybe-            (return $ Just [])+            (return False)             (\x-> case x                   of Markup (End token') | token == token' -> put endSink x-                                                              >>= cond (return Nothing) (return $ Just [x])+                                                              >> return True                      Content y -> put sink x-                                  >>= cond (pourRestOfRegion token source sink endSink) (return $ Just [x])+                                  >> pourRestOfRegion token source sink endSink                      _ -> error ("Expected rest of " ++ show token ++ ", received " ++ show x))  pourRestOfTag :: forall m a1 a2 d. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d) =>@@ -309,74 +329,62 @@ findEndTag :: forall m a1 a2 a3 d. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d) =>               Source m a1 (Markup Token Char) -> Sink m a2 (Markup Token Char) -> Sink m a3 (Markup Token Char)                                               -> String-           -> Coroutine d m [Markup Token Char]+           -> Coroutine d m () findEndTag source sink endSink name = find where-   find = get source-          >>= maybe-                 (return [])-                 (\x-> case x-                       of Markup (Start EndTag) -> do (tokens, mn) <- getElementName source (x :)-                                                      maybe-                                                         (return tokens)-                                                         (\name'-> if name == name'-                                                                   then putList tokens endSink-                                                                        >>= whenNull-                                                                               (pourRestOfTag source endSink-                                                                                >> return [])-                                                                   else putList tokens sink-                                                                        >>= whenNull-                                                                               (pourRestOfTag source sink-                                                                                >> find))-                                                         mn-                          Markup (Start StartTag) -> do (tokens, mn) <- getElementName source (x :)-                                                        maybe-                                                           (return tokens)-                                                           (\name'-> putList tokens sink-                                                                     >>= whenNull-                                                                            (if name == name'-                                                                             then pourRestOfTag source sink-                                                                                  >>= cond-                                                                                         (findEndTag source sink sink name)-                                                                                         (return [])-                                                                                  >>= whenNull find-                                                                             else pourRestOfTag source sink-                                                                                  >> find))-                                                           mn-                          _ -> put sink x-                               >>= cond find (return [x]))+   find = getWith consumeOne source+   consumeOne x@(Markup (Start EndTag)) = do (tokens, mn) <- getElementName source (x :)+                                             maybe+                                                (return ())+                                                (\name'-> if name == name'+                                                          then do putList tokens endSink+                                                                  pourRestOfTag source endSink+                                                                  return ()+                                                          else do putList tokens sink+                                                                  pourRestOfTag source sink+                                                                  find)+                                                mn+   consumeOne x@(Markup (Start StartTag)) = do (tokens, mn) <- getElementName source (x :)+                                               maybe+                                                  (return ())+                                                  (\name'-> putList tokens sink+                                                            >> if name == name'+                                                               then pourRestOfTag source sink+                                                                    >>= flip when (findEndTag source sink sink name)+                                                                    >> find+                                                               else pourRestOfTag source sink+                                                                    >> find)+                                                  mn+   consumeOne x = put sink x >> find  findStartTag :: forall m a1 a2 d. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d) =>                 Source m a1 (Markup Token Char) -> Sink m a2 (Markup Token Char)-             -> Coroutine d m (Either [Markup Token Char] (Markup Token Char))+             -> Coroutine d m (Maybe (Markup Token Char)) findStartTag source sink = get source                            >>= maybe-                                  (return $ Left [])-                                  (\x-> case x of Markup (Start StartTag) -> return $ Right x+                                  (return Nothing)+                                  (\x-> case x of Markup (Start StartTag) -> return $ Just x                                                   _ -> put sink x-                                                       >>= cond (findStartTag source sink) (return $ Left [x]))+                                                       >> findStartTag source sink)  -- | Splits all top-level elements with all their content to /true/, all other input to /false/. element :: Monad m => Splitter m (Markup Token Char) () element = Splitter $           \source true false edge->           let split0 = findStartTag source false-                       >>= either return-                              (\x-> put edge ()-                                    >> put true x-                                    >>= cond-                                           (do (tokens, mn) <- getElementName source id-                                               maybe-                                                  (putList tokens true)-                                                  (\name-> putList tokens true-                                                           >>= whenNull-                                                                  (pourRestOfTag source true-                                                                   >>= cond-                                                                          (split1 name)-                                                                          split0))-                                                  mn)-                                           (return [x]))+                       >>= maybe (return ())+                              (\x-> do put edge ()+                                       put true x+                                       (tokens, mn) <- getElementName source id+                                       maybe+                                          (putList tokens true)+                                          (\name-> putList tokens true+                                                   >> pourRestOfTag source true+                                                   >>= cond+                                                          (split1 name)+                                                          split0)+                                             mn)               split1 name = findEndTag source true true name-                            >>= whenNull split0+                            >> split0           in split0  -- | Splits the content of all top-level elements to /true/, their tags and intervening input to /false/.@@ -384,87 +392,68 @@ elementContent = Splitter $                  \source true false edge->                  let split0 = findStartTag source false-                              >>= either return-                                     (\x-> put false x-                                           >>= cond-                                                  (do (tokens, mn) <- getElementName source id-                                                      maybe-                                                         (putList tokens false)-                                                         (\name-> putList tokens false-                                                                  >>= whenNull (pourRestOfTag source false-                                                                                >>= cond-                                                                                       (put edge ()-                                                                                        >> split1 name)-                                                                                       split0))-                                                         mn)-                                                  (return [x]))+                              >>= maybe (return ())+                                     (\x-> do put false x+                                              (tokens, mn) <- getElementName source id+                                              maybe+                                                 (putList tokens false)+                                                 (\name-> putList tokens false+                                                          >> pourRestOfTag source false+                                                          >>= cond+                                                                 (put edge ()+                                                                  >> split1 name)+                                                                 split0)+                                                 mn)                      split1 name = findEndTag source true false name-                                   >>= whenNull split0+                                   >> split0                  in split0  -- | Similiar to @('Control.Concurrent.SCC.Combinators.having' 'element')@, except it runs the argument splitter -- only on each element's start tag, not on the entire element with its content.-elementHavingTag :: forall m b. ParallelizableMonad m =>+elementHavingTag :: forall m b. MonadParallel m =>                     Splitter m (Markup Token Char) b -> Splitter m (Markup Token Char) b elementHavingTag test =    isolateSplitter $ \ source true false edge ->       let split0 = findStartTag source false-                   >>= either return+                   >>= maybe (return ())                           (\x-> do (tokens, mn) <- getElementName source (x :)                                    maybe-                                      (return tokens)+                                      (return ())                                       (\name-> do (hasContent, rest) <- pipe                                                                            (pourRestOfTag source)                                                                            getList                                                   let tag = tokens ++ rest-                                                  (_, (unconsumed, maybeTrue, (), maybeEdge))-                                                     <- pipe-                                                           (putList tag)-                                                           (\tag-> splitToConsumers-                                                                      test-                                                                      tag-                                                                      get-                                                                      consumeAndSuppress-                                                                      get)-                                                  if isJust maybeTrue || isJust maybeEdge-                                                     then maybe (return True) (put edge) maybeEdge-                                                          >> putList tag true-                                                          >>= whenNull (split1 hasContent true name)-                                                     else putList tag false-                                                          >>= whenNull (split1 hasContent false name))+                                                  ((), found) <- pipe (putList tag) (findsTrueIn test)+                                                  case found of Just mb -> maybe (return ()) (put edge) mb+                                                                           >> putList tag true+                                                                           >> split1 hasContent true name+                                                                Nothing -> putList tag false+                                                                           >> split1 hasContent false name)                                       mn)-          split1 hasContent sink name = if hasContent-                                        then findEndTag source sink sink name >>= whenNull split0-                                        else split0+          split1 hasContent sink name = when hasContent (findEndTag source sink sink name)+                                        >> split0    in split0  -- | Splits every attribute specification to /true/, everything else to /false/. attribute :: Monad m => Splitter m (Markup Token Char) () attribute = Splitter $             \source true false edge->-            let split0 = get source-                         >>= maybe-                                (return [])-                                (\x-> case x of Markup (Start AttributeName)-                                                   -> put edge ()-                                                      >> put true x-                                                      >>= cond-                                                             (pourRestOfRegion AttributeName source true true-                                                              >>= maybe split1 return)-                                                             (return [x])-                                                _ -> put false x-                                                     >>= cond split0 (return [x]))-                split1 = get source-                         >>= maybe-                                (return [])-                                (\x-> case x of Markup (Start AttributeValue)-                                                   -> put true x-                                                      >>= cond-                                                             (pourRestOfRegion AttributeValue source true true-                                                              >>= maybe split0 return)-                                                             (return [x])-                                                _ -> put true x-                                                     >>= cond split1 (return [x]))+            let split0 = getWith+                            (\x-> case x+                                  of Markup (Start AttributeName) -> do put edge ()+                                                                        put true x+                                                                        pourRestOfRegion AttributeName source true true+                                                                                            >>= flip when split1+                                     _ -> put false x >> split0)+                            source+                split1 = getWith+                            (\x-> case x+                                  of Markup (Start AttributeValue)+                                        -> put true x+                                           >> pourRestOfRegion AttributeValue source true true+                                           >>= flip when split0+                                     _ -> put true x >> split1)+                            source             in split0  -- | Splits every element name, including the names of nested elements and names in end tags, to /true/, all the rest of@@ -481,71 +470,52 @@ attributeValue = Splitter (splitSimpleRegions AttributeValue)  splitSimpleRegions token source true false edge = split-   where split = get source-                 >>= maybe-                        (return [])-                        (\x-> case x of Markup (Start token') | token == token'-                                           -> put false x-                                              >>= cond-                                                     (put edge ()-                                                      >> pourRestOfRegion token source true false-                                                      >>= maybe split return)-                                                     (return [x])-                                        _ -> put false x-                                             >>= cond split (return [x]))+   where split = getWith consumeOne source+         consumeOne x@(Markup (Start token')) | token == token' = put false x+                                                                  >> put edge ()+                                                                  >> pourRestOfRegion token source true false+                                                                  >>= flip when split+         consumeOne x = put false x >> split  -- | Behaves like 'Control.Concurrent.SCC.Combinators.having', but the right-hand splitter works on plain instead of -- marked-up text. This allows regular 'Char' splitters to be applied to parsed XML.-havingText :: forall m b1 b2. ParallelizableMonad m =>+havingText :: forall m b1 b2. MonadParallel m =>               Bool -> Splitter m (Markup Token Char) b1 -> Splitter m Char b2 -> Splitter m (Markup Token Char) b1-havingText parallel chunker tester =-   isolateSplitter $ \ source true false edge ->-   let test Nothing chunk = pour chunk false >> return []-       test (Just mb) chunk = pipe-                                 (\sink1-> pipe (tee chunk sink1) getList)-                                 (\chunk-> liftM snd $-                                           pipe-                                              (transduce unparse chunk)-                                              (\chunk-> splitToConsumers tester chunk-                                                           (liftM isJust . get)-                                                           consumeAndSuppress-                                                           (liftM isJust . get)))-                              >>= \(((), prefix), (_, anyTrue, (), anyEdge))->-                                  if anyTrue || anyEdge-                                  then maybe (return True) (put edge) mb-                                       >> putList prefix true-                                       >>= whenNull (pour chunk true >> return [])-                                  else putList prefix false-                                       >>= whenNull (pour chunk false >> return [])-   in liftM fst $-      pipePS parallel-         (transduce (splitterToMarker chunker) source)-         (flip groupMarks test)+havingText parallel chunker tester = isolateSplitter havingText' where+   havingText' source true false edge =+      let test Nothing chunk = pour chunk false+          test (Just mb) chunk = teeConsumers False getList (findsTrueIn tester . mapMaybeSource justContent) chunk+                                 >>= \(chunk, found)->+                                     if isJust found+                                     then maybe (return ()) (put edge) mb+                                          >> putList chunk true+                                     else putList chunk false+      in liftM fst $+         pipePS parallel+            (transduce (splitterToMarker chunker) source)+            (flip groupMarks test)  -- | Behaves like 'Control.Concurrent.SCC.Combinators.havingOnly', but the right-hand splitter works on plain instead of -- marked-up text. This allows regular 'Char' splitters to be applied to parsed XML.-havingOnlyText :: forall m b1 b2. ParallelizableMonad m =>+havingOnlyText :: forall m b1 b2. MonadParallel m =>                   Bool -> Splitter m (Markup Token Char) b1 -> Splitter m Char b2 -> Splitter m (Markup Token Char) b1-havingOnlyText parallel chunker tester =-   isolateSplitter $ \ source true false edge ->-   let test Nothing chunk = pour chunk false >> return []-       test (Just mb) chunk = pipe-                                 (\sink1-> pipe (tee chunk sink1) getList)-                                 (\chunk-> liftM snd $-                                           pipe-                                              (transduce unparse chunk)-                                              (\chunk-> splitToConsumers tester chunk-                                                           consumeAndSuppress-                                                           (liftM isJust . get)-                                                           consumeAndSuppress))-                              >>= \(((), prefix), (_, (), anyFalse, ()))->-                                  if anyFalse-                                  then putList prefix false-                                       >>= whenNull (pour chunk false >> return [])-                                  else maybe (return True) (put edge) mb-                                       >> putList prefix true-                                       >>= whenNull (pour chunk true >> return [])-   in liftM fst $-      pipePS parallel-         (transduce (splitterToMarker chunker) source)-         (flip groupMarks test)+havingOnlyText parallel chunker tester = isolateSplitter havingOnlyText' where+   havingOnlyText' source true false edge =+      let test Nothing chunk = pour chunk false+          test (Just mb) chunk = teeConsumers False getList (findsFalseIn tester . mapMaybeSource justContent) chunk+                                 >>= \(chunk, found)->+                                     if found+                                     then putList chunk false+                                     else maybe (return ()) (put edge) mb+                                          >> putList chunk true+      in liftM fst $+         pipePS parallel+            (transduce (splitterToMarker chunker) source)+            (flip groupMarks test)++justContent (Content x) = Just x+justContent _ = Nothing++mapJoinM :: (Monad m, Monad t, Traversable t) => (a -> m (t b)) -> t a -> m (t b)+mapJoinM f ta = mapM f ta >>= return . join+

@@ -1,32 +1,42 @@-Executables=test test-prof shsh shsh-prof+Executables=test test-prof test-coroutine test-parallel shsh shsh-prof LibraryFiles=$(addprefix Control/Concurrent/SCC/, \                Streams.hs Types.hs Primitives.hs Combinators.hs Components.hs XML.hs) \-               Control/Concurrent/Coroutine.hs Control/Concurrent/Configuration.hs+               Control/Monad/Parallel.hs Control/Monad/Coroutine.hs \+               Control/Monad/Coroutine/SuspensionFunctors.hs Control/Monad/Coroutine/Nested.hs \+	            Control/Concurrent/Configuration.hs DocumentationFiles=$(LibraryFiles)-OptimizingOptions=-O2 -threaded -hidir obj -odir obj+OptimizingOptions=-O -threaded -hidir obj -odir obj ProfilingOptions=-prof -auto-all -hidir prof -odir prof  all: $(Executables) doc/index.html  docs: doc/index.html -test: $(LibraryFiles) Test.hs | obj-	ghc --make Test.hs -o test $(OptimizingOptions)+test: Test.hs $(LibraryFiles) | obj+	ghc --make $< -o $@ $(OptimizingOptions) -test-prof: $(LibraryFiles) Test.hs | prof-	ghc --make Test.hs -o test-prof $(ProfilingOptions)+test-prof: Test.hs $(LibraryFiles) | prof+	ghc --make $< -o $@ $(ProfilingOptions) -shsh: $(LibraryFiles) Shell.hs | obj-	ghc --make Shell.hs -o shsh $(OptimizingOptions)+test-coroutine: TestCoroutine.hs Control/Monad/Coroutine.hs Control/Monad/Coroutine/*.hs | obj+	ghc --make $< -o $@ $(OptimizingOptions) -shsh-prof: $(LibraryFiles) Shell.hs | prof-	ghc --make Shell.hs -o shsh-prof $(ProfilingOptions)+test-parallel: TestParallel.hs Control/Monad/Parallel.hs | obj+	ghc --make $< -o $@ $(OptimizingOptions) +shsh: Shell.hs $(LibraryFiles) | obj+	ghc --make $< -o $@ $(OptimizingOptions)++shsh-prof: Shell.hs $(LibraryFiles) | prof+	ghc --make $< -o $@ $(ProfilingOptions)+ doc/index.html: $(DocumentationFiles)-	haddock -h -o doc $^+	haddock -v -h -o doc \+	   -i http://www.haskell.org/ghc/docs/latest/html/libraries/base,/usr/share/doc/ghc/libraries/base/base.haddock \+	   $^  obj prof: 	mkdir -p $@  clean:-	rm -r obj/* prof/* doc/* $(Executables)+	rm -r obj/* prof/* doc/* dist/* $(Executables)

@@ -1,6 +1,6 @@  {- -    Copyright 2008-2009 Mario Blazevic+    Copyright 2008-2010 Mario Blazevic      This file is part of the Streaming Component Combinators (SCC) project. @@ -19,7 +19,7 @@  module Main where -import Prelude hiding (appendFile, interact, last, sequence)+import Prelude hiding (appendFile, interact, id, last, sequence) import Data.List (intersperse, partition) import Data.Char (isAlphaNum) import Data.Maybe (fromJust)@@ -45,7 +45,7 @@                   hGetChar, hGetContents, hPutChar, hFlush, hIsEOF, hClose, putChar, isEOF, stdout)  import Control.Concurrent.Configuration (Component, atomic, showComponentTree, usingThreads, with)-import Control.Concurrent.Coroutine+import Control.Monad.Coroutine import Control.Concurrent.SCC.Streams import Control.Concurrent.SCC.Types import Control.Concurrent.SCC.Components hiding ((&&), (||))@@ -428,7 +428,7 @@ compile UnitTag (FileProducer path) = Compiled (ProducerTag CharTag) (fromFile path) compile UnitTag StdInProducer = Compiled (ProducerTag CharTag) fromStdIn compile inputTag (FromList string) = Compiled (ProducerTag CharTag) (atomic "putList" 1 $ Producer $-                                                                     \sink-> putList string sink >> return ())+                                                                     \sink-> putList string sink) compile inputTag (FileConsumer path) = Compiled (ConsumerTag CharTag) (toFile path) compile inputTag (FileAppend path) = Compiled (ConsumerTag CharTag) (appendFile path) compile inputTag Suppress = Compiled (ConsumerTag inputTag) suppress@@ -446,7 +446,6 @@                             lift (hSetBuffering stdin NoBuffering                                   >> hSetBuffering stdout NoBuffering)                             interleave source stdin pid stdout sink-                            return []          interleave :: forall a1 a2 d. (AncestorFunctor a1 d, AncestorFunctor a2 d) =>                        Source IO a1 Char -> Handle -> Process.ProcessHandle -> Handle -> Sink IO a2 Char                     -> Coroutine d IO ()@@ -458,19 +457,16 @@                                              >>= maybe                                                     (lift (hPutChar stdin x) >> interleave2)                                                     (const interleave2))-                  interleave2 = canPut sink-                                >>= flip when (lift (hReady stdout)-                                               >>= flip when (lift (hGetChar stdout)-                                                              >>= put sink-                                                              >> return ())-                                               >> interleave1)-                  interleaveEnd = canPut sink-                                  >>= flip when (lift (hIsEOF stdout)-                                                 >>= cond-                                                        (lift $ hClose stdout)-                                                        (lift (hGetChar stdout)-                                                         >>= put sink-                                                         >> interleaveEnd))+                  interleave2 = lift (hReady stdout)+                                >>= flip when (lift (hGetChar stdout)+                                               >>= put sink)+                                >> interleave1+                  interleaveEnd = lift (hIsEOF stdout)+                                  >>= cond+                                         (lift $ hClose stdout)+                                         (lift (hGetChar stdout)+                                          >>= put sink+                                          >> interleaveEnd) compile inputTag (Select e) = case compile inputTag e                               of Compiled (SplitterTag tag _) s -> Compiled (TransducerTag tag tag) (select s)                                  Compiled tag _  -> TypeError tag (SplitterTag inputTag AnyTag) e@@ -501,16 +497,15 @@ compile inputTag (Substitute replacement) = wrapGenericProducerIntoTransducer substitute inputTag replacement compile inputTag ExecuteTransducer    = Compiled (TransducerTag CharTag CharTag) (atomic "execute" ioCost $ Transducer execute)-     where execute :: forall a1 a2 d. OpenTransducer IO a1 a2 d Char Char+     where execute :: forall a1 a2 d. OpenTransducer IO a1 a2 d Char Char ()            execute source sink = do let (source' :: Source IO d Char) = liftSource source                                     ((), command) <- pipe (pour source') getList                                     (Nothing, Just stdout, Nothing, pid)                                        <- lift (Process.createProcess                                                    (Process.shell command){Process.std_out= Process.CreatePipe})                                     produce (with $ fromHandle stdout True) sink-                                    return [] -compile inputTag IdentityTransducer = Compiled (TransducerTag inputTag inputTag) asis+compile inputTag IdentityTransducer = Compiled (TransducerTag inputTag inputTag) id compile inputTag Count = Compiled (TransducerTag inputTag IntTag) count compile inputTag@(ListTag itemTag) Concatenate = Compiled (TransducerTag inputTag itemTag) concatenate compile inputTag Concatenate = TypeError inputTag (ListTag AnyTag) Concatenate@@ -703,7 +698,7 @@            -> tryComponentCast tag2 tag1 t2 right (\t2'-> Compiled tag1 (combinator t1 t2'))  combineSplitterAndBranches :: forall x.-                              (forall x b cc. Branching cc IO x [x] => SplitterComponent IO x b -> Component cc -> Component cc -> Component cc)+                              (forall x b cc. Branching cc IO x () => SplitterComponent IO x b -> Component cc -> Component cc -> Component cc)                            -> TypeTag x -> Expression -> Expression -> Expression -> Expression combineSplitterAndBranches combinator inputTag splitter true false    = case (compile inputTag splitter, compile inputTag true, compile inputTag false)

@@ -1,5 +1,5 @@ {- -    Copyright 2008-2009 Mario Blazevic+    Copyright 2008-2010 Mario Blazevic      This file is part of the Streaming Component Combinators (SCC) project. @@ -19,7 +19,7 @@ module Main where  import Control.Concurrent.Configuration-import Control.Concurrent.Coroutine+import Control.Monad.Coroutine import Control.Concurrent.SCC.Streams import Control.Concurrent.SCC.Types import qualified Control.Concurrent.SCC.Combinators as Combinator@@ -39,7 +39,7 @@ import qualified Data.Sequence as Seq import Data.Sequence (Seq, (|>), (><), ViewL (EmptyL, (:<))) import Debug.Trace (trace)-import Prelude hiding (even, last)+import Prelude hiding (even, id, last) import qualified Prelude import Test.QuickCheck (Arbitrary, Gen, Property, -- CoArbitrary, Positive(Positive),                         arbitrary, coarbitrary, label, classify, choose, oneof, sized, quickCheck, variant, (==>))@@ -60,9 +60,9 @@  main = mapM_ quickCheck tests -tests = [label "pipe" $ \(input :: [Int])-> runCoroutine (pipe (putList input) getList) == Just ([], input),+tests = [label "pipe" $ \(input :: [Int])-> runCoroutine (pipe (putList input) getList) == Just ((), input),          label "pour" prop_pour,-         label "asis" prop_asis,+         label "id" prop_id,          label "suppress" prop_suppress,          label "substitute" prop_substitute,          label "prepend" prop_prepend,@@ -77,27 +77,27 @@                                                         (putList s)                                                         (consume $ with $                                                          uppercase >-> atomic "getList" 1 (Consumer getList)))-                  == Just ([], map toUpper s),+                  == Just ((), map toUpper s),          label "uppercase <<-" $ \s-> runCoroutine (pipe                                                         (produce $ with $                                                          atomic "putList" 1 (Producer (putList s)) >-> uppercase)                                                         getList)-                  == Just ([], map toUpper s),-         label "uppercase `join` asis" $ \s-> transducerOutput (uppercase `join` asis) s == map toUpper s ++ s,+                  == Just ((), map toUpper s),+         label "uppercase `join` id" $ \s-> transducerOutput (uppercase `join` id) s == map toUpper s ++ s,          label "prepend >-> append" (\(s :: String) prefix suffix->                                      transducerOutput (prepend (fromList prefix) >-> append (fromList suffix)) s                                      == prefix ++ s ++ suffix),-         label "prepend == (`join` asis) . substitute" $+         label "prepend == (`join` id) . substitute" $                \(s :: String) prefix-> transducerOutput (prepend (fromList prefix)) s-                                       == transducerOutput (substitute (fromList prefix) `join` asis) s,-         label "append == (asis `join`) . substitute" $+                                       == transducerOutput (substitute (fromList prefix) `join` id) s,+         label "append == (id `join`) . substitute" $                \(s :: String) suffix-> transducerOutput (append (fromList suffix)) s-                                       == transducerOutput (asis `join` substitute (fromList suffix)) s,+                                       == transducerOutput (id `join` substitute (fromList suffix)) s,          label "whitespace" $ \s-> splitterOutputs whitespace s == (filter isSpace s, filter (not . isSpace) s),-         label "ifs everything asis asis" $ \(s :: [TestEnum])-> transducerOutput (ifs everything asis asis) s == s,+         label "ifs everything id id" $ \(s :: [TestEnum])-> transducerOutput (ifs everything id id) s == s,          label "substring" $ \s (c :: TestEnum)-> splitterOutputs (substring [c]) s == (filter (==c) s, filter (/=c) s),-         label "ifs (substring X) uppercase asis" $-               \s (LowercaseLetter c)-> transducerOutput (ifs (substring [c]) uppercase asis) s+         label "ifs (substring X) uppercase id" $+               \s (LowercaseLetter c)-> transducerOutput (ifs (substring [c]) uppercase id) s                                         == map (\x-> if x == c then toUpper x else x) s,          label "parseSubstring" $ \s (c :: TestEnum)-> transducerOutput                                                           (parseSubstring [c] >-> select markedContent >-> unparse)@@ -113,11 +113,11 @@          label "parseRegions substring == parseSubstring" prop_substringVsParse,          label "count >-> toString >-> concatenate" $                \(s :: [TestEnum])-> transducerOutput (count >-> toString >-> concatenate) s == show (length s),-         label "foreach whitespace asis (prepend \"[\" >-> append \"]\")" $-               \s-> transducerOutput (foreach whitespace asis (prepend (fromList "[") >-> append (fromList "]"))) s+         label "foreach whitespace id (prepend \"[\" >-> append \"]\")" $+               \s-> transducerOutput (foreach whitespace id (prepend (fromList "[") >-> append (fromList "]"))) s                     == mapWords (("[" ++) . (++ "]")) s,-         label "foreach whitespace asis (count >-> toString >-> concatenate)" $-               \s-> transducerOutput (foreach whitespace asis (count >-> toString >-> concatenate)) s+         label "foreach whitespace id (count >-> toString >-> concatenate)" $+               \s-> transducerOutput (foreach whitespace id (count >-> toString >-> concatenate)) s                     == mapWords (show . length) s,          label "uppercase `wherever` (snot whitespace `having` substring X)" $                \s1 s2-> not (null s1) && length s1 < length s2 ==> classify (not (s1 `isInfixOf` s2)) "trivial" $@@ -143,20 +143,20 @@                    && transducerOutput (uppercase `wherever` (last letters)) "Hello, World" == "Hello, WORLD"),           label "(select (prefix letters))" (transducerOutput (select (prefix letters)) "Hello, World!" == "Hello"),-         label "(foreach letters (count >-> toString >-> concatenate) asis)"-                  (transducerOutput (foreach letters (count >-> toString >-> concatenate) asis) "Hola, Mundo!" == "4, 5!"),-         label "(foreach (letters `having` prefix (substring \"H\")) uppercase asis)"+         label "(foreach letters (count >-> toString >-> concatenate) id)"+                  (transducerOutput (foreach letters (count >-> toString >-> concatenate) id) "Hola, Mundo!" == "4, 5!"),+         label "(foreach (letters `having` prefix (substring \"H\")) uppercase id)"                   (transducerOutput (foreach                                         (letters `having` prefix (substring "H"))                                         uppercase-                                        asis)+                                        id)                       "Hello, World! Hola, Mundo!"                    == "HELLO, World! HOLA, Mundo!"),-         label "(foreach (letters `having` suffix (substring \"o\")) uppercase asis)"+         label "(foreach (letters `having` suffix (substring \"o\")) uppercase id)"                   (transducerOutput (foreach                                         (letters `having` suffix (substring "o"))                                         uppercase-                                        asis)+                                        id)                       "Hello, World! Hola, Mundo!"                    == "HELLO, World! Hola, MUNDO!"), @@ -204,10 +204,10 @@  prop_pour :: [Int] -> Bool prop_pour input = runCoroutine (pipe (putList input) (\source-> pipe (\sink-> pour source sink) getList))-                  == Just ([], ((), input))+                  == Just ((), ((), input)) -prop_asis :: [Int] -> Bool-prop_asis input = transducerOutput asis input == input+prop_id :: [Int] -> Bool+prop_id input = transducerOutput id input == input  prop_suppress :: [Int] -> Bool prop_suppress input = null (transducerOutput (consumeBy suppress :: TransducerComponent Identity Int ()) input)@@ -494,7 +494,7 @@                                                    (\source-> pipe                                                                  (\sink-> transduce t source sink)                                                                  getList))-                           of Identity ([], ([], output)) -> output+                           of Identity ((), ((), output)) -> output  splitterOutputs :: SplitterComponent Identity x b -> [x] -> ([x], [x]) splitterOutputs s input = case runCoroutine (pipe@@ -502,8 +502,8 @@                                                  (\source-> splitToConsumers (with s) source                                                                getList                                                                getList-                                                               consumeAndSuppress))-                          of Identity ([], ([], true, false, ())) -> (true, false)+                                                               (mapMStream_ (const $ return ()))))+                          of Identity ((), ((), true, false, ())) -> (true, false)  splitterUnifiedOutput :: forall x b. SplitterComponent Identity x b -> [x] -> [Either (x, Bool) b] splitterUnifiedOutput s input =@@ -515,12 +515,12 @@                      getList)    where mapSplit :: forall a d. AncestorFunctor a d =>                      SplitterComponent Identity x b -> Sink Identity a (Either (x, Bool) b) -> Source Identity d x-                  -> Coroutine d Identity ([x], (), (), ())+                  -> Coroutine d Identity ()          mapSplit s sink source = let sink' = liftSink sink :: Sink Identity d (Either (x, Bool) b)-                                  in splitToConsumers (with s) source-                                        (flip (pourMap (Left . (\x-> (x, True)))) sink')-                                        (flip (pourMap (Left . (\x-> (x, False)))) sink')-                                        (flip (pourMap Right) sink')+                                  in split (with s) source+                                        (mapSink (Left . (\x-> (x, True))) sink')+                                        (mapSink (Left . (\x-> (x, False))) sink')+                                        (mapSink Right sink')  splitterOutputChunks :: SplitterComponent Identity x b -> [x] -> [([x], Bool)] splitterOutputChunks s input = transducerOutput (foreach s@@ -542,17 +542,16 @@             where succeed x = let q' = q |> x                               in case head                                  of Nothing -> follow previous tail q'-                                    Just Nothing -> when (not previous) (put edge () >> return ())+                                    Just Nothing -> when (not previous) (put edge ())                                                     >> follow False tail q'-                                    Just (Just True) -> when (not previous) (put edge () >> return ())+                                    Just (Just True) -> when (not previous) (put edge ())                                                         >> putList (Foldable.toList (Seq.viewl q')) true-                                                        >>= whenNull (follow True tail Seq.empty)+                                                        >> follow True tail Seq.empty                                     Just (Just False) -> putList (Foldable.toList (Seq.viewl q')) false-                                                         >>= whenNull (follow False tail Seq.empty)+                                                         >> follow False tail Seq.empty                   fail = if find (maybe False isJust) trace2 == Just (Just (Just True))-                         then do when (not previous) (put edge () >> return ())-                                 result <- putList (Foldable.toList (Seq.viewl q)) true-                                 return result+                         then do when (not previous) (put edge ())+                                 putList (Foldable.toList (Seq.viewl q)) true                          else putList (Foldable.toList (Seq.viewl q)) false      in follow False (cycle (fst trace1 ++ [Just (Just $ snd trace1)])) Seq.empty 

@@ -1,15 +1,15 @@ Name:                scc-Version:             0.4+Version:             0.5 Cabal-Version:       >= 1.2 Build-Type:          Simple Synopsis:            Streaming component combinators Category:            Control, Combinators, Concurrency Tested-with:         GHC Description:-  SCC is a layered library of Streaming Component Combinators. The lowest layer defines the Coroutine monad transformer.-  The next few layers add stream abstractions and nested producer-consumer coroutine pairs. On top of that are streaming-  component types, a number of primitive streaming components and a set of component combinators. Finally, there is an-  executable that exposes all framework functionality in a command-line shell.+  SCC is a layered library of Streaming Component Combinators. The lowest layer defines stream abstractions and nested+  producer-consumer coroutine pairs based on the Coroutine monad transformer. On top of that are streaming component+  types, a number of primitive streaming components and a set of component combinators. Finally, there is an executable+  that exposes all the framework functionality in a command-line shell.   .   The original library design is based on paper <http://conferences.idealliance.org/extreme/html/2006/Blazevic01/EML2006Blazevic01.html>   .@@ -28,18 +28,18 @@  Executable shsh   Main-is:           Shell.hs-  Other-Modules:     Control.Concurrent.Coroutine,-                     Control.Concurrent.SCC.Streams, Control.Concurrent.SCC.Types,+  Other-Modules:     Control.Concurrent.SCC.Streams, Control.Concurrent.SCC.Types,                      Control.Concurrent.SCC.Combinators, Control.Concurrent.SCC.Primitives,                      Control.Concurrent.SCC.XML,                      Control.Concurrent.Configuration, Control.Concurrent.SCC.Components-  Build-Depends:     base < 5, containers, transformers, parallel, process, readline, parsec >= 3.0 && < 4.0+  Build-Depends:     base < 5, containers, transformers, monad-parallel, monad-coroutine,+                     process, readline, parsec >= 3.0 && < 4.0   GHC-options:       -threaded  Library-  Exposed-Modules:   Control.Concurrent.Coroutine, Control.Concurrent.SCC.Streams, Control.Concurrent.SCC.Types,+  Exposed-Modules:   Control.Concurrent.SCC.Streams, Control.Concurrent.SCC.Types,                      Control.Concurrent.SCC.Combinators, Control.Concurrent.SCC.Primitives,                      Control.Concurrent.SCC.XML,                      Control.Concurrent.Configuration, Control.Concurrent.SCC.Components-  Build-Depends:     base < 5, containers, transformers, parallel+  Build-Depends:     base < 5, containers, transformers, monad-parallel, monad-coroutine   GHC-prof-options:  -auto-all