diff --git a/Control/Concurrent/Coroutine.hs b/Control/Concurrent/Coroutine.hs
deleted file mode 100644
--- a/Control/Concurrent/Coroutine.hs
+++ /dev/null
@@ -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
- .
--}
-
--- | 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)
diff --git a/Control/Concurrent/SCC/Combinators.hs b/Control/Concurrent/SCC/Combinators.hs
--- a/Control/Concurrent/SCC/Combinators.hs
+++ b/Control/Concurrent/SCC/Combinators.hs
@@ -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
- .
--}
-
-{-# 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
+ .
+-}
+
+{-# 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
diff --git a/Control/Concurrent/SCC/Components.hs b/Control/Concurrent/SCC/Components.hs
--- a/Control/Concurrent/SCC/Components.hs
+++ b/Control/Concurrent/SCC/Components.hs
@@ -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
diff --git a/Control/Concurrent/SCC/Primitives.hs b/Control/Concurrent/SCC/Primitives.hs
--- a/Control/Concurrent/SCC/Primitives.hs
+++ b/Control/Concurrent/SCC/Primitives.hs
@@ -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
diff --git a/Control/Concurrent/SCC/Streams.hs b/Control/Concurrent/SCC/Streams.hs
--- a/Control/Concurrent/SCC/Streams.hs
+++ b/Control/Concurrent/SCC/Streams.hs
@@ -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
diff --git a/Control/Concurrent/SCC/Types.hs b/Control/Concurrent/SCC/Types.hs
--- a/Control/Concurrent/SCC/Types.hs
+++ b/Control/Concurrent/SCC/Types.hs
@@ -14,7 +14,7 @@
.
-}
--- | 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
diff --git a/Control/Concurrent/SCC/XML.hs b/Control/Concurrent/SCC/XML.hs
--- a/Control/Concurrent/SCC/XML.hs
+++ b/Control/Concurrent/SCC/XML.hs
@@ -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 ">= whenNull (put edge (Start ProcessingInstructionText)
- >> processingInstruction)
+ >> getContent
+ tag '?' = do put edge (Start ProcessingInstruction)
+ putList " put edge (Point (ErrorToken ("Expecting > return (" 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 " 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 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
+
diff --git a/Makefile b/Makefile
--- a/Makefile
+++ b/Makefile
@@ -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)
diff --git a/Shell.hs b/Shell.hs
--- a/Shell.hs
+++ b/Shell.hs
@@ -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)
diff --git a/Test.hs b/Test.hs
--- a/Test.hs
+++ b/Test.hs
@@ -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
diff --git a/scc.cabal b/scc.cabal
--- a/scc.cabal
+++ b/scc.cabal
@@ -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
.
@@ -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