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,1093 +1,1213 @@
{-
- Copyright 2008 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, FunctionalDependencies, FlexibleContexts, FlexibleInstances #-}
-
--- | The "Combinators" module defines combinators applicable to 'Transducer' and 'Splitter' components defined in the
--- "ComponentTypes" module.
-
-module Control.Concurrent.SCC.Combinators
- (-- * Consumer, producer, and transducer combinators
- consumeBy, prepend, append, substitute,
- PipeableComponentPair ((>->)), 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, (>&), (>|),
- -- ** 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.
- (&&), (||),
- -- * 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
- (...))
-where
-
-import Control.Concurrent.SCC.Foundation
-import Control.Concurrent.SCC.ComponentTypes
-
-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 Data.Maybe (isJust, isNothing, fromJust)
-import Data.Typeable (Typeable)
-import qualified Data.Foldable as Foldable
-import qualified Data.Sequence as Seq
-import Data.Sequence (Seq, (|>), (><), ViewL (EmptyL, (:<)))
-
-import Debug.Trace (trace)
-
-consumeBy :: forall m x y r. (Monad m, Typeable x) => Consumer m x r -> Transducer m x y
-consumeBy c = liftTransducer "consumeBy" (maxUsableThreads c) $
- \threads-> let c' = usingThreads threads c
- in (ComponentConfiguration [AnyComponent c'] (usedThreads c') (cost c'),
- \ 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 (>->) :: c1 -> c2 -> c3
-
-instance (ParallelizableMonad m, Typeable x)
- => PipeableComponentPair m x (Producer m x ()) (Consumer m x ()) (Performer m ())
- where p >-> c = liftPerformer ">->" (maxUsableThreads p `max` maxUsableThreads c) $
- \threads-> let (configuration, p', c', parallel) = optimalTwoParallelConfigurations threads p c
- performPipe = (if parallel then pipeP else pipe) (produce p') (consume c') >> return ()
- in (configuration, performPipe)
-
-instance (ParallelizableMonad m, Typeable x, Typeable y)
- => PipeableComponentPair m y (Transducer m x y) (Consumer m y r) (Consumer m x r)
- where t >-> c = liftConsumer ">->" (maxUsableThreads t `max` maxUsableThreads c) $
- \threads-> let (configuration, t', c', parallel) = optimalTwoParallelConfigurations threads t c
- consumePipe source = liftM snd $ (if parallel then pipeP else pipe)
- (transduce t' source)
- (consume c')
- in (configuration, consumePipe)
-
-instance (ParallelizableMonad m, Typeable x, Typeable y)
- => PipeableComponentPair m x (Producer m x r) (Transducer m x y) (Producer m y r)
- where p >-> t = liftProducer ">->" (maxUsableThreads t `max` maxUsableThreads p) $
- \threads-> let (configuration, p', t', parallel) = optimalTwoParallelConfigurations threads p t
- producePipe sink = liftM fst $ (if parallel then pipeP else pipe)
- (produce p')
- (\source-> transduce t' source sink)
- in (configuration, producePipe)
-
-instance ParallelizableMonad m => PipeableComponentPair m y (Transducer m x y) (Transducer m y z) (Transducer m x z)
- where t1 >-> t2 = liftTransducer ">->" (maxUsableThreads t1 + maxUsableThreads t2) $
- \threads-> let (configuration, t1', t2', parallel) = optimalTwoParallelConfigurations threads t1 t2
- transducePipe source sink = liftM fst $ (if parallel then pipeP else pipe)
- (transduce t1' source)
- (\source-> transduce t2' source sink)
- in (configuration, transducePipe)
-
-class Component c => 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 :: c1 -> c2 -> c3
- sequence :: c1 -> c2 -> c3
- join = sequence
-
-instance forall m x any r1 r2. (Monad m, Typeable x)
- => 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 = liftProducer "sequence" (maxUsableThreads p1 `max` maxUsableThreads p2) $
- \threads-> let (configuration, p1', p2') = optimalTwoSequentialConfigurations threads p1 p2
- produceJoin sink = produce p1' sink >> produce p2' sink
- in (configuration, produceJoin)
-
-instance forall m x any. (ParallelizableMonad m, Typeable x)
- => JoinableComponentPair (ConsumerType ()) (ConsumerType ()) (ConsumerType ()) m [x] () (Consumer m x ()) (Consumer m x ()) (Consumer m x ())
- where join c1 c2 = liftConsumer "join" (maxUsableThreads c1 + maxUsableThreads c2) $
- \threads-> let (configuration, c1', c2', parallel) = optimalTwoParallelConfigurations threads c1 c2
- consumeJoin source = do (if parallel then pipeP else pipe)
- (\sink1-> pipe (tee source sink1) (consume c2'))
- (consume c1')
- return ()
- in (configuration, consumeJoin)
- sequence c1 c2 = liftConsumer "sequence" (maxUsableThreads c1 `max` maxUsableThreads c2) $
- \threads-> let (configuration, c1', c2') = optimalTwoSequentialConfigurations threads c1 c2
- consumeJoin source = pipe
- (\buffer-> pipe (tee source buffer) (consume c1'))
- getList
- >>= \(_, list)-> pipe (putList list) (consume c2')
- >> return ()
- in (configuration, consumeJoin)
-
-instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)
- => JoinableComponentPair TransducerType TransducerType TransducerType m [x] [y] (Transducer m x y) (Transducer m x y) (Transducer m x y)
- where join t1 t2 = liftTransducer "join" (maxUsableThreads t1 + maxUsableThreads t2) $
- \threads-> let (configuration, t1', t2', parallel) = optimalTwoParallelConfigurations threads t1 t2
- transduce' source sink = pipe
- (\buffer-> (if parallel then pipeP else pipe)
- (\sink1-> pipe
- (\sink2-> tee source sink1 sink2)
- (\src-> transduce t2' src buffer))
- (\source-> transduce t1' source sink))
- getList
- >>= \(_, list)-> putList list sink
- >> getList source
- in (configuration, transduce')
- sequence t1 t2 = liftTransducer "sequence" (maxUsableThreads t1 `max` maxUsableThreads t2) $
- \threads-> let (configuration, t1', t2') = optimalTwoSequentialConfigurations threads t1 t2
- transduce' source sink = pipe
- (\buffer-> pipe
- (tee source buffer)
- (\source-> transduce t1 source sink))
- getList
- >>= \((extra, _), list)-> pipe
- (putList list)
- (\source-> transduce t2 source sink)
- >> return extra
- in (configuration, transduce')
-
-
-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 p1 p2 = liftPerformer "join" (maxUsableThreads p1 + maxUsableThreads p2) $
- \threads-> let (configuration, p1', p2', parallel) = optimalTwoParallelConfigurations threads p1 p2
- in (configuration, if parallel then liftM snd $ perform p1' `parallelize` perform p2'
- else perform p1' >> perform p2')
- sequence p1 p2 = liftPerformer "sequence" (maxUsableThreads p1 `max` maxUsableThreads p2) $
- \threads-> let (configuration, p1', p2') = optimalTwoSequentialConfigurations threads p1 p2
- in (configuration, perform p1' >> perform p2')
-
-instance forall m x r1 r2. (ParallelizableMonad m, Typeable x)
- => JoinableComponentPair (PerformerType r1) (ProducerType r2) (ProducerType r2) m () [x] (Performer m r1) (Producer m x r2) (Producer m x r2)
- where join pe pr = liftProducer "join" (maxUsableThreads pe + maxUsableThreads pr) $
- \threads-> let (configuration, pe', pr', parallel) = optimalTwoParallelConfigurations threads pe pr
- produceJoin sink = if parallel then liftM snd (perform pe' `parallelize` produce pr' sink)
- else perform pe' >> produce pr' sink
- in (configuration, produceJoin)
- sequence pe pr = liftProducer "sequence" (maxUsableThreads pe `max` maxUsableThreads pr) $
- \threads-> let (configuration, pe', pr') = optimalTwoSequentialConfigurations threads pe pr
- produceJoin sink = perform pe' >> produce pr' sink
- in (configuration, produceJoin)
-
-instance forall m x r1 r2. (ParallelizableMonad m, Typeable x)
- => JoinableComponentPair (ProducerType r1) (PerformerType r2) (ProducerType r2) m () [x] (Producer m x r1) (Performer m r2) (Producer m x r2)
- where join pr pe = liftProducer "join" (maxUsableThreads pr + maxUsableThreads pe) $
- \threads-> let (configuration, pr', pe', parallel) = optimalTwoParallelConfigurations threads pr pe
- produceJoin sink = if parallel then liftM snd (produce pr' sink `parallelize` perform pe')
- else produce pr' sink >> perform pe'
- in (configuration, produceJoin)
- sequence pr pe = liftProducer "sequence" (maxUsableThreads pr `max` maxUsableThreads pe) $
- \threads-> let (configuration, pr', pe') = optimalTwoSequentialConfigurations threads pr pe
- produceJoin sink = produce pr' sink >> perform pe'
- in (configuration, produceJoin)
-
-instance forall m x r1 r2. (ParallelizableMonad m, Typeable x)
- => JoinableComponentPair (PerformerType r1) (ConsumerType r2) (ConsumerType r2) m [x] () (Performer m r1) (Consumer m x r2) (Consumer m x r2)
- where join p c = liftConsumer "join" (maxUsableThreads p + maxUsableThreads c) $
- \threads-> let (configuration, p', c', parallel) = optimalTwoParallelConfigurations threads p c
- consumeJoin source = if parallel then liftM snd (perform p' `parallelize` consume c' source)
- else perform p' >> consume c' source
- in (configuration, consumeJoin)
- sequence p c = liftConsumer "sequence" (maxUsableThreads p `max` maxUsableThreads c) $
- \threads-> let (configuration, p', c') = optimalTwoSequentialConfigurations threads p c
- consumeJoin source = perform p' >> consume c' source
- in (configuration, consumeJoin)
-
-instance forall m x r1 r2. (ParallelizableMonad m, Typeable x)
- => JoinableComponentPair (ConsumerType r1) (PerformerType r2) (ConsumerType r2) m [x] () (Consumer m x r1) (Performer m r2) (Consumer m x r2)
- where join c p = liftConsumer "join" (maxUsableThreads c + maxUsableThreads p) $
- \threads-> let (configuration, c', p', parallel) = optimalTwoParallelConfigurations threads c p
- consumeJoin source = if parallel then liftM snd (consume c' source `parallelize` perform p')
- else consume c' source >> perform p'
- in (configuration, consumeJoin)
- sequence c p = liftConsumer "sequence" (maxUsableThreads c `max` maxUsableThreads p) $
- \threads-> let (configuration, c', p') = optimalTwoSequentialConfigurations threads c p
- consumeJoin source = consume c' source >> perform p'
- in (configuration, consumeJoin)
-
-instance forall m x y r. (ParallelizableMonad m, Typeable x, Typeable y)
- => JoinableComponentPair (PerformerType r) TransducerType TransducerType m [x] [y] (Performer m r) (Transducer m x y) (Transducer m x y)
- where join p t = liftTransducer "join" (maxUsableThreads p + maxUsableThreads t) $
- \threads-> let (configuration, p', t', parallel) = optimalTwoParallelConfigurations threads p t
- join' source sink = if parallel then liftM snd (perform p'
- `parallelize` transduce t' source sink)
- else perform p' >> transduce t' source sink
- in (configuration, join')
- sequence p t = liftTransducer "sequence" (maxUsableThreads p `max` maxUsableThreads t) $
- \threads-> let (configuration, p', t') = optimalTwoSequentialConfigurations threads p t
- join' source sink = perform p' >> transduce t' source sink
- in (configuration, join')
-
-instance forall m x y r. (ParallelizableMonad m, Typeable x, Typeable y)
- => JoinableComponentPair TransducerType (PerformerType r) TransducerType m [x] [y] (Transducer m x y) (Performer m r) (Transducer m x y)
- where join t p = liftTransducer "join" (maxUsableThreads t + maxUsableThreads p) $
- \threads-> let (configuration, t', p', parallel) = optimalTwoParallelConfigurations threads t p
- join' source sink = if parallel then liftM fst (transduce t' source sink
- `parallelize` perform p')
- else do result <- transduce t' source sink
- perform p'
- return result
- in (configuration, join')
- sequence t p = liftTransducer "sequence" (maxUsableThreads t `max` maxUsableThreads p) $
- \threads-> let (configuration, t', p') = optimalTwoSequentialConfigurations threads t p
- join' source sink = do result <- transduce t' source sink
- perform p'
- return result
- in (configuration, join')
-
-instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)
- => JoinableComponentPair (ProducerType ()) TransducerType TransducerType m [x] [y] (Producer m y ()) (Transducer m x y) (Transducer m x y)
- where join p t = liftTransducer "join" (maxUsableThreads p + maxUsableThreads t) $
- \threads-> let (configuration, p', t', parallel) = optimalTwoParallelConfigurations threads p t
- join' source sink = if parallel
- then do ((_, rest), out) <- pipe
- (\buffer-> produce p' sink `parallelize`
- transduce t' source buffer)
- getList
- putList out sink
- return rest
- else produce p' sink >> transduce t' source sink
- in (configuration, join')
- sequence p t = liftTransducer "sequence" (maxUsableThreads p `max` maxUsableThreads t) $
- \threads-> let (configuration, p', t') = optimalTwoSequentialConfigurations threads p t
- join' source sink = produce p' sink >> transduce t' source sink
- in (configuration, join')
-
-instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)
- => JoinableComponentPair TransducerType (ProducerType ()) TransducerType m [x] [y] (Transducer m x y) (Producer m y ()) (Transducer m x y)
- where join t p = liftTransducer "join" (maxUsableThreads t `max` maxUsableThreads p) $
- \threads-> let (configuration, t', p', parallel) = optimalTwoParallelConfigurations threads t p
- join' source sink = if parallel
- then do ((rest, ()), out) <- pipe
- (\buffer-> transduce t' source sink
- `parallelize` produce p' buffer)
- getList
- putList out sink
- return rest
- else do result <- transduce t' source sink
- produce p' sink
- return result
- in (configuration, join')
- sequence t p = liftTransducer "sequence" (maxUsableThreads t `max` maxUsableThreads p) $
- \threads-> let (configuration, t', p') = optimalTwoSequentialConfigurations threads t p
- join' source sink = do result <- transduce t' source sink
- produce p' sink
- return result
- in (configuration, join')
-
-instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)
- => JoinableComponentPair (ConsumerType ()) TransducerType TransducerType m [x] [y] (Consumer m x ()) (Transducer m x y) (Transducer m x y)
- where join c t = liftTransducer "join" (maxUsableThreads c + maxUsableThreads t) $
- \threads-> let (configuration, c', t', parallel) = optimalTwoParallelConfigurations threads c t
- join' source sink = liftM (snd . fst) $
- (if parallel then pipeP else pipe)
- (\sink1-> pipe
- (tee source sink1)
- (\source-> transduce t' source sink))
- (consume c')
- in (configuration, join')
- sequence c t = liftTransducer "sequence" (maxUsableThreads c `max` maxUsableThreads t) $
- \threads-> let (configuration, c', t') = optimalTwoSequentialConfigurations threads c t
- sequence' source sink = pipe
- (\buffer-> pipe
- (tee source buffer)
- (consume c'))
- getList
- >>= \((rest, _), list)-> pipe
- (putList list)
- (\source-> transduce t' source sink)
- >> return rest
- in (configuration, sequence')
-
-instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)
- => JoinableComponentPair TransducerType (ConsumerType ()) TransducerType m [x] [y] (Transducer m x y) (Consumer m x ()) (Transducer m x y)
- where join t c = join c t
- sequence t c = liftTransducer "sequence" (maxUsableThreads t `max` maxUsableThreads c) $
- \threads-> let (configuration, t', c') = optimalTwoSequentialConfigurations threads t c
- sequence' source sink = pipe
- (\buffer-> pipe
- (tee source buffer)
- (\source-> transduce t' source sink))
- getList
- >>= \((rest, _), list)-> pipe
- (putList list)
- (consume c')
- >> return rest
- in (configuration, sequence')
-
-instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)
- => JoinableComponentPair (ProducerType ()) (ConsumerType ()) TransducerType m [x] [y] (Producer m y ()) (Consumer m x ()) (Transducer m x y)
- where join p c = liftTransducer "sequence" (maxUsableThreads p + maxUsableThreads c) $
- \threads-> let (configuration, p', c', parallel) = optimalTwoParallelConfigurations threads p c
- join' source sink = if parallel then produce p' sink >> consume c' source >> return []
- else parallelize (produce p' sink) (consume c' source) >> return []
- in (configuration, join')
- sequence p c = liftTransducer "sequence" (maxUsableThreads p `max` maxUsableThreads c) $
- \threads-> let (configuration, p', c') = optimalTwoSequentialConfigurations threads p c
- join' source sink = produce p' sink >> consume c' source >> return []
- in (configuration, join')
-
-instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)
- => JoinableComponentPair (ConsumerType ()) (ProducerType ()) TransducerType m [x] [y] (Consumer m x ()) (Producer m y ()) (Transducer m x y)
- where join c p = join p c
- sequence c p = liftTransducer "sequence" (maxUsableThreads c `max` maxUsableThreads p) $
- \threads-> let (configuration, c', p') = optimalTwoSequentialConfigurations threads c p
- join' source sink = consume c' source >> produce p' sink >> return []
- in (configuration, join')
-
--- | 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, Typeable x) => Producer m x r -> Transducer m x x
-prepend prefix = liftTransducer "prepend" (maxUsableThreads prefix) $
- \threads-> let prefix' = usingThreads threads prefix
- prepend' source sink = produce prefix' sink >> pour source sink >> return []
- in (ComponentConfiguration [AnyComponent prefix] threads (cost prefix'), prepend')
-
--- | 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, Typeable x) => Producer m x r -> Transducer m x x
-append suffix = liftTransducer "append" (maxUsableThreads suffix) $
- \threads-> let suffix' = usingThreads threads suffix
- append' source sink = pour source sink >> produce suffix' sink >> return []
- in (ComponentConfiguration [AnyComponent suffix] threads (cost suffix'), append')
-
--- | 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, Typeable x, Typeable y) => Producer m y r -> Transducer m x y
-substitute feed = liftTransducer "substitute" (maxUsableThreads feed) $
- \threads-> let feed' = usingThreads threads feed
- substitute' source sink = consumeAndSuppress source >> produce feed' sink >> return []
- in (ComponentConfiguration [AnyComponent feed] threads (cost feed'), substitute')
-
--- | 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 :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x
-snot splitter = liftSectionSplitter "not" (maxUsableThreads splitter) $
- \threads-> let splitter' = usingThreads threads splitter
- not source true false = splitSections splitter source false true
- in (ComponentConfiguration [AnyComponent splitter'] threads (cost splitter'), not)
-
--- | 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.
-(>&) :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x -> Splitter m x
-s1 >& s2 = liftSimpleSplitter ">&" (maxUsableThreads s1 + maxUsableThreads s2) $
- \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2
- s source true false = liftM fst $
- (if parallel then pipeP else pipe)
- (\true-> split s1 source true false)
- (\source-> split s2 source true false)
- in (configuration, s)
-
--- | A '>|' combinator's input value can reach its /false/ sink only by going through both argument splitters' /false/
--- sinks.
-(>|) :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x -> Splitter m x
-s1 >| s2 = liftSimpleSplitter ">|" (maxUsableThreads s1 + maxUsableThreads s2) $
- \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2
- s source true false = liftM fst $
- (if parallel then pipeP else pipe)
- (split s1 source true)
- (\source-> split s2 source true false)
- in (configuration, s)
-
--- | Combinator '&&' is a pairwise logical conjunction of two splitters run in parallel on the same input.
-(&&) :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x -> Splitter m x
-(&&) = zipSplittersWith (Prelude.&&)
-
--- | Combinator '||' is a pairwise logical disjunction of two splitters run in parallel on the same input.
-(||) :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x -> Splitter m x
-(||) = zipSplittersWith (Prelude.||)
-
-ifs :: (ParallelizableMonad m, Typeable x, BranchComponent cc m x [x]) => Splitter m x -> cc -> cc -> cc
-ifs s = combineBranches "if" (cost s) (\ parallel c1 c2 -> \source-> liftM fst3 $ splitConsumer "ifs" parallel s c1 c2 source)
-
-wherever :: (ParallelizableMonad m, Typeable x) => Transducer m x x -> Splitter m x -> Transducer m x x
-wherever t s = liftTransducer "wherever" (maxUsableThreads s + maxUsableThreads t) $
- \threads-> let (configuration, s', t', parallel) = optimalTwoParallelConfigurations threads s t
- wherever' source sink = liftM fst3 $ splitConsumer "wherever" parallel s
- (\source-> transduce t source sink)
- (\source-> pour source sink)
- source
- in (configuration, wherever')
-
-unless :: (ParallelizableMonad m, Typeable x) => Transducer m x x -> Splitter m x -> Transducer m x x
-unless t s = liftTransducer "unless" (maxUsableThreads s + maxUsableThreads t) $
- \threads-> let (configuration, s', t', parallel) = optimalTwoParallelConfigurations threads s t
- unless' source sink = liftM fst3 $ splitConsumer "unless" parallel s
- (\source-> pour source sink)
- (\source-> transduce t source sink)
- source
- in (configuration, unless')
-
-select :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Transducer m x x
-select s = liftTransducer "select" (maxUsableThreads s) $
- \threads-> let s' = usingThreads threads s
- transduce' source sink = liftM fst3 $ splitConsumer "select" False s'
- (\source-> pour source sink)
- consumeAndSuppress
- source
- in (ComponentConfiguration [AnyComponent s'] threads (cost s' + 1), transduce')
-
--- | 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 :: (ParallelizableMonad m, Typeable x) => Transducer m x x -> Splitter m x -> Transducer m x x
-while t s = liftTransducer "while" (maxUsableThreads t + maxUsableThreads s) $
- \threads-> let (configuration, s', while'', parallel) = optimalTwoParallelConfigurations threads s while'
- transduce' source sink = liftM fst3 $ splitConsumer "while" parallel s'
- (\source-> transduce while' source sink)
- (\source-> pour source sink)
- source
- while' = t >-> while t s
- in (configuration, transduce')
-
--- | 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,
--- a value would either not loop at all or it would loop forever.
-nestedIn :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x -> Splitter m x
-nestedIn s1 s2 = liftSimpleSplitter "nestedIn" (maxUsableThreads s1 + maxUsableThreads s2) $
- \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2
- s source true false = liftM fst $
- (if parallel then pipeP else pipe)
- (\false-> split s1' source true false)
- (\source-> pipe (\true-> split s2' source true false)
- (\source-> split (nestedIn s1' s2') source true false))
- in (configuration,s)
-
--- | 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 :: (ParallelizableMonad m, Typeable x, BranchComponent cc m x [x]) => Splitter m x -> cc -> cc -> cc
-foreach s = combineBranches "foreach" (cost s)
- (\ parallel c1 c2 source-> liftM fst $ (if parallel then pipeP else pipe)
- (transduce (splitterToMarker s) source)
- (\source-> groupMarks source (\b-> if b then c1 else c2)))
-
--- | 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 :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x -> Splitter m x
-having s1 s2 = liftSectionSplitter "having" (maxUsableThreads s1 + maxUsableThreads s2) $
- \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2
- s source true false = liftM fst $
- (if parallel then pipeP else pipe)
- (transduce (splitterToMarker s1') source)
- (\source-> groupMarks source (\b chunk-> if b then test chunk
- else pourMaybe chunk false))
- where test chunk = pipe (\sink1-> pipe (tee chunk sink1) getList)
- (\chunk-> pipe (\sink-> suppressProducer (split s2' chunk sink)) getList)
- >>= \(([], chunk), (_, truePart))-> let chunk' = if null chunk
- then [Nothing]
- else map Just chunk
- in (if null truePart
- then putList chunk' false
- else putList chunk' true)
- >> return ()
- in (configuration, s)
-
--- | 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 :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x -> Splitter m x
-havingOnly s1 s2 = liftSectionSplitter "havingOnly" (maxUsableThreads s1 + maxUsableThreads s2) $
- \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2
- s source true false = liftM fst $
- (if parallel then pipeP else pipe)
- (transduce (splitterToMarker s1') source)
- (\source-> groupMarks source (\b chunk-> if b then test chunk
- else pourMaybe chunk false))
- where test chunk = pipe (\sink1-> pipe (tee chunk sink1) getList)
- (\chunk-> pipe (\sink-> suppressProducer
- (\suppress-> split s2' chunk suppress sink))
- getList)
- >>= \(([], chunk), (_, falsePart))-> let chunk' = if null chunk
- then [Nothing]
- else map Just chunk
- in (if null falsePart
- then putList chunk' true
- else putList chunk' false)
- >> return ()
- in (configuration, s)
-
--- | 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 :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x
-first splitter = liftSectionSplitter "first" (maxUsableThreads splitter) $
- \threads-> let splitter' = usingThreads threads splitter
- configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)
- s source true false = liftM (\(x, y)-> y ++ x) $
- pipeD "first" (transduce (splitterToMarker splitter') source)
- (\source-> let get1 (x, False) = p false x get1
- get1 (x, True) = p true x get2
- get2 (x, True) = p true x get2
- get2 (x, False) = p false x get3
- get3 (x, _) = p false x get3
- p sink x succeed = put sink x
- >>= cond (get source
- >>= maybe (return []) succeed)
- (return $ maybe [] (:[]) x)
- in get source >>= maybe (return []) get1)
- in (configuration, s)
-
--- | 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 'last' and 'lastAndAfter' combinators is in where they direct the
--- /false/ portion of the input preceding the first /true/ part.
-uptoFirst :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x
-uptoFirst splitter = liftSectionSplitter "uptoFirst" (maxUsableThreads splitter) $
- \threads-> let splitter' = usingThreads threads splitter
- configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)
- s source true false = liftM (\(x, y)-> concatMap (maybe [] (:[])) y ++ x) $
- pipeD "uptoFirst" (transduce (splitterToMarker splitter') source)
- (\source-> let get1 q (x, False) = let q' = q |> x
- in get source
- >>= maybe
- (putQueue q' false)
- (get1 q')
- get1 q p@(x, True) = putQueue q true
- >>= whenNull (get2 p)
- get2 (x, True) = p true x get2
- get2 (x, False) = p false x get3
- get3 (x, _) = p false x get3
- p sink x succeed = put sink x
- >>= cond (get source
- >>= maybe (return []) succeed)
- (return [x])
- in get source >>= maybe (return []) (get1 Seq.empty))
- in (configuration, s)
-
--- | 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 :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x
-last splitter = liftSectionSplitter "last" (maxUsableThreads splitter) $
- \threads-> let splitter' = usingThreads threads splitter
- configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)
- s source true false = liftM (\(x, y)-> concatMap (maybe [] (:[])) y ++ x) $
- pipeD "last" (transduce (splitterToMarker splitter') source)
- (\source-> let get1 (x, False) = put false x
- >>= cond (get source
- >>= maybe (return []) get1)
- (return [x])
- get1 p@(x, True) = get2 Seq.empty p
- get2 q (x, True) = let q' = q |> x
- in get source
- >>= maybe
- (putQueue q' true)
- (get2 q')
- get2 q p@(x, False) = get3 q Seq.empty p
- get3 qt qf (x, False) = let qf' = qf |> x
- in get source
- >>= maybe
- (putQueue qt true
- >> putQueue qf' false)
- (get3 qt qf')
- get3 qt qf p@(x, True) = do rest1 <- putQueue qt false
- rest2 <- putQueue qf false
- if null rest1 Prelude.&& null rest2
- then get2 Seq.empty p
- else return (rest1 ++ rest2)
- p succeed = get source >>= maybe (return []) succeed
- in p get1)
- in (configuration, s)
-
--- | 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 :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x
-lastAndAfter splitter = liftSectionSplitter "lastAndAfter" (maxUsableThreads splitter) $
- \threads-> let splitter' = usingThreads threads splitter
- configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)
- s source true false = liftM (\(x, y)-> concatMap (maybe [] (:[])) y ++ x) $
- pipeD "lastAndAfter" (transduce (splitterToMarker splitter') source)
- (\source-> let get1 (x, False) = put false x
- >>= cond (p get1) (return [x])
- get1 p@(x, True) = get2 Seq.empty p
- get2 q (x, True) = let q' = q |> x
- in get source
- >>= maybe
- (putQueue q' true)
- (get2 q')
- get2 q p@(x, False) = get3 q p
- get3 q (x, False) = let q' = q |> x
- in get source
- >>= maybe
- (putQueue q' true)
- (get3 q')
- get3 q p@(x, True) = putQueue q false
- >>= whenNull (get1 p)
- p succeed = get source >>= maybe (return []) succeed
- in p get1)
- in (configuration, s)
-
--- | 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 :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x
-prefix splitter = liftSectionSplitter "prefix" (maxUsableThreads splitter) $
- \threads-> let splitter' = usingThreads threads splitter
- configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)
- s source true false = liftM (\(x, y)-> y ++ x) $
- pipeD "prefix" (transduce (splitterToMarker splitter') source)
- (\source-> let get1 (x, False) = p false x get2
- get1 (x, True) = p true x get1
- get2 (x, _) = p false x get2
- p sink x succeed = put sink x
- >>= cond (get source
- >>= maybe (return []) succeed)
- (return $ maybe [] (:[]) x)
- in get source >>= maybe (return []) get1)
- in (configuration, s)
-
--- | 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 :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x
-suffix splitter = liftSectionSplitter "suffix" (maxUsableThreads splitter) $
- \threads-> let splitter' = usingThreads threads splitter
- configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)
- s source true false = liftM (\(x, y)-> concatMap (maybe [] (:[])) y ++ x) $
- pipeD "suffix" (transduce (splitterToMarker splitter') source)
- (\source-> let get1 (x, False) = put false x >>= cond (p get1) (return [x])
- get1 (x, True) = get2 (Seq.singleton x)
- get2 q = get source
- >>= maybe (putQueue q true) (get3 q)
- get3 q (x, True) = get2 (q |> x)
- get3 q p@(x, False) = putQueue q false >>= whenNull (get1 p)
- p succeed = get source >>= maybe (return []) succeed
- in p get1)
- in (configuration, s)
-
--- | The 'even' combinator takes every input section that its argument splitters 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 :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x
-even splitter = liftSectionSplitter "even" (maxUsableThreads splitter) $
- \threads-> let splitter' = usingThreads threads splitter
- configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)
- s source true false = liftM (\(x, y)-> concatMap (maybe [] (:[])) y ++ x) $
- pipeD "even"
- (transduce (splitterToMarker splitter') source)
- (\source-> let get1 (x, False) = put false x
- >>= cond (next get1) (return [x])
- get1 p@(x, True) = get2 p
- get2 (x, True) = put false x
- >>= cond (next get2) (return [x])
- get2 p@(x, False) = get3 p
- get3 (x, False) = put false x
- >>= cond (next get3) (return [x])
- get3 p@(x, True) = get4 p
- get4 (x, True) = put true x
- >>= cond (next get4) (return [x])
- get4 p@(x, False) = get1 p
- next g = get source >>= maybe (return []) g
- in next get1)
- in (configuration, s)
-
--- | 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 :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x
-startOf splitter = liftSectionSplitter "startOf" (maxUsableThreads splitter) $
- \threads-> let splitter' = usingThreads threads splitter
- configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)
- s source true false = liftM (\(x, y)-> concatMap (maybe [] (:[])) y ++ x) $
- pipeD "startOf"
- (transduce (splitterToMarker splitter') source)
- (\source-> let get1 (x, False) = put false x
- >>= cond (next get1) (return [x])
- get1 p@(x, True) = put true Nothing >> get2 p
- get2 (x, True) = put false x
- >>= cond (next get2) (return [x])
- get2 p@(x, False) = get1 p
- next g = get source >>= maybe (return []) g
- in next get1)
- in (configuration, s)
-
--- | 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 :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x
-endOf splitter = liftSectionSplitter "endOf" (maxUsableThreads splitter) $
- \threads-> let splitter' = usingThreads threads splitter
- configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)
- s source true false = liftM (\(x, y)-> concatMap (maybe [] (:[])) y ++ x) $
- pipeD "endOf"
- (transduce (splitterToMarker splitter') source)
- (\source-> let get1 (x, False) = put false x
- >>= cond (next get1) (return [x])
- get1 p@(x, True) = get2 p
- get2 (x, True) = put false x
- >>= cond (next get2) (return [x])
- get2 p@(x, False) = put true Nothing >> get1 p
- next g = get source >>= maybe (return []) g
- in next get1)
- in (configuration, s)
-
--- | 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. (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x -> Splitter m x
-followedBy s1 s2 = liftSectionSplitter "followedBy" (maxUsableThreads s1 + maxUsableThreads s2) $
- \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2
- in (configuration, followedBy' parallel s1' s2')
- where followedBy' parallel s1 s2 source true false
- = liftM (\(x, y)-> concatMap (maybe [] (:[])) y ++ x) $
- (if parallel then pipeP else pipe)
- (transduce (splitterToMarker s1) source)
- (\source-> let get0 q = case Seq.viewl q
- of Seq.EmptyL -> get source >>= maybe (return []) get1
- (x, False) :< rest -> put false x
- >>= cond (get0 rest)
- (return $ Foldable.toList $ Seq.viewl $ fmap fst q)
- (x, True) :< rest -> get2 Seq.empty q
- get1 (x, False) = put false x
- >>= cond (get source >>= maybe (return []) get1)
- (return [x])
- get1 p@(x, True) = get2 Seq.empty (Seq.singleton p)
- get2 q q' = case Seq.viewl q'
- of Seq.EmptyL -> get source
- >>= maybe (testEnd q) (get2 q . Seq.singleton)
- (x, True) :< rest -> get2 (q |> x) rest
- (x, False) :< rest -> do ((q1, q2), n) <- pipeD "followedBy tail"
- (get3 Seq.empty q') (test q)
- case n of Nothing -> putQueue q false
- >>= whenNull (get0 (q1 >< q2))
- Just n -> do put false Nothing
- get0 (dropJust n q1 >< q2)
- get3 q1 q2 sink = canPut sink
- >>= cond (case Seq.viewl q2
- of Seq.EmptyL -> get source
- >>= maybe (return (q1, q2))
- (\p-> maybe (return True) (put sink) (fst p)
- >> get3 (q1 |> p) q2 sink)
- p :< rest -> maybe (return True) (put sink) (fst p)
- >> get3 (q1 |> p) rest sink)
- (return (q1, q2))
- testEnd q = do ((), n) <- pipeD "testEnd" (const $ return ()) (test q)
- case n of Nothing -> putQueue q false
- _ -> return []
- test q source = liftM snd $
- pipeD "follower"
- (transduce (splitterToMarker s2) source)
- (\source-> let get4 (_, False) = return Nothing
- get4 p@(_, True) = putQueue q true >> get5 0 p
- get5 n (x, False) = return (Just n)
- get5 n (Nothing, True) = get6 n
- get5 n (x, True) = put true x >> get6 (succ n)
- get6 n = get source
- >>= maybe
- (return $ Just n)
- (get5 n)
- in get source >>= maybe (return Nothing) get4)
- dropJust 0 q = q
- dropJust n q = case Seq.viewl q of (Nothing, _) :< rest -> dropJust n rest
- (Just _, _) :< rest -> dropJust (pred n) rest
- in get0 Seq.empty)
-
--- | Combinator '...' tracks the running balance of difference between the numbers of preceding inputs 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. (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x -> Splitter m x
-s1 ... s2 = liftSectionSplitter "..." (maxUsableThreads s1 + maxUsableThreads s2) $
- \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2
- s source true false = liftM (\(x, y)-> concatMap (maybe [] (:[])) y ++ x) $
- (if parallel then pipeP else pipe)
- (transduce (splittersToPairMarker 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) (Just x)
- state n (Left (x, False, True)) = pass' (pred n) (Just x)
- state n (Left (x, True, True)) = pass' n (Just x)
- state n (Left (x, False, False)) = pass n (Just x)
- state n (Right (Left True)) = pass (succ n) Nothing
- state n (Right (Right True)) = pass (pred n) Nothing
- state n (Right _) = next n
- in next 0)
- in (configuration, s)
-
--- Helper functions
-
-type Marker m x = Transducer m x (Maybe x, Bool)
-
-splitterToMarker :: forall m x. (ParallelizableMonad m, Typeable x) => Splitter m x -> Marker m x
-splitterToMarker s = liftTransducer "splitterToMarker" (maxUsableThreads s) $
- \threads-> let s' = usingThreads threads s
- t source sink = liftM (\((x, y), z)-> z ++ y ++ x) $
- pipeD "splitterToMarker true"
- (\trueSink-> pipeD "splitterToMarker false"
- (splitSections s' source trueSink)
- (mark False))
- (mark True)
- where mark b source = canPut sink
- >>= cond (get source
- >>= maybe (return [])
- (\x-> put sink (x, b)
- >>= cond
- (mark b source)
- (return $ maybe [] (: []) x)))
- (return [])
- in (ComponentConfiguration [AnyComponent s'] threads (cost s' + 1), t)
-
-
-splittersToPairMarker :: forall m x. (ParallelizableMonad m, Typeable x)
- => Splitter m x -> Splitter m x -> Transducer m x (Either (x, Bool, Bool) (Either Bool Bool))
-splittersToPairMarker s1 s2
- = liftTransducer "splittersToPairMarker" (maxUsableThreads s1 + maxUsableThreads s2) $
- \threads-> let (configuration, s1', s2', parallelize) = optimalTwoParallelConfigurations threads s1 s2
- t source sink = liftM (\((((((([], l1), l2), l3), l4), l5), l6), l7)-> l7 ++ l6 ++ l5 ++ l4 ++ l3 ++ l2 ++ l1) $
- pipeD "splittersToPairMarker synchronize"
- (\sync->
- pipeD "splittersToPairMarker true1"
- (\true1->
- pipeD "splittersToPairMarker false1"
- (\false1->
- pipeD "splittersToPairMarker true2"
- (\true2->
- pipeD "splittersToPairMarker false2"
- (\false2->
- pipeD "splittersToPairMarker sink1"
- (\sink1->
- (if parallelize then pipeP else pipe)
- (\sink2-> tee source sink1 sink2)
- (\source2-> splitSections s2 source2 true2 false2))
- (\source1-> splitSections s1 source1 true1 false1))
- (mark sync False False))
- (mark sync False True))
- (mark sync True False))
- (mark sync True True))
- (synchronizeMarks Nothing sink)
- synchronizeMarks :: Maybe (Seq (Maybe x, Bool), Bool)
- -> Sink c (Either (x, Bool, Bool) (Either Bool Bool)) -> Source c (Maybe x, Bool, Bool)
- -> Pipe c m [x]
- synchronizeMarks state sink source = get source
- >>= maybe
- (assert (isNothing state) (return []))
- (handleMark state sink source)
- handleMark :: Maybe (Seq (Maybe x, Bool), Bool)
- -> Sink c (Either (x, Bool, Bool) (Either Bool Bool)) -> Source c (Maybe x, Bool, Bool)
- -> (Maybe x, Bool, Bool) -> Pipe c m [x]
- handleMark Nothing sink source (x, pos, b)
- = case x of Nothing -> put sink (Right $ if pos then Left b else Right b)
- >> synchronizeMarks Nothing sink source
- _ -> synchronizeMarks (Just (Seq.singleton (x, b), pos)) sink source
- handleMark state@(Just (q, pos')) sink source mark@(x, pos, b)
- | pos == pos' = synchronizeMarks (Just (q |> (x, b), pos')) sink source
- | isNothing x = put sink (Right $ if pos then Left b else Right b)
- >> synchronizeMarks state sink source
- | otherwise = case Seq.viewl q
- of Seq.EmptyL -> synchronizeMarks (Just (Seq.singleton (x, b), pos)) sink source
- (Nothing, b') :< rest -> put sink (Right $ if pos then Right b' else Left b')
- >>= cond
- (handleMark
- (if Seq.null rest then Nothing else Just (rest, pos'))
- sink
- source
- mark)
- (returnQueuedList q)
- (Just y, b') :< rest -> put sink (Left $ if pos then (y, b, b') else (y, b', b))
- >>= cond
- (synchronizeMarks
- (if Seq.null rest then Nothing else Just (rest, pos'))
- sink
- source)
- (returnQueuedList q)
- returnQueuedList q = return $ concatMap (maybe [] (:[]) . fst) $ Foldable.toList $ Seq.viewl q
- mark sink first b source = let mark' = canPut sink
- >>= cond
- (get source
- >>= maybe
- (return [])
- (\x-> put sink (x, first, b)
- >>= cond mark' (return $ maybe [] (: []) x)))
- (return [])
- in mark'
- in (configuration, t)
-
-pairMarkerToMaybePairMarker :: forall m x. (ParallelizableMonad m, Typeable x)
- => Transducer m x (Either (x, Bool, Bool) (Either Bool Bool)) -> Transducer m x (Maybe x, Bool, Bool)
-pairMarkerToMaybePairMarker t = liftTransducer "pairMarkerToMaybePairMarker" (maxUsableThreads t + 1) $
- \threads-> let t's = usingThreads threads t
- t'p = usingThreads (threads - 1) t
- parallel = threads > 1 Prelude.&& cost t'p <= cost t's
- t' = if parallel then t'p else t's
- cost' = if parallel then (cost t'p `max` 1) + 1 else cost t's + 1
- transduce' source sink
- = liftM (\(x, y)-> y ++ x) $
- (if parallel then pipeP else pipe)
- (transduce t source)
- (\source-> let next state = get source >>= maybe (return []) state
- nextState2 l r d = get source
- >>= maybe (put sink (Nothing, l, r) >> return []) (state2 l r d)
- state0 (Left (x, l, r)) = put sink (Just x, l, r)
- >>= cond (next $ state1 l r) (return [x])
- state0 v@(Right d) = state2 False False d v
- state1 _ _ (Left (x, l, r)) = put sink (Just x, l, r)
- >>= cond (next $ state1 l r) (return [x])
- state1 l r v@(Right d) = state2 l r d v
- state2 l r Left{} (Right d@(Left l')) = nextState2 l' r d
- state2 l r Left{} (Right (Right r')) = put sink (Nothing, l, r')
- >>= cond (next $ state1 l r') (return [])
- state2 l r Left{} t@(Left (x, l', r')) | l == l' = state1 l r t
- | otherwise = put sink (Nothing, l, r)
- >>= cond
- (state1 l' r' t)
- (return [])
- state2 l r Right{} (Right d@(Right r')) = nextState2 l r' d
- state2 l r Right{} (Right (Left l')) = put sink (Nothing, l', r)
- >>= cond (next $ state1 l' r) (return [])
- state2 l r Right{} t@(Left (x, l', r')) | r == r' = state1 l r t
- | otherwise = put sink (Nothing, l, r)
- >>= cond
- (state1 l' r' t)
- (return [])
- in next state0)
- in (ComponentConfiguration [AnyComponent t'] threads cost', transduce')
-
-zipSplittersWith :: (ParallelizableMonad m, Typeable x) => (Bool -> Bool -> Bool) -> Splitter m x -> Splitter m x -> Splitter m x
-zipSplittersWith f s1 s2
- = liftSectionSplitter "zip" (maxUsableThreads s1 + maxUsableThreads s2) $
- \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2
- s source true false = liftM (\(x, y)-> y ++ x) $
- (if parallel then pipeP else pipe)
- (transduce (pairMarkerToMaybePairMarker $ splittersToPairMarker s1 s2) source)
- (\source-> let split = get source >>= maybe (return []) test
- test (x, b1, b2) = (if f b1 b2 then put true x else put false x)
- >>= cond split (return $ maybe [] (:[]) x)
- in split)
- in (configuration, s)
-
-groupMarks :: forall c m x y z. (ParallelizableMonad m, Typeable x, Typeable y, Eq y)
- => Source c (Maybe x, y) -> (y -> Source c x -> Pipe c m z) -> Pipe c m ()
-groupMarks source getConsumer = getSuccess source startNew
- where startNew (mx, y) = do (nextPair, _) <- pipeD "groupMarks" (\sink-> pass sink mx y) (getConsumer y)
- case nextPair of Just p -> startNew p
- Nothing -> return ()
- pass sink Nothing y = next sink y
- pass sink (Just x) y = put sink x >> next sink y
- next sink y = get source >>= maybe (return Nothing) (continue sink y)
- continue sink y (x, y') | y == y' = pass sink x y
- continue sink y p@(x, y') | y /= y' = return (Just p)
-
-splitConsumer :: forall c m x r1 r2. (ParallelizableMonad m, Typeable x)
- => String -> Bool -> Splitter m x -> (Source c x -> Pipe c m r1) -> (Source c x -> Pipe c m r2)
- -> (Source c x -> Pipe c m ([x], r1, r2))
-splitConsumer description parallel s trueConsumer falseConsumer = consumer'
- where consumer' source = (if parallel then pipeP else pipe)
- (\false-> pipeD (description ++ " true") (\true-> split s source true false) trueConsumer)
- falseConsumer
- >>= \((extra, r1), r2)-> return (extra, r1, r2)
-
-splitConsumerSections :: forall m x r1 r2. (ParallelizableMonad m, Typeable x) =>
- String -> Splitter m x -> Consumer m (Maybe x) r1 -> Consumer m (Maybe x) r2 -> Consumer m x ([x], r1, r2)
-splitConsumerSections description s trueConsumer falseConsumer
- = liftConsumer description (maxUsableThreads s + maxUsableThreads trueConsumer + maxUsableThreads falseConsumer) usingThreads
- where usingThreads :: Int -> (ComponentConfiguration, forall c. Source c x -> Pipe c m ([x], r1, r2))
- usingThreads threadCount = (configuration', consumer')
- where (configuration', (splitter', forkSplitter), (trueConsumer', forkTrue), (falseConsumer', forkFalse))
- = optimalThreeParallelConfigurations threadCount s trueConsumer falseConsumer
- consumer' source = (if forkFalse then pipeP else pipe)
- (\false-> (if forkTrue Prelude.|| forkSplitter then pipeP else pipe)
- (\true-> splitSections s source true false)
- (consume trueConsumer))
- (consume falseConsumer)
- >>= \((extra, r1), r2)-> return (extra, r1, r2)
-
-putQueue :: forall c m x. (Monad m, Typeable x) => Seq x -> Sink c x -> Pipe c m [x]
-putQueue q sink = putList (Foldable.toList (Seq.viewl q)) sink
-
-getQueue :: forall c m x. (Monad m, Typeable x) => Source c x -> Pipe c m (Seq x)
-getQueue source = let getOne q = get source >>= maybe (return q) (\x-> getOne (q |> x))
- in getOne Seq.empty
-
-pourMaybe :: forall c x m. (Monad m, Typeable x) => Source c x -> Sink c (Maybe x) -> Pipe c m ()
-pourMaybe source sink = pour0
- where pour0 = canPut sink >>= flip when (get source >>= maybe (put sink Nothing >> return ()) pass)
- pour1 = canPut sink >>= flip when (getSuccess source pass)
- pass x = put sink (Just x) >> pour1
-
-
-suppressProducer :: forall c m x r. (ParallelizableMonad m, Typeable x) => (Sink c x -> Pipe c m r) -> Pipe c m r
-suppressProducer p = liftM fst $ pipeD "suppress" p consumeAndSuppress
-
-fst3 :: (a, b, c) -> a
-fst3 (a, b, c) = a
+ 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, ImpredicativeTypes, KindSignatures, EmptyDataDecls,
+ MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, FlexibleInstances #-}
+
+-- | The "Combinators" module defines combinators applicable to 'Transducer' and 'Splitter' components defined in the
+-- "Control.Concurrent.SCC.ComponentTypes" module.
+
+module Control.Concurrent.SCC.Combinators
+ (-- * Consumer, producer, and transducer combinators
+ splitterToMarker,
+ consumeBy, prepend, append, substitute,
+ PipeableComponentPair ((>->)), 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, (>&), (>|),
+ -- ** 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.
+ (&&), (||),
+ -- * 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
+ (...),
+ -- * parser support
+ parseRegions, parseNestedRegions,
+ -- * grouping helpers
+ groupMarks)
+where
+
+import Control.Concurrent.SCC.Foundation
+import Control.Concurrent.SCC.ComponentTypes
+
+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 Data.Maybe (isJust, isNothing, fromJust)
+import Data.Typeable (Typeable)
+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, Typeable x) => Consumer m x r -> Transducer m x y
+consumeBy c = liftTransducer "consumeBy" (maxUsableThreads c) $
+ \threads-> let c' = usingThreads threads c
+ in (ComponentConfiguration [AnyComponent c'] (usedThreads c') (cost c'),
+ \ 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 (>->) :: c1 -> c2 -> c3
+
+instance (ParallelizableMonad m, Typeable x)
+ => PipeableComponentPair m x (Producer m x ()) (Consumer m x ()) (Performer m ())
+ where p >-> c = liftPerformer ">->" (maxUsableThreads p `max` maxUsableThreads c) $
+ \threads-> let (configuration, p', c', parallel) = optimalTwoParallelConfigurations threads p c
+ performPipe = (if parallel then pipeP else pipe) (produce p') (consume c') >> return ()
+ in (configuration, performPipe)
+
+instance (ParallelizableMonad m, Typeable x, Typeable y)
+ => PipeableComponentPair m y (Transducer m x y) (Consumer m y r) (Consumer m x r)
+ where t >-> c = liftConsumer ">->" (maxUsableThreads t `max` maxUsableThreads c) $
+ \threads-> let (configuration, t', c', parallel) = optimalTwoParallelConfigurations threads t c
+ consumePipe source = liftM snd $ (if parallel then pipeP else pipe)
+ (transduce t' source)
+ (consume c')
+ in (configuration, consumePipe)
+
+instance (ParallelizableMonad m, Typeable x, Typeable y)
+ => PipeableComponentPair m x (Producer m x r) (Transducer m x y) (Producer m y r)
+ where p >-> t = liftProducer ">->" (maxUsableThreads t `max` maxUsableThreads p) $
+ \threads-> let (configuration, p', t', parallel) = optimalTwoParallelConfigurations threads p t
+ producePipe sink = liftM fst $ (if parallel then pipeP else pipe)
+ (produce p')
+ (\source-> transduce t' source sink)
+ in (configuration, producePipe)
+
+instance ParallelizableMonad m => PipeableComponentPair m y (Transducer m x y) (Transducer m y z) (Transducer m x z)
+ where t1 >-> t2 = liftTransducer ">->" (maxUsableThreads t1 + maxUsableThreads t2) $
+ \threads-> let (configuration, t1', t2', parallel) = optimalTwoParallelConfigurations threads t1 t2
+ transducePipe source sink = liftM fst $ (if parallel then pipeP else pipe)
+ (transduce t1' source)
+ (\source-> transduce t2' source sink)
+ in (configuration, transducePipe)
+
+class Component c => 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 :: c1 -> c2 -> c3
+ sequence :: c1 -> c2 -> c3
+ join = sequence
+
+instance forall m x any r1 r2. (Monad m, Typeable x)
+ => 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 = liftProducer "sequence" (maxUsableThreads p1 `max` maxUsableThreads p2) $
+ \threads-> let (configuration, p1', p2') = optimalTwoSequentialConfigurations threads p1 p2
+ produceJoin sink = produce p1' sink >> produce p2' sink
+ in (configuration, produceJoin)
+
+instance forall m x any. (ParallelizableMonad m, Typeable x)
+ => JoinableComponentPair (ConsumerType ()) (ConsumerType ()) (ConsumerType ()) m [x] () (Consumer m x ()) (Consumer m x ()) (Consumer m x ())
+ where join c1 c2 = liftConsumer "join" (maxUsableThreads c1 + maxUsableThreads c2) $
+ \threads-> let (configuration, c1', c2', parallel) = optimalTwoParallelConfigurations threads c1 c2
+ consumeJoin source = do (if parallel then pipeP else pipe)
+ (\sink1-> pipe (tee source sink1) (consume c2'))
+ (consume c1')
+ return ()
+ in (configuration, consumeJoin)
+ sequence c1 c2 = liftConsumer "sequence" (maxUsableThreads c1 `max` maxUsableThreads c2) $
+ \threads-> let (configuration, c1', c2') = optimalTwoSequentialConfigurations threads c1 c2
+ consumeJoin source = pipe
+ (\buffer-> pipe (tee source buffer) (consume c1'))
+ getList
+ >>= \(_, list)-> pipe (putList list) (consume c2')
+ >> return ()
+ in (configuration, consumeJoin)
+
+instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)
+ => JoinableComponentPair TransducerType TransducerType TransducerType m [x] [y] (Transducer m x y) (Transducer m x y) (Transducer m x y)
+ where join t1 t2 = liftTransducer "join" (maxUsableThreads t1 + maxUsableThreads t2) $
+ \threads-> let (configuration, t1', t2', parallel) = optimalTwoParallelConfigurations threads t1 t2
+ transduce' source sink = pipe
+ (\buffer-> (if parallel then pipeP else pipe)
+ (\sink1-> pipe
+ (\sink2-> tee source sink1 sink2)
+ (\src-> transduce t2' src buffer))
+ (\source-> transduce t1' source sink))
+ getList
+ >>= \(_, list)-> putList list sink
+ >> getList source
+ in (configuration, transduce')
+ sequence t1 t2 = liftTransducer "sequence" (maxUsableThreads t1 `max` maxUsableThreads t2) $
+ \threads-> let (configuration, t1', t2') = optimalTwoSequentialConfigurations threads t1 t2
+ transduce' 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
+ in (configuration, transduce')
+
+
+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 p1 p2 = liftPerformer "join" (maxUsableThreads p1 + maxUsableThreads p2) $
+ \threads-> let (configuration, p1', p2', parallel) = optimalTwoParallelConfigurations threads p1 p2
+ in (configuration, if parallel then liftM snd $ perform p1' `parallelize` perform p2'
+ else perform p1' >> perform p2')
+ sequence p1 p2 = liftPerformer "sequence" (maxUsableThreads p1 `max` maxUsableThreads p2) $
+ \threads-> let (configuration, p1', p2') = optimalTwoSequentialConfigurations threads p1 p2
+ in (configuration, perform p1' >> perform p2')
+
+instance forall m x r1 r2. (ParallelizableMonad m, Typeable x)
+ => JoinableComponentPair (PerformerType r1) (ProducerType r2) (ProducerType r2) m () [x] (Performer m r1) (Producer m x r2) (Producer m x r2)
+ where join pe pr = liftProducer "join" (maxUsableThreads pe + maxUsableThreads pr) $
+ \threads-> let (configuration, pe', pr', parallel) = optimalTwoParallelConfigurations threads pe pr
+ produceJoin sink = if parallel then liftM snd (perform pe' `parallelize` produce pr' sink)
+ else perform pe' >> produce pr' sink
+ in (configuration, produceJoin)
+ sequence pe pr = liftProducer "sequence" (maxUsableThreads pe `max` maxUsableThreads pr) $
+ \threads-> let (configuration, pe', pr') = optimalTwoSequentialConfigurations threads pe pr
+ produceJoin sink = perform pe' >> produce pr' sink
+ in (configuration, produceJoin)
+
+instance forall m x r1 r2. (ParallelizableMonad m, Typeable x)
+ => JoinableComponentPair (ProducerType r1) (PerformerType r2) (ProducerType r2) m () [x] (Producer m x r1) (Performer m r2) (Producer m x r2)
+ where join pr pe = liftProducer "join" (maxUsableThreads pr + maxUsableThreads pe) $
+ \threads-> let (configuration, pr', pe', parallel) = optimalTwoParallelConfigurations threads pr pe
+ produceJoin sink = if parallel then liftM snd (produce pr' sink `parallelize` perform pe')
+ else produce pr' sink >> perform pe'
+ in (configuration, produceJoin)
+ sequence pr pe = liftProducer "sequence" (maxUsableThreads pr `max` maxUsableThreads pe) $
+ \threads-> let (configuration, pr', pe') = optimalTwoSequentialConfigurations threads pr pe
+ produceJoin sink = produce pr' sink >> perform pe'
+ in (configuration, produceJoin)
+
+instance forall m x r1 r2. (ParallelizableMonad m, Typeable x)
+ => JoinableComponentPair (PerformerType r1) (ConsumerType r2) (ConsumerType r2) m [x] () (Performer m r1) (Consumer m x r2) (Consumer m x r2)
+ where join p c = liftConsumer "join" (maxUsableThreads p + maxUsableThreads c) $
+ \threads-> let (configuration, p', c', parallel) = optimalTwoParallelConfigurations threads p c
+ consumeJoin source = if parallel then liftM snd (perform p' `parallelize` consume c' source)
+ else perform p' >> consume c' source
+ in (configuration, consumeJoin)
+ sequence p c = liftConsumer "sequence" (maxUsableThreads p `max` maxUsableThreads c) $
+ \threads-> let (configuration, p', c') = optimalTwoSequentialConfigurations threads p c
+ consumeJoin source = perform p' >> consume c' source
+ in (configuration, consumeJoin)
+
+instance forall m x r1 r2. (ParallelizableMonad m, Typeable x)
+ => JoinableComponentPair (ConsumerType r1) (PerformerType r2) (ConsumerType r2) m [x] () (Consumer m x r1) (Performer m r2) (Consumer m x r2)
+ where join c p = liftConsumer "join" (maxUsableThreads c + maxUsableThreads p) $
+ \threads-> let (configuration, c', p', parallel) = optimalTwoParallelConfigurations threads c p
+ consumeJoin source = if parallel then liftM snd (consume c' source `parallelize` perform p')
+ else consume c' source >> perform p'
+ in (configuration, consumeJoin)
+ sequence c p = liftConsumer "sequence" (maxUsableThreads c `max` maxUsableThreads p) $
+ \threads-> let (configuration, c', p') = optimalTwoSequentialConfigurations threads c p
+ consumeJoin source = consume c' source >> perform p'
+ in (configuration, consumeJoin)
+
+instance forall m x y r. (ParallelizableMonad m, Typeable x, Typeable y)
+ => JoinableComponentPair (PerformerType r) TransducerType TransducerType m [x] [y] (Performer m r) (Transducer m x y) (Transducer m x y)
+ where join p t = liftTransducer "join" (maxUsableThreads p + maxUsableThreads t) $
+ \threads-> let (configuration, p', t', parallel) = optimalTwoParallelConfigurations threads p t
+ join' source sink = if parallel then liftM snd (perform p'
+ `parallelize` transduce t' source sink)
+ else perform p' >> transduce t' source sink
+ in (configuration, join')
+ sequence p t = liftTransducer "sequence" (maxUsableThreads p `max` maxUsableThreads t) $
+ \threads-> let (configuration, p', t') = optimalTwoSequentialConfigurations threads p t
+ join' source sink = perform p' >> transduce t' source sink
+ in (configuration, join')
+
+instance forall m x y r. (ParallelizableMonad m, Typeable x, Typeable y)
+ => JoinableComponentPair TransducerType (PerformerType r) TransducerType m [x] [y] (Transducer m x y) (Performer m r) (Transducer m x y)
+ where join t p = liftTransducer "join" (maxUsableThreads t + maxUsableThreads p) $
+ \threads-> let (configuration, t', p', parallel) = optimalTwoParallelConfigurations threads t p
+ join' source sink = if parallel then liftM fst (transduce t' source sink
+ `parallelize` perform p')
+ else do result <- transduce t' source sink
+ perform p'
+ return result
+ in (configuration, join')
+ sequence t p = liftTransducer "sequence" (maxUsableThreads t `max` maxUsableThreads p) $
+ \threads-> let (configuration, t', p') = optimalTwoSequentialConfigurations threads t p
+ join' source sink = do result <- transduce t' source sink
+ perform p'
+ return result
+ in (configuration, join')
+
+instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)
+ => JoinableComponentPair (ProducerType ()) TransducerType TransducerType m [x] [y] (Producer m y ()) (Transducer m x y) (Transducer m x y)
+ where join p t = liftTransducer "join" (maxUsableThreads p + maxUsableThreads t) $
+ \threads-> let (configuration, p', t', parallel) = optimalTwoParallelConfigurations threads p t
+ join' source sink = if parallel
+ then do ((_, rest), out) <- pipe
+ (\buffer-> produce p' sink `parallelize`
+ transduce t' source buffer)
+ getList
+ putList out sink
+ return rest
+ else produce p' sink >> transduce t' source sink
+ in (configuration, join')
+ sequence p t = liftTransducer "sequence" (maxUsableThreads p `max` maxUsableThreads t) $
+ \threads-> let (configuration, p', t') = optimalTwoSequentialConfigurations threads p t
+ join' source sink = produce p' sink >> transduce t' source sink
+ in (configuration, join')
+
+instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)
+ => JoinableComponentPair TransducerType (ProducerType ()) TransducerType m [x] [y] (Transducer m x y) (Producer m y ()) (Transducer m x y)
+ where join t p = liftTransducer "join" (maxUsableThreads t `max` maxUsableThreads p) $
+ \threads-> let (configuration, t', p', parallel) = optimalTwoParallelConfigurations threads t p
+ join' source sink = if parallel
+ then do ((rest, ()), out) <- pipe
+ (\buffer-> transduce t' source sink
+ `parallelize` produce p' buffer)
+ getList
+ putList out sink
+ return rest
+ else do result <- transduce t' source sink
+ produce p' sink
+ return result
+ in (configuration, join')
+ sequence t p = liftTransducer "sequence" (maxUsableThreads t `max` maxUsableThreads p) $
+ \threads-> let (configuration, t', p') = optimalTwoSequentialConfigurations threads t p
+ join' source sink = do result <- transduce t' source sink
+ produce p' sink
+ return result
+ in (configuration, join')
+
+instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)
+ => JoinableComponentPair (ConsumerType ()) TransducerType TransducerType m [x] [y] (Consumer m x ()) (Transducer m x y) (Transducer m x y)
+ where join c t = liftTransducer "join" (maxUsableThreads c + maxUsableThreads t) $
+ \threads-> let (configuration, c', t', parallel) = optimalTwoParallelConfigurations threads c t
+ join' source sink = liftM (snd . fst) $
+ (if parallel then pipeP else pipe)
+ (\sink1-> pipe
+ (tee source sink1)
+ (\source-> transduce t' source sink))
+ (consume c')
+ in (configuration, join')
+ sequence c t = liftTransducer "sequence" (maxUsableThreads c `max` maxUsableThreads t) $
+ \threads-> let (configuration, c', t') = optimalTwoSequentialConfigurations threads c t
+ sequence' 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
+ in (configuration, sequence')
+
+instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)
+ => JoinableComponentPair TransducerType (ConsumerType ()) TransducerType m [x] [y] (Transducer m x y) (Consumer m x ()) (Transducer m x y)
+ where join t c = join c t
+ sequence t c = liftTransducer "sequence" (maxUsableThreads t `max` maxUsableThreads c) $
+ \threads-> let (configuration, t', c') = optimalTwoSequentialConfigurations threads t c
+ sequence' 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
+ in (configuration, sequence')
+
+instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)
+ => JoinableComponentPair (ProducerType ()) (ConsumerType ()) TransducerType m [x] [y] (Producer m y ()) (Consumer m x ()) (Transducer m x y)
+ where join p c = liftTransducer "sequence" (maxUsableThreads p + maxUsableThreads c) $
+ \threads-> let (configuration, p', c', parallel) = optimalTwoParallelConfigurations threads p c
+ join' source sink = if parallel then produce p' sink >> consume c' source >> return []
+ else parallelize (produce p' sink) (consume c' source) >> return []
+ in (configuration, join')
+ sequence p c = liftTransducer "sequence" (maxUsableThreads p `max` maxUsableThreads c) $
+ \threads-> let (configuration, p', c') = optimalTwoSequentialConfigurations threads p c
+ join' source sink = produce p' sink >> consume c' source >> return []
+ in (configuration, join')
+
+instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)
+ => JoinableComponentPair (ConsumerType ()) (ProducerType ()) TransducerType m [x] [y] (Consumer m x ()) (Producer m y ()) (Transducer m x y)
+ where join c p = join p c
+ sequence c p = liftTransducer "sequence" (maxUsableThreads c `max` maxUsableThreads p) $
+ \threads-> let (configuration, c', p') = optimalTwoSequentialConfigurations threads c p
+ join' source sink = consume c' source >> produce p' sink >> return []
+ in (configuration, join')
+
+-- | 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, Typeable x) => Producer m x r -> Transducer m x x
+prepend prefix = liftTransducer "prepend" (maxUsableThreads prefix) $
+ \threads-> let prefix' = usingThreads threads prefix
+ prepend' source sink = produce prefix' sink >> pour source sink >> return []
+ in (ComponentConfiguration [AnyComponent prefix] threads (cost prefix'), prepend')
+
+-- | 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, Typeable x) => Producer m x r -> Transducer m x x
+append suffix = liftTransducer "append" (maxUsableThreads suffix) $
+ \threads-> let suffix' = usingThreads threads suffix
+ append' source sink = pour source sink >> produce suffix' sink >> return []
+ in (ComponentConfiguration [AnyComponent suffix] threads (cost suffix'), append')
+
+-- | 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, Typeable x, Typeable y) => Producer m y r -> Transducer m x y
+substitute feed = liftTransducer "substitute" (maxUsableThreads feed) $
+ \threads-> let feed' = usingThreads threads feed
+ substitute' source sink = consumeAndSuppress source >> produce feed' sink >> return []
+ in (ComponentConfiguration [AnyComponent feed] threads (cost feed'), substitute')
+
+-- | 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 :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x b
+snot splitter = liftSplitter "not" (maxUsableThreads splitter) $
+ \threads-> let splitter' = usingThreads threads splitter
+ not source true false edge = liftM fst $
+ pipe
+ (split splitter source false true)
+ consumeAndSuppress
+ in (ComponentConfiguration [AnyComponent splitter'] threads (cost splitter'), not)
+
+-- | 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.
+(>&) :: (ParallelizableMonad m, Typeable x, Typeable b1, Typeable b2) => Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)
+s1 >& s2 = liftSplitter ">&" (maxUsableThreads s1 + maxUsableThreads s2) $
+ \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2
+ s source true false edge = liftM (fst . fst . fst . fst) $
+ pipe
+ (\edges->
+ pipe
+ (\edge1-> pipe
+ (\edge2-> (if parallel then pipeP else pipe)
+ (\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)
+ in (configuration, s)
+
+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.
+(>|) :: forall m x b1 b2. (ParallelizableMonad m, Typeable x, Typeable b1, Typeable b2)
+ => Splitter m x b1 -> Splitter m x b2 -> Splitter m x (Either b1 b2)
+s1 >| s2 = liftSplitter ">|" (maxUsableThreads s1 + maxUsableThreads s2) $
+ \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2
+ s source true false edge = liftM (fst . fst . fst) $
+ pipe
+ (\edge1-> pipe
+ (\edge2-> (if parallel then pipeP else pipe)
+ (\false-> split s1' source true false edge1)
+ (\source-> split s2' source true false edge2))
+ (flip (pourMap Right) edge))
+ (flip (pourMap Left) edge)
+ in (configuration, s)
+
+-- | Combinator '&&' is a pairwise logical conjunction of two splitters run in parallel on the same input.
+(&&) :: (ParallelizableMonad m, Typeable x, Typeable b1, Typeable b2) => Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)
+s1 && s2 = liftSplitter "&&" (maxUsableThreads s1 + maxUsableThreads s2) $
+ \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2
+ s source true false edge = liftM (\(x, y)-> y ++ x) $
+ (if parallel then pipeP else pipe)
+ (transduce (splittersToPairMarker s1' s2') source)
+ (\source-> let split l r = get source
+ >>= maybe
+ (return [])
+ (test l r)
+ test l r (Left (x, t1, t2))
+ = put (if t1 Prelude.&& t2 then true else 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)
+ in (configuration, s)
+
+-- | Combinator '||' is a pairwise logical disjunction of two splitters run in parallel on the same input.
+(||) :: (ParallelizableMonad m, Typeable x, Typeable b1, Typeable b2)
+ => Splitter m x b1 -> Splitter m x b2 -> Splitter m x (Either b1 b2)
+(||) = zipSplittersWith (Prelude.||) pour
+
+ifs :: (ParallelizableMonad m, Typeable x, Typeable b, BranchComponent cc m x [x]) => Splitter m x b -> cc -> cc -> cc
+ifs s = combineBranches "if" (cost s) (\ parallel c1 c2 -> \source-> splitInputToConsumers parallel s source c1 c2)
+
+wherever :: (ParallelizableMonad m, Typeable x, Typeable b) => Transducer m x x -> Splitter m x b -> Transducer m x x
+wherever t s = liftTransducer "wherever" (maxUsableThreads s + maxUsableThreads t) $
+ \threads-> let (configuration, s', t', parallel) = optimalTwoParallelConfigurations threads s t
+ wherever' source sink = splitInputToConsumers parallel s source
+ (\source-> transduce t source sink)
+ (\source-> pour source sink >> return [])
+ in (configuration, wherever')
+
+unless :: (ParallelizableMonad m, Typeable x, Typeable b) => Transducer m x x -> Splitter m x b -> Transducer m x x
+unless t s = liftTransducer "unless" (maxUsableThreads s + maxUsableThreads t) $
+ \threads-> let (configuration, s', t', parallel) = optimalTwoParallelConfigurations threads s t
+ unless' source sink = splitInputToConsumers parallel s source
+ (\source-> pour source sink >> return [])
+ (\source-> transduce t source sink)
+ in (configuration, unless')
+
+select :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Transducer m x x
+select s = liftTransducer "select" (maxUsableThreads s) $
+ \threads-> let s' = usingThreads threads s
+ transduce' source sink = splitInputToConsumers False s' source
+ (\source-> pour source sink >> return [])
+ (\source-> consumeAndSuppress source >> return [])
+ in (ComponentConfiguration [AnyComponent s'] threads (cost s' + 1), transduce')
+
+-- | Converts a splitter into a parser.
+parseRegions :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Parser m x b
+parseRegions s = liftTransducer "parseRegions" (maxUsableThreads s) $
+ \threads-> let s' = usingThreads threads s
+ transduce' source sink = liftM (\(x, y)-> y ++ x) $
+ pipe
+ (transduce (splitterToMarker s') source)
+ (\source-> wrapRegions source sink)
+ 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
+ in (ComponentConfiguration [AnyComponent s'] threads (cost s' + 1), transduce')
+
+-- | Converts a boundary-marking splitter into a parser.
+parseNestedRegions :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x (Boundary b) -> Parser m x b
+parseNestedRegions s = liftTransducer "parseNestedRegions" (maxUsableThreads s) $
+ \threads-> let s' = usingThreads threads s
+ transduce' source sink = liftM (\(w, (), (), _)-> w) $
+ splitToConsumers s' source
+ (flip (pourMap Content) sink)
+ (flip (pourMap Content) sink)
+ (flip (pourMap Markup) sink)
+ in (ComponentConfiguration [AnyComponent s'] threads (cost s' + 1), transduce')
+
+-- | 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 :: (ParallelizableMonad m, Typeable x, Typeable b) => Transducer m x x -> Splitter m x b -> Transducer m x x
+while t s = liftTransducer "while" (maxUsableThreads t + maxUsableThreads s) $
+ \threads-> let (configuration, s', while'', parallel) = optimalTwoParallelConfigurations threads s while'
+ transduce' source sink = splitInputToConsumers parallel s' source
+ (\source-> transduce while' source sink)
+ (\source-> pour source sink >> return [])
+ while' = t >-> while t s
+ in (configuration, transduce')
+
+-- | 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 :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x b -> Splitter m x b
+nestedIn s1 s2 = liftSplitter "nestedIn" (maxUsableThreads s1 + maxUsableThreads s2) $
+ \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2
+ s source true false edge
+ = liftM fst $
+ (if parallel then pipeP else pipe)
+ (\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 s1' s2')
+ source true false edge))))
+ in (configuration,s)
+
+-- | 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 :: (ParallelizableMonad m, Typeable x, Typeable b, BranchComponent cc m x [x]) => Splitter m x b -> cc -> cc -> cc
+foreach s = combineBranches "foreach" (cost s)
+ (\ parallel c1 c2 source-> liftM fst $ (if parallel then pipeP else pipe)
+ (transduce (splitterToMarker s) source)
+ (\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 :: (ParallelizableMonad m, Typeable x, Typeable b1, Typeable b2)
+ => Splitter m x b1 -> Splitter m x b2 -> Splitter m x b1
+having s1 s2 = liftSplitter "having" (maxUsableThreads s1 + maxUsableThreads s2) $
+ \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2
+ s source true false edge = liftM fst $
+ (if parallel then pipeP else pipe)
+ (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 [])
+ in (configuration, s)
+
+-- | 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 :: (ParallelizableMonad m, Typeable x, Typeable b1, Typeable b2)
+ => Splitter m x b1 -> Splitter m x b2 -> Splitter m x b1
+havingOnly s1 s2 = liftSplitter "havingOnly" (maxUsableThreads s1 + maxUsableThreads s2) $
+ \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2
+ s source true false edge = liftM fst $
+ (if parallel then pipeP else pipe)
+ (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 [])
+ in (configuration, s)
+
+-- | 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 :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x b
+first splitter = liftSplitter "first" (maxUsableThreads splitter) $
+ \threads-> let splitter' = usingThreads threads splitter
+ configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)
+ s source true false edge
+ = liftM (\(x, y)-> y ++ x) $
+ pipeD "first" (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)
+ in (configuration, s)
+
+-- | 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 :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x b
+uptoFirst splitter = liftSplitter "uptoFirst" (maxUsableThreads splitter) $
+ \threads-> let splitter' = usingThreads threads splitter
+ configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)
+ s source true false edge
+ = liftM (\(x, y)-> y ++ x) $
+ pipeD "uptoFirst" (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))
+ in (configuration, s)
+
+-- | 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 :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x b
+last splitter = liftSplitter "last" (maxUsableThreads splitter) $
+ \threads-> let splitter' = usingThreads threads splitter
+ configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)
+ s source true false edge
+ = liftM (\(x, y)-> y ++ x) $
+ pipeD "last" (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)
+ in (configuration, s)
+
+-- | 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 :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x b
+lastAndAfter splitter = liftSplitter "lastAndAfter" (maxUsableThreads splitter) $
+ \threads-> let splitter' = usingThreads threads splitter
+ configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)
+ s 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)
+ in (configuration, s)
+
+-- | 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 :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x b
+prefix splitter = liftSplitter "prefix" (maxUsableThreads splitter) $
+ \threads-> let splitter' = usingThreads threads splitter
+ configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)
+ s source true false edge
+ = liftM (\(x, y)-> y ++ x) $
+ pipeD "prefix" (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)
+ in (configuration, s)
+
+-- | 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 :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x b
+suffix splitter = liftSplitter "suffix" (maxUsableThreads splitter) $
+ \threads-> let splitter' = usingThreads threads splitter
+ configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)
+ s source true false edge
+ = liftM (\(x, y)-> y ++ x) $
+ pipeD "suffix" (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)
+ in (configuration, s)
+
+-- | 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 :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x b
+even splitter = liftSplitter "even" (maxUsableThreads splitter) $
+ \threads-> let splitter' = usingThreads threads splitter
+ configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)
+ s source true false edge
+ = liftM (\(x, y)-> y ++ x) $
+ pipeD "even"
+ (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)
+ in (configuration, s)
+
+-- | 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 :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x (Maybe b)
+startOf splitter = liftSplitter "startOf" (maxUsableThreads splitter) $
+ \threads-> let splitter' = usingThreads threads splitter
+ configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)
+ s source true false edge = liftM (\(x, y)-> y ++ x) $
+ pipeD "startOf"
+ (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)
+ in (configuration, s)
+
+-- | 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 :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x (Maybe b)
+endOf splitter = liftSplitter "endOf" (maxUsableThreads splitter) $
+ \threads-> let splitter' = usingThreads threads splitter
+ configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)
+ s source true false edge = liftM (\(x, y)-> y ++ x) $
+ pipeD "endOf"
+ (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)
+ in (configuration, s)
+
+-- | 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, Typeable x, Typeable b1, Typeable b2)
+ => Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)
+followedBy s1 s2 = liftSplitter "followedBy" (maxUsableThreads s1 + maxUsableThreads s2) $
+ \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2
+ in (configuration, followedBy' parallel s1' s2')
+ where followedBy' parallel s1 s2 source true false edge
+ = liftM (\(x, y)-> y ++ x) $
+ (if parallel then pipeP else pipe)
+ (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) <- pipeD "testEnd" (const $ return ()) (test mb q)
+ case n of Nothing -> putQueue q false
+ _ -> return []
+ test mb q source = liftM snd $
+ pipeD "follower"
+ (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.
+(...) :: forall m x b1 b2. (ParallelizableMonad m, Typeable x, Typeable b1, Typeable b2)
+ => Splitter m x b1 -> Splitter m x b2 -> Splitter m x b1
+s1 ... s2 = liftSplitter "..." (maxUsableThreads s1 + maxUsableThreads s2) $
+ \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2
+ s source true false edge
+ = liftM (\(x, y)-> y ++ x) $
+ (if parallel then pipeP else pipe)
+ (transduce (splittersToPairMarker 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)
+ in (configuration, s)
+
+-- Helper functions
+
+-- | Converts a 'Control.Concurrent.SCC.ComponentTypes.Splitter' into a
+-- 'Control.Concurrent.SCC.ComponentTypes.Transducer'. Every input value @x@ that the argument splitter sends to its
+-- /true/ sink is converted to @Left (x, True)@, every @y@ sent to the splitter's /false/ sink becomes @Left (y,
+-- False)@, and any value @e@ the splitter puts in its /edge/ sink becomes @Right e@.
+splitterToMarker :: forall m x b. (ParallelizableMonad m, Typeable x, Typeable b)
+ => Splitter m x b -> Transducer m x (Either (x, Bool) b)
+splitterToMarker s = liftTransducer "splitterToMarker" (maxUsableThreads s) $
+ \threads-> let s' = usingThreads threads s
+ t source sink = liftM (\(x, y, z, _)-> z ++ y ++ x) $
+ splitToConsumers s' source
+ (mark (\x-> Left (x, True)))
+ (mark (\x-> Left (x, False)))
+ (mark Right)
+ where mark f source = canPut sink
+ >>= cond
+ (get source
+ >>= maybe (return [])
+ (\x-> put sink (f x)
+ >>= cond (mark f source) (return [x])))
+ (return [])
+ in (ComponentConfiguration [AnyComponent s'] threads (cost s' + 1), t)
+
+
+splittersToPairMarker :: forall m x b1 b2. (ParallelizableMonad m, Typeable x, Typeable b1, Typeable b2)
+ => Splitter m x b1 -> Splitter m x b2
+ -> Transducer m x (Either (x, Bool, Bool) (Either b1 b2))
+splittersToPairMarker s1 s2
+ = liftTransducer "splittersToPairMarker" (maxUsableThreads s1 + maxUsableThreads s2) $
+ \threads-> let (configuration, s1', s2', parallelize) = optimalTwoParallelConfigurations threads s1 s2
+ t source sink = liftM (\(((_, _), (x, _, _, _)), _)-> x) $
+ pipeD "splittersToPairMarker synchronize"
+ (\sync-> (if parallelize then pipeP else pipe)
+ (\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 c (Either (x, Bool, Bool) (Either b1 b2))
+ -> Source c (Either ((x, Bool), Bool) (Either b1 b2))
+ -> Pipe 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 c (Either (x, Bool, Bool) (Either b1 b2))
+ -> Source c (Either ((x, Bool), Bool) (Either b1 b2))
+ -> Either ((x, Bool), Bool) (Either b1 b2) -> Pipe 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 (configuration, t)
+
+zipSplittersWith :: (ParallelizableMonad m, Typeable x, Typeable b1, Typeable b2, Typeable b)
+ => (Bool -> Bool -> Bool)
+ -> (forall c. Source c (Either b1 b2) -> Sink c b -> Pipe c m ())
+ -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x b
+zipSplittersWith f boundaries s1 s2
+ = liftSplitter "zip" (maxUsableThreads s1 + maxUsableThreads s2) $
+ \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2
+ s source true false edge = liftM (\((x, y), _)-> y ++ x) $
+ pipe
+ (\edge'->
+ (if parallel then pipeP else pipe)
+ (transduce (splittersToPairMarker s1' s2') source)
+ (\source-> let split = get source
+ >>= maybe
+ (return [])
+ (either
+ test
+ (\b-> put edge' b >> split))
+ test (x, t1, t2) = put (if f t1 t2 then true else false) x
+ >>= cond split (return [x])
+ in split))
+ (flip boundaries edge)
+ in (configuration, s)
+-- | 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 :: forall c m x b r. (ParallelizableMonad m, Typeable x, Typeable b)
+ => Source c (Either (x, Bool) b) -> (Maybe (Maybe b) -> Source c x -> Pipe c m r) -> Pipe c 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)
diff --git a/Control/Concurrent/SCC/ComponentTypes.hs b/Control/Concurrent/SCC/ComponentTypes.hs
--- a/Control/Concurrent/SCC/ComponentTypes.hs
+++ b/Control/Concurrent/SCC/ComponentTypes.hs
@@ -1,5 +1,5 @@
{-
- Copyright 2008 Mario Blazevic
+ Copyright 2008-2009 Mario Blazevic
This file is part of the Streaming Component Combinators (SCC) project.
@@ -14,21 +14,22 @@
.
-}
-{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies,
- ExistentialQuantification, KindSignatures, Rank2Types, PatternSignatures #-}
+{-# LANGUAGE ScopedTypeVariables, KindSignatures, Rank2Types, ImpredicativeTypes, ExistentialQuantification, DeriveDataTypeable,
+ MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies #-}
module Control.Concurrent.SCC.ComponentTypes
(-- * Classes
- Component (..), BranchComponent (combineBranches),
+ Component (..), BranchComponent (combineBranches), LiftableComponent (liftComponent), Container (..),
-- * Types
AnyComponent (AnyComponent), Performer (..), Consumer (..), Producer(..), Splitter(..), Transducer(..),
- ComponentConfiguration(..),
+ ComponentConfiguration(..), Boundary(..), Markup(..), Parser,
-- * Lifting functions
liftPerformer, liftConsumer, liftAtomicConsumer, liftProducer, liftAtomicProducer,
liftTransducer, liftAtomicTransducer, lift121Transducer, liftStatelessTransducer, liftFoldTransducer, liftStatefulTransducer,
- liftSimpleSplitter, liftSectionSplitter, liftAtomicSimpleSplitter, liftAtomicSectionSplitter, liftStatelessSplitter,
+ liftSplitter, liftAtomicSplitter, liftStatelessSplitter, liftStatefulSplitter,
-- * Utility functions
- showComponentTree, optimalTwoParallelConfigurations, optimalTwoSequentialConfigurations, optimalThreeParallelConfigurations
+ showComponentTree, optimalTwoParallelConfigurations, optimalTwoSequentialConfigurations, optimalThreeParallelConfigurations,
+ splitToConsumers, splitInputToConsumers
)
where
@@ -117,17 +118,91 @@
-- | The 'Splitter' type represents computations that distribute data 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. If the two sink arguments of a splitter are the same, the splitter must act as an identity transform.
-data Splitter m x = Splitter {splitterName :: String,
- splitterMaxThreads :: Int,
- splitterConfiguration :: ComponentConfiguration,
- splitterUsingThreads :: Int -> (ComponentConfiguration,
- forall c. Source c x -> Sink c x -> Sink c x -> Pipe c m [x],
- forall c. Source c x -> Sink c (Maybe x) -> Sink c (Maybe x)
- -> Pipe c m [x]),
- split :: forall c. Source c x -> Sink c x -> Sink c x -> Pipe c m [x],
- splitSections :: forall c. Source c x -> Sink c (Maybe x) -> Sink c (Maybe x) -> Pipe c m [x]}
+-- source. If the two 'Sink c x' arguments of a splitter are the same, the splitter must act as an identity transform.
+data Splitter m x b = Splitter {splitterName :: String,
+ splitterMaxThreads :: Int,
+ splitterConfiguration :: ComponentConfiguration,
+ splitterUsingThreads :: Int -> (ComponentConfiguration,
+ forall c. Source c x -> Sink c x -> Sink c x -> Sink c b
+ -> Pipe c m [x]),
+ split :: forall c. Source c x -> Sink c x -> Sink c x -> Sink c b -> Pipe c m [x]}
+-- | 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'
+-- constructor wraps the actual data.
+data Boundary y = Start y | End y | Point y deriving (Eq, Show, Typeable)
+data Markup x y = Content x | Markup (Boundary y) deriving (Eq, Typeable)
+type Parser m x b = Transducer m x (Markup x b)
+
+instance Functor Boundary where
+ fmap f (Start b) = Start (f b)
+ fmap f (End b) = End (f b)
+ fmap f (Point b) = Point (f b)
+
+instance (Show y) => Show (Markup Char y) where
+ showsPrec p (Content x) s = x : s
+ showsPrec p (Markup b) s = '[' : shows b (']' : s)
+
+-- | The 'Container' class applies to two types where a first type value may contain values of the second type.
+class Container x y where
+ -- | 'unwrap' returns a pair of a 'Splitter' that determines which containers are non-empty, and a 'Transducer' that
+ -- unwraps the contained values.
+ unwrap :: ParallelizableMonad m => (Splitter m x (), Transducer m x y)
+ -- | 'rewrap' returns a 'Transducer' that puts the unwrapped values into containers again.
+ rewrap :: ParallelizableMonad m => Transducer m y x
+
+instance (Typeable x, Typeable y) => Container (Markup x y) x where
+ unwrap = (liftStatelessSplitter "isContent" isContent, liftStatelessTransducer "unwrapContent" unwrapContent)
+ where isContent (Content x) = True
+ isContent _ = False
+ unwrapContent (Content x) = [x]
+ unwrapContent _ = []
+ rewrap = lift121Transducer "wrapContent" Content
+
+class LiftableComponent cx cy x y | cx -> x, cy -> y, cx y -> cy, cy x -> cx where
+ liftComponent :: cy -> cx
+
+instance forall m x y. (Container x y, ParallelizableMonad m, Typeable x, Typeable y)
+ => LiftableComponent (Transducer m x x) (Transducer m y y) x y where
+ liftComponent t = liftTransducer "liftComponent" (maxUsableThreads t + maxUsableThreads (rewrap :: Transducer m y x)) $
+ \threads-> let (configuration, t', w', parallel) = optimalTwoParallelConfigurations threads t wrapper
+ (wrapper :: Splitter m x (), unwrap' :: Transducer m x y) = unwrap
+ tx source sink = liftM (const []) $
+ pipe
+ (\true-> pipe
+ (split w' source true sink)
+ consumeAndSuppress)
+ (\wrapped-> pipe
+ (transduce unwrap' wrapped)
+ (\unwrapped-> pipe
+ (transduce t' unwrapped)
+ (\out-> transduce rewrap out sink)))
+ in (configuration, tx)
+
+instance forall m x y. (Container x y, ParallelizableMonad m, Typeable x, Typeable y)
+ => LiftableComponent (Splitter m x ()) (Splitter m y ()) x y where
+ liftComponent splitter = liftSplitter "liftComponent" (maxUsableThreads splitter + maxUsableThreads (rewrap :: Transducer m y x)) $
+ \threads-> let (configuration, s', w', parallel) = optimalTwoParallelConfigurations threads splitter wrapper
+ (wrapper :: Splitter m x (), unwrap' :: Transducer m x y) = unwrap
+ split' :: forall c. Source c x -> Sink c x -> Sink c x -> Sink c () -> Pipe c m [x]
+ split' source true false edge
+ = liftM (fst . fst . fst) $
+ pipe
+ (\rewrappedTrue-> pipe
+ (\rewrappedFalse-> split'' source rewrappedTrue rewrappedFalse false edge)
+ (flip (transduce rewrap) false))
+ (flip (transduce rewrap) true)
+ split'' :: forall c. Source c x -> Sink c y -> Sink c y -> Sink c x -> Sink c () -> Pipe c m ([x], ([x], [y]))
+ split'' source true1 false1 false2 edge = pipe
+ (\sink-> split''' source sink false2 edge)
+ (\source-> pipe
+ (transduce unwrap' source)
+ (\source-> split s' source true1 false1 edge))
+ split''' :: forall c. Source c x -> Sink c x -> Sink c x -> Sink c ()
+ -> Pipe c m [x]
+ split''' source true false edge = split w' source true false edge
+ in (configuration, split')
+
instance Component (Performer m r) where
name = performerName
subComponents = componentChildren . performerConfiguration
@@ -167,18 +242,16 @@
in transducer{transducerConfiguration= configuration', transduce= transduce'}
cost = componentCost . transducerConfiguration
-instance Component (Splitter m x) where
+instance Component (Splitter m x b) where
name = splitterName
subComponents = componentChildren . splitterConfiguration
maxUsableThreads = splitterMaxThreads
usedThreads = componentThreads . splitterConfiguration
usingThreads threads splitter = let (configuration',
- split' :: forall c. Source c x -> Sink c x -> Sink c x -> Pipe c m [x],
- splitSections' :: forall c. Source c x -> Sink c (Maybe x) -> Sink c (Maybe x)
- -> Pipe c m [x])
- = splitterUsingThreads splitter threads
+ split' :: forall c. Source c x -> Sink c x -> Sink c x -> Sink c b -> Pipe c m [x])
+ = splitterUsingThreads splitter threads
in splitter{splitterConfiguration= configuration',
- split= split', splitSections= splitSections'}
+ split= split'}
cost = componentCost . splitterConfiguration
@@ -214,14 +287,14 @@
source
in (configuration, transduce')
-instance forall m x. (ParallelizableMonad m, Typeable x) => BranchComponent (Splitter m x) m x [x] where
+instance forall m x b. (ParallelizableMonad m, Typeable x) => BranchComponent (Splitter m x b) m x [x] where
combineBranches name cost combinator s1 s2
- = liftSimpleSplitter name (maxUsableThreads s1 + maxUsableThreads s2) $
+ = liftSplitter name (maxUsableThreads s1 + maxUsableThreads s2) $
\threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2
- split' source true false = combinator parallel
- (\source-> split s1 source true false)
- (\source-> split s2 source true false)
- source
+ split' source true false edge = combinator parallel
+ (\source-> split s1 source true false edge)
+ (\source-> split s2 source true false edge)
+ source
in (configuration, split')
-- | Function 'liftPerformer' takes a component name, maximum number of threads it can use, and its 'usingThreads'
@@ -304,86 +377,42 @@
-- | Function 'liftStatelessSplitter' takes a function that assigns a Boolean value to each input item and lifts it into
-- a 'Splitter'.
-liftStatelessSplitter :: (ParallelizableMonad m, Typeable x) => String -> (x -> Bool) -> Splitter m x
-liftStatelessSplitter name f = liftAtomicSimpleSplitter name 1 $
- \source true false-> let s = get source
- >>= maybe
- (return [])
- (\x-> (if f x
- then put true x
- else put false x)
- >>= cond s (return [x]))
- in s
-
--- | Function 'liftSimpleSplitter' lifts a simple, non-sectioning splitter function into a full 'Splitter'.
-liftSimpleSplitter :: forall m x. (ParallelizableMonad m, Typeable x) =>
- String -> Int
- -> (Int -> (ComponentConfiguration, forall c. Source c x -> Sink c x -> Sink c x -> Pipe c m [x]))
- -> Splitter m x
-liftSimpleSplitter name maxThreads usingThreads
- = case usingThreads 1
- of (configuration, split) -> Splitter name maxThreads configuration usingThreads' split (splitSections split)
- where usingThreads' :: Int -> (ComponentConfiguration,
- forall c. Source c x -> Sink c x -> Sink c x -> Pipe c m [x],
- forall c. Source c x -> Sink c (Maybe x) -> Sink c (Maybe x) -> Pipe c m [x])
- usingThreads' threads = case usingThreads threads
- of (configuration, splitValues) -> (configuration, splitValues, splitSections splitValues)
- splitSections split source true false
- = liftM (fst . fst) $
- pipeD "liftSimpleSplitter true"
- (\true'-> pipeD "liftSimpleSplitter false"
- (\false'-> split source true' false')
- (decorate false))
- (decorate true)
- decorate sink source = transduce (lift121Transducer "Just" Just) source sink
-
+liftStatelessSplitter :: (ParallelizableMonad m, Typeable x) => String -> (x -> Bool) -> Splitter m x b
+liftStatelessSplitter name f = liftAtomicSplitter name 1 $
+ \source true false edge->
+ let s = get source
+ >>= maybe
+ (return [])
+ (\x-> put (if f x then true else false) x
+ >>= cond s (return [x]))
+ in s
--- | Function 'liftSectionSplitter' lifts a sectioning splitter function into a full 'Splitter'
-liftSectionSplitter :: forall m x. (ParallelizableMonad m, Typeable x) =>
- String -> Int -> (Int -> (ComponentConfiguration,
- forall c. Source c x -> Sink c (Maybe x) -> Sink c (Maybe x) -> Pipe c m [x]))
- -> Splitter m x
-liftSectionSplitter name maxThreads usingThreads
- = case usingThreads 1
- of (configuration, splitSections) -> Splitter name 1 configuration usingThreads' (splitValues splitSections) splitSections
- where usingThreads' :: Int -> (ComponentConfiguration,
- forall c. Source c x -> Sink c x -> Sink c x -> Pipe c m [x],
- forall c. Source c x -> Sink c (Maybe x) -> Sink c (Maybe x) -> Pipe c m [x])
- usingThreads' threads = case usingThreads threads
- of (configuration, splitSections) -> (configuration, splitValues splitSections, splitSections)
- splitValues splitSections source true false
- = liftM (fst . fst) $
- pipeD "liftSectionSplitter true"
- (\true'-> pipeD "liftSectionSplitter false" (\false'-> splitSections source true' false') (strip false))
- (strip true)
- strip sink source = canPut sink
- >>= flip when (getSuccess source (\x-> maybe (return False) (put sink) x >> strip sink source))
+-- | Function 'liftStatefulSplitter' takes a state-converting function that also assigns a Boolean value to each input
+-- item and lifts it into a 'Splitter'.
+liftStatefulSplitter :: (ParallelizableMonad m, Typeable x) => String -> (state -> x -> (state, Bool)) -> state -> Splitter m x ()
+liftStatefulSplitter name f s0 = liftAtomicSplitter name 1 $
+ \source true false edge->
+ let split s = get source
+ >>= maybe
+ (return [])
+ (\x-> let (s', truth) = f s x
+ in put (if truth then true else false) x
+ >>= cond (split s') (return [x]))
+ in split s0
--- | Function 'liftAtomicSimpleSplitter' lifts a single-threaded 'split' function into a 'Splitter' component.
-liftAtomicSimpleSplitter :: forall m x. (ParallelizableMonad m, Typeable x) =>
- String -> Int -> (forall c. Source c x -> Sink c x -> Sink c x -> Pipe c m [x]) -> Splitter m x
-liftAtomicSimpleSplitter name cost split = liftSimpleSplitter name 1 (\_threads-> (ComponentConfiguration [] 1 cost, split))
+-- | Function 'liftSplitter' lifts a splitter function into a full 'Splitter'.
+liftSplitter :: forall m x b. (Monad m, Typeable x) =>
+ String -> Int
+ -> (Int -> (ComponentConfiguration, forall c. Source c x -> Sink c x -> Sink c x -> Sink c b -> Pipe c m [x]))
+ -> Splitter m x b
+liftSplitter name maxThreads usingThreads = case usingThreads 1
+ of (configuration, split) -> Splitter name maxThreads configuration usingThreads split
--- | Function 'liftAtomicSectionSplitter' lifts a single-threaded 'splitSections' function into a full 'Splitter'
--- component.
-liftAtomicSectionSplitter :: forall m x. (ParallelizableMonad m, Typeable x) =>
- String -> Int -> (forall c. Source c x -> Sink c (Maybe x) -> Sink c (Maybe x) -> Pipe c m [x])
- -> Splitter m x
-liftAtomicSectionSplitter name cost splitSections = liftSectionSplitter name 1 $
- \_threads-> (ComponentConfiguration [] 1 cost, splitSections)
- where configuration = ComponentConfiguration [] 1 1
- usingThreads :: Int -> (ComponentConfiguration,
- forall c. Source c x -> Sink c x -> Sink c x -> Pipe c m [x],
- forall c. Source c x -> Sink c (Maybe x) -> Sink c (Maybe x) -> Pipe c m [x])
- usingThreads threads = (configuration, splitValues, splitSections)
- splitValues source true false
- = liftM (fst . fst) $
- pipeD "liftSectionSplitter true"
- (\true'-> pipeD "liftSectionSplitter false" (\false'-> splitSections source true' false') (strip false))
- (strip true)
--- strip sink source = transduce (liftStatelessTransducer (maybe [] (:[]))) source sink
- strip sink source = canPut sink
- >>= flip when (getSuccess source (\x-> maybe (return False) (put sink) x >> strip sink source))
+-- | Function 'liftAtomicSplitter' lifts a single-threaded 'split' function into a 'Splitter' component.
+liftAtomicSplitter :: forall m x b. (Monad m, Typeable x) =>
+ String -> Int -> (forall c. Source c x -> Sink c x -> Sink c x -> Sink c b -> Pipe c m [x])
+ -> Splitter m x b
+liftAtomicSplitter name cost split = liftSplitter name 1 (\_threads-> (ComponentConfiguration [] 1 cost, split))
-- | Function 'optimalTwoParallelConfigurations' configures two components, both of them with the full thread count, and
-- returns the components and a 'ComponentConfiguration' that can be used to build a new component from them.
@@ -426,3 +455,37 @@
optimalThreeParallelConfigurations :: (Component c1, Component c2, Component c3) =>
Int -> c1 -> c2 -> c3 -> (ComponentConfiguration, (c1, Bool), (c2, Bool), (c3, Bool))
optimalThreeParallelConfigurations threadCount c1 c2 c3 = undefined
+
+
+-- | 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.
+splitToConsumers :: forall c m x b r1 r2 r3. (ParallelizableMonad m, Typeable x, Typeable b)
+ => Splitter m x b -> Source c x -> (Source c x -> Pipe c m r1) -> (Source c x -> Pipe c m r2)
+ -> (Source c b -> Pipe c m r3) -> Pipe c m ([x], r1, r2, r3)
+splitToConsumers s source trueConsumer falseConsumer edgeConsumer
+ = pipe
+ (\true-> pipe
+ (\false-> pipe
+ (split s source true false)
+ edgeConsumer)
+ falseConsumer)
+ trueConsumer
+ >>= \(((extra, r3), r2), r1)-> return (extra, r1, r2, r3)
+
+-- | 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 c m x b r1 r2. (ParallelizableMonad m, Typeable x, Typeable b)
+ => Bool -> Splitter m x b -> Source c x -> (Source c x -> Pipe c m [x]) -> (Source c x -> Pipe c m [x])
+ -> Pipe c m [x]
+splitInputToConsumers parallel s source trueConsumer falseConsumer
+ = pipe'
+ (\false-> pipe'
+ (\true-> pipe
+ (split s source true false)
+ consumeAndSuppress)
+ trueConsumer)
+ falseConsumer
+ >>= \(((extra, _), xs1), xs2)-> return (prependCommonPrefix xs1 xs2 extra)
+ where pipe' = if parallel then pipeP else pipe
+ prependCommonPrefix (x:xs) (y:ys) tail = x : prependCommonPrefix xs ys tail
+ prependCommonPrefix _ _ tail = tail
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 Mario Blazevic
+ Copyright 2008-2009 Mario Blazevic
This file is part of the Streaming Component Combinators (SCC) project.
@@ -17,20 +17,23 @@
-- | Module "Components" defines primitive components of 'Producer', 'Consumer', 'Transducer' and 'Splitter' types,
-- defined in the "Foundation" and "ComponentTypes" modules.
-{-# LANGUAGE ScopedTypeVariables, Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables, Rank2Types, DeriveDataTypeable #-}
module Control.Concurrent.SCC.Components
- (-- * List producers and consumers
+ (
+ -- * Tag types
+ OccurenceTag,
+ -- * List producers and consumers
fromList, toList,
-- * I/O producers and consumers
fromFile, fromHandle, fromStdIn,
- appendFile, toFile, toHandle, toStdOut, toPrint,
+ appendFile, toFile, toHandle, toStdOut,
-- * Generic consumers
suppress, erroneous,
-- * Generic transducers
- asis,
+ asis, parse, unparse, parseSubstring,
-- * Generic splitters
- everything, nothing, one, substring, substringMatch,
+ everything, nothing, marked, markedContent, markedWith, contentMarkedWith, one, substring,
-- * List transducers
-- | The following laws hold:
--
@@ -46,23 +49,27 @@
)
where
+import Prelude hiding (appendFile, last)
+
import Control.Concurrent.SCC.Foundation
import Control.Concurrent.SCC.ComponentTypes
-import Prelude hiding (appendFile, last)
+import Control.Exception (assert)
+
import Control.Monad (liftM, when)
import qualified Control.Monad as Monad
import Data.Char (isAlpha, isDigit, isPrint, isSpace, toLower, toUpper)
-import Data.List (isPrefixOf, stripPrefix)
+import Data.List (delete, isPrefixOf, stripPrefix)
import Data.Maybe (fromJust)
import qualified Data.Foldable as Foldable
import qualified Data.Sequence as Seq
-import Data.Sequence (Seq, (|>), ViewL (EmptyL, (:<)))
+import Data.Sequence (Seq, (|>), (><), ViewL (EmptyL, (:<)))
import Data.Typeable (Typeable)
import Debug.Trace (trace)
import System.IO (Handle, IOMode (ReadMode, WriteMode, AppendMode), openFile, hClose,
hGetChar, hPutChar, hFlush, hIsEOF, hClose, putChar, isEOF, stdout)
+-- | The constant cost of each I/O-performing component.
ioCost :: Int
ioCost = 5
@@ -80,10 +87,6 @@
>>= maybe (return ()) (\x-> liftPipe (putChar x) >> c)
in c
-toPrint :: forall x. (Show x, Typeable x) => Consumer IO x ()
-toPrint = liftAtomicConsumer "toPrint" ioCost $ \source-> let c = getSuccess source (\x-> liftPipe (print x) >> c)
- in c
-
-- | Producer 'fromStdIn' feeds the given sink from the standard input.
fromStdIn :: Producer IO Char ()
fromStdIn = liftAtomicProducer "fromStdIn" ioCost $ \sink-> let p = do readyInput <- liftM not (liftPipe isEOF)
@@ -133,11 +136,21 @@
asis :: forall m x. (Monad m, Typeable x) => Transducer m x x
asis = lift121Transducer "asis" id
--- | The 'suppress' transducer suppresses all input it receives. It is equivalent to 'substitute' []
+-- | Transducer 'unparse' removes all markup from its input and passes the content through.
+unparse :: forall m x y. (Monad m, Typeable x, Typeable y) => Transducer m (Markup x y) x
+unparse = liftStatelessTransducer "unparse" removeTag
+ where removeTag (Content x) = [x]
+ removeTag _ = []
+
+-- | Transducer 'parse' prepares input content for subsequent parsing.
+parse :: forall m x y. (Monad m, Typeable x, Typeable y) => Transducer m x (Markup x y)
+parse = lift121Transducer "parse" Content
+
+-- | The 'suppress' consumer suppresses all input it receives. It is equivalent to 'substitute' []
suppress :: forall m x y. (Monad m, Typeable x) => Consumer m x ()
suppress = liftAtomicConsumer "suppress" 1 consumeAndSuppress
--- | The 'erroneous' transducer reports an error if any input reaches it.
+-- | The 'erroneous' consumer reports an error if any input reaches it.
erroneous :: forall m x. (Monad m, Typeable x) => String -> Consumer m x ()
erroneous message = liftAtomicConsumer "erroneous" 0 $ \source-> get source >>= maybe (return ()) (const (error message))
@@ -153,6 +166,7 @@
count :: forall m x. (Monad m, Typeable x) => Transducer m x Integer
count = liftFoldTransducer "count" (\count _-> succ count) 0 id
+-- | Converts each input value @x@ to @show x@.
toString :: forall m x. (Monad m, Show x, Typeable x) => Transducer m x String
toString = lift121Transducer "toString" show
@@ -164,117 +178,219 @@
concatenate :: forall m x. (Monad m, Typeable x) => Transducer m [x] x
concatenate = liftStatelessTransducer "concatenate" id
+-- | Same as 'concatenate' except it inserts the given separator list between every two input lists.
concatSeparate :: forall m x. (Monad m, Typeable x) => [x] -> Transducer m [x] x
concatSeparate separator = liftStatefulTransducer "concatSeparate"
(\seen list-> (True, if seen then separator ++ list else list))
False
-- | Splitter 'whitespace' feeds all white-space characters into its /true/ sink, all others into /false/.
-whitespace :: forall m. ParallelizableMonad m => Splitter m Char
+whitespace :: forall m. ParallelizableMonad m => Splitter m Char ()
whitespace = liftStatelessSplitter "whitespace" isSpace
-- | Splitter 'letters' feeds all alphabetical characters into its /true/ sink, all other characters into /false/.
-letters :: forall m. ParallelizableMonad m => Splitter m Char
+letters :: forall m. ParallelizableMonad m => Splitter m Char ()
letters = liftStatelessSplitter "letters" isAlpha
-- | Splitter 'digits' feeds all digits into its /true/ sink, all other characters into /false/.
-digits :: forall m. ParallelizableMonad m => Splitter m Char
+digits :: forall m. ParallelizableMonad m => Splitter m Char ()
digits = liftStatelessSplitter "digits" isDigit
-- | Splitter 'nonEmptyLine' feeds line-ends into its /false/ sink, and all other characters into /true/.
-nonEmptyLine :: forall m. ParallelizableMonad m => Splitter m Char
+nonEmptyLine :: forall m. ParallelizableMonad m => Splitter m Char ()
nonEmptyLine = liftStatelessSplitter "nonEmptyLine" (\ch-> ch /= '\n' && ch /= '\r')
-- | The sectioning splitter 'line' feeds line-ends into its /false/ sink, and line contents into /true/. A single
-- line-end can be formed by any of the character sequences \"\\n\", \"\\r\", \"\\r\\n\", or \"\\n\\r\".
-line :: forall m. ParallelizableMonad m => Splitter m Char
-line = liftAtomicSectionSplitter "line" 1 $
- \source true false-> let split0 = get source >>= maybe (return []) split1
- split1 x = if x == '\n' || x == '\r'
- then split2 x
- else lineChar x
- split2 x = put false (Just 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 (Just x)
- >>= cond
- (get source
- >>= maybe
- (return [])
- (\y-> if y == '\n' || y == '\r'
- then emptyLine y
- else lineChar y))
- (return [x])
- emptyLine x = put true Nothing >>= cond (split2 x) (return [])
- lineChar x = put true (Just x) >>= cond split0 (return [x])
- in split0
+line :: forall m. ParallelizableMonad m => Splitter m Char ()
+line = liftAtomicSplitter "line" 1 $
+ \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
-- | Splitter 'everything' feeds its entire input into its /true/ sink.
-everything :: forall m x. (ParallelizableMonad m, Typeable x) => Splitter m x
-everything = liftStatelessSplitter "everything" (const True)
+everything :: forall m x. (ParallelizableMonad m, Typeable x) => Splitter m x ()
+everything = liftAtomicSplitter "everything" 1 $
+ \source true false edge-> do put edge ()
+ pour source true
+ return []
-- | Splitter 'nothing' feeds its entire input into its /false/ sink.
-nothing :: forall m x. (ParallelizableMonad m, Typeable x) => Splitter m x
-nothing = liftStatelessSplitter "nothing" (const False)
+nothing :: forall m x. (ParallelizableMonad m, Typeable x) => Splitter m x ()
+nothing = liftAtomicSplitter "nothing" 1 $
+ \source true false edge-> do pour source false
+ return []
-- | Splitter 'one' feeds all input values to its /true/ sink, treating every value as a separate section.
-one :: forall m x. (ParallelizableMonad m, Typeable x) => Splitter m x
-one = liftAtomicSectionSplitter "one" 1 $
- \source true false-> let split x = put true (Just x)
- >>= cond (get source
- >>= maybe
- (return [])
- (\x-> put false Nothing >> split x))
- (return [x])
- in get source >>= maybe (return []) split
+one :: forall m x. (ParallelizableMonad m, Typeable x) => Splitter m x ()
+one = liftAtomicSplitter "one" 1 $
+ \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
--- | Splitter 'substring' feeds to its /true/ sink all input parts that match the contents of the given list
--- argument. If two overlapping parts of the input both match the argument, only the first one wins.
-substring :: forall m x. (ParallelizableMonad m, Eq x, Typeable x) => [x] -> Splitter m x
-substring = substringPrim "substring" False
+-- | Splitter 'marked' passes all marked-up input sections to its /true/ sink, and all unmarked input to its /false/
+-- sink.
+marked :: forall m x y. (ParallelizableMonad m, Typeable x, Typeable y, Eq y) => Splitter m (Markup x y) ()
+marked = markedWith (const True)
--- | Splitter 'substringMatch' feeds to its /true/ sink all input parts that match the contents of the given list
--- argument. If two overlapping parts of the input match the argument, both are considered /true/.
-substringMatch :: forall m x. (ParallelizableMonad m, Eq x, Typeable x) => [x] -> Splitter m x
-substringMatch = substringPrim "substringMatch" True
+-- | Splitter 'markedContent' passes the content of all marked-up input sections to its /true/ sink, while the outermost
+-- tags and all unmarked input go to its /false/ sink.
+markedContent :: forall m x y. (ParallelizableMonad m, Typeable x, Typeable y, Eq y) => Splitter m (Markup x y) ()
+markedContent = contentMarkedWith (const True)
-substringPrim name _ [] = liftAtomicSectionSplitter name 1 $
- \ source true false -> do put true Nothing
- rest <- splitSections one source false true
- put true Nothing
- return rest
-substringPrim name overlap list
- = liftAtomicSectionSplitter name 1 $
- \ source true false ->
- let getNext rest q separate = get source
- >>= maybe
- (liftM (map fromJust) $
- putList (map Just $ Foldable.toList (Seq.viewl q)) false)
- (\x-> do when separate (put false Nothing >> return ())
- advance rest q x)
- advance rest@(head:tail) q x = if x == head
- then if null tail
- then liftM (map fromJust) (putList (map Just list) true)
- >>= whenNull (if overlap
- then fallback True (Seq.drop 1 q)
- else getNext list Seq.empty True)
- else getNext tail (q |> x) False
- else fallback False (q |> x)
- fallback committed q = case stripPrefix (Foldable.toList (Seq.viewl q)) list
- of Just rest -> getNext rest q committed
- Nothing -> let view@(head :< tail) = Seq.viewl q
- in if committed
- then fallback committed tail
- else put false (Just head)
+-- | Splitter 'markedWith' passes input sections marked-up with the appropriate tag to its /true/ sink, and the rest of
+-- the input to its /false/ sink. The argument /select/ determines if the tag is appropriate.
+markedWith :: forall m x y. (ParallelizableMonad m, Typeable x, Typeable y, Eq y) => (y -> Bool) -> Splitter m (Markup x y) ()
+markedWith select = liftStatefulSplitter "markedWith" transition ([], False)
+ where transition s@([], _) Content{} = (s, False)
+ transition s@(_, truth) Content{} = (s, truth)
+ transition s@([], _) (Markup (Point y)) = (s, select y)
+ transition s@(_, truth) (Markup (Point y)) = (s, truth)
+ transition ([], _) (Markup (Start y)) = (([y], select y), select y)
+ transition (open, truth) (Markup (Start y)) = ((y:open, truth), truth)
+ transition (open, truth) (Markup (End y)) = assert (elem y open) ((delete y open, truth), truth)
+
+-- | Splitter 'contentMarkedWith' passes the content of input sections marked-up with the appropriate tag to its /true/
+-- sink, and the rest of the input to its /false/ sink. The argument /select/ determines if the tag is appropriate.
+contentMarkedWith :: forall m x y. (ParallelizableMonad m, Typeable x, Typeable y, Eq y)
+ => (y -> Bool) -> Splitter m (Markup x y) ()
+contentMarkedWith select = liftStatefulSplitter "markedWith" transition ([], False)
+ where transition s@(_, truth) Content{} = (s, truth)
+ transition s@(_, truth) (Markup Point{}) = (s, truth)
+ transition ([], _) (Markup (Start y)) = (([y], select y), False)
+ transition (open, truth) (Markup (Start y)) = ((y:open, truth), truth)
+ transition (open, truth) (Markup (End y)) = assert (elem y open) (let open' = delete y open
+ truth' = not (null open') && truth
+ in ((open', truth'), truth'))
+
+-- | Used by 'parseSubstring' to distinguish between overlapping substrings.
+data OccurenceTag = Occurence Int deriving (Eq, Show, Typeable)
+
+instance Enum OccurenceTag where
+ succ (Occurence n) = Occurence (succ n)
+ pred (Occurence n) = Occurence (pred n)
+ toEnum = Occurence
+ fromEnum (Occurence n) = n
+
+-- | 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. (ParallelizableMonad m, Eq x, Typeable x) => [x] -> Parser m x OccurenceTag
+parseSubstring [] = liftAtomicTransducer "parseSubstring" 1 $
+ \ 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 list
+ = liftAtomicTransducer "parseSubstring" 1 $
+ \ source sink ->
+ let getNext id rest q = get source
+ >>= maybe
+ (flush q)
+ (advance id rest q)
+ advance id rest@(head:tail) q x = let q' = q |> Content x
+ view@(qh@Content{} :< qt) = Seq.viewl q'
+ id' = succ id
+ 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')
+ 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)
+ 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
+ remainingContent :: Seq (Markup x OccurenceTag) -> [x]
+ remainingContent q = extractContent (Seq.viewl q)
+ extractContent :: Foldable.Foldable f => f (Markup x b) -> [x]
+ extractContent = Foldable.concatMap (\e-> case e of {Content x -> [x]; _ -> []})
+ in getNext 0 list Seq.empty
+
+-- | Splitter 'substring' feeds to its /true/ sink all input parts that match the contents of the given list
+-- 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. (ParallelizableMonad m, Eq x, Typeable x) => [x] -> Splitter m x ()
+substring [] = liftAtomicSplitter "substring" 1 $
+ \ source true false edge -> do rest <- split one source false true edge
+ put edge ()
+ return rest
+substring list
+ = liftAtomicSplitter "substring" 1 $
+ \ source true false edge ->
+ let getNext rest qt qf = get source
+ >>= maybe
+ (putList (Foldable.toList (Seq.viewl qt)) true
+ >> putList (Foldable.toList (Seq.viewl qf)) false)
+ (advance rest qt qf)
+ advance rest@(head:tail) qt qf x = let qf' = qf |> x
+ view@(qqh :< qqt) = Seq.viewl (qt >< qf')
+ in if x == head
+ then if null tail
+ then put edge ()
+ >> put true qqh
>>= cond
- (fallback committed tail)
- (return (Foldable.toList view))
- in getNext list Seq.empty False
+ (fallback qqt Seq.empty)
+ (return $ Foldable.toList view)
+ else getNext tail qt qf'
+ else fallback qt qf'
+ fallback qt qf = case Seq.viewl (qt >< qf)
+ of EmptyL -> getNext list Seq.empty Seq.empty
+ view@(head :< tail) -> case stripPrefix (Foldable.toList view) list
+ 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)
+ else put true head
+ >>= cond
+ (fallback (Seq.drop 1 qt) qf)
+ (return $ Foldable.toList view)
+ in getNext list Seq.empty Seq.empty
diff --git a/Control/Concurrent/SCC/Foundation.hs b/Control/Concurrent/SCC/Foundation.hs
--- a/Control/Concurrent/SCC/Foundation.hs
+++ b/Control/Concurrent/SCC/Foundation.hs
@@ -1,5 +1,5 @@
{-
- Copyright 2008 Mario Blazevic
+ Copyright 2008-2009 Mario Blazevic
This file is part of the Streaming Component Combinators (SCC) project.
@@ -24,10 +24,10 @@
-- * Types
Pipe, Source, Sink,
-- * Flow-control functions
- pipe, pipeD, pipeP, get, getSuccess, canPut, put,
+ pipe, pipeD, pipeP, get, getSuccess, get', canPut, put,
liftPipe, runPipes,
-- * Utility functions
- cond, whenNull, pour, tee, getList, putList, consumeAndSuppress)
+ cond, whenNull, pour, pourMap, pourMapMaybe, tee, getList, putList, putQueue, consumeAndSuppress)
where
import Control.Concurrent (forkIO)
@@ -36,7 +36,10 @@
import Control.Monad (liftM, liftM2, when)
import Control.Monad.Identity
import Control.Parallel (par, pseq)
+
+import Data.Foldable (toList)
import Data.Maybe (maybe)
+import Data.Sequence (Seq, viewl)
import Data.Typeable (Typeable, cast)
import Debug.Trace (trace)
@@ -253,6 +256,11 @@
-> Pipe context 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 context x m r. (Monad m, Typeable x) => Source context x -> Pipe context m x
+get' source = get source >>= maybe (error "get' failed") return
+
-- | Function 'put' tries to put a value into the given sink. The intervening 'Pipe' computations suspend up to the
-- 'pipe' invocation that has created the argument sink. The result of 'put' indicates whether the operation succeded.
put :: forall context x m r. (Monad m, Typeable x) => Sink context x -> x -> Pipe context m Bool
@@ -279,15 +287,24 @@
pour source sink = fill'
where fill' = canPut sink >>= flip when (getSuccess source (\x-> put sink x >> fill'))
+-- | 'pourMap' is like 'pour' that applies the function /f/ to each argument before passing it into the /sink/.
+pourMap :: forall c x y m. (Monad m, Typeable x, Typeable y) => (x -> y) -> Source c x -> Sink c y -> Pipe c m ()
+pourMap f source sink = loop
+ where loop = canPut sink >>= flip when (get source >>= maybe (return ()) (\x-> put sink (f x) >> loop))
+
+-- | 'pourMapMaybe' is to 'pourMap' like 'Data.Maybe.mapMaybe' is to 'Data.List.Map'.
+pourMapMaybe :: forall c x y m. (Monad m, Typeable x, Typeable y) => (x -> Maybe y) -> Source c x -> Sink c y -> Pipe c 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))
+
-- | 'tee' is similar to 'pour' except it distributes every input value from the /source/ arguments into both /sink1/
-- and /sink2/.
-tee :: (Monad m, Typeable x) => Source c x -> Sink c x -> Sink c x -> Pipe c m [x]
+tee :: (Monad m, Typeable x) => Source c x -> Sink c x -> Sink c x -> Pipe c m ()
tee source sink1 sink2 = distribute
where distribute = do c1 <- canPut sink1
c2 <- canPut sink2
- if c1 && c2
- then get source >>= maybe (return []) (\x-> put sink1 x >> put sink2 x >> distribute)
- else getList source
+ when (c1 && c2)
+ (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.
@@ -301,7 +318,8 @@
-- | 'consumeAndSuppress' consumes the entire source ignoring the values it generates.
consumeAndSuppress :: forall x c m. (Monad m, Typeable x) => Source c x -> Pipe c m ()
-consumeAndSuppress source = getSuccess source (\x-> consumeAndSuppress source)
+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
@@ -313,3 +331,7 @@
track :: String -> Bool
track message = True
+
+-- | Like 'putList', except it puts the contents of the given 'Data.Sequence.Seq' into the sink.
+putQueue :: forall c m x. (Monad m, Typeable x) => Seq x -> Sink c x -> Pipe c m [x]
+putQueue q sink = putList (toList (viewl q)) sink
diff --git a/Control/Concurrent/SCC/XMLComponents.hs b/Control/Concurrent/SCC/XMLComponents.hs
new file mode 100644
--- /dev/null
+++ b/Control/Concurrent/SCC/XMLComponents.hs
@@ -0,0 +1,528 @@
+{-
+ Copyright 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
+ .
+-}
+
+-- | Module "XMLComponents" defines primitive components for parsing and manipulating XML.
+
+{-# LANGUAGE DeriveDataTypeable, PatternGuards #-}
+
+module Control.Concurrent.SCC.XMLComponents (
+-- * Types
+Token (..),
+-- * Parsing XML
+tokens, parseTokens, expandEntity,
+-- * Showing XML
+escapeAttributeCharacter, escapeContentCharacter,
+-- * Splitters
+element, elementContent, elementName, attribute, attributeName, attributeValue,
+-- * Splitter combinators
+elementHavingTag, havingText, havingOnlyText
+)
+where
+
+import Control.Exception (assert)
+import Control.Monad (liftM, when)
+import Data.Char
+import Data.Dynamic (Typeable)
+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 Numeric (readDec, readHex)
+import Debug.Trace (trace)
+
+import Control.Concurrent.SCC.Foundation
+import Control.Concurrent.SCC.ComponentTypes
+import Control.Concurrent.SCC.Components (unparse)
+import Control.Concurrent.SCC.Combinators ((>->), groupMarks, having, havingOnly, parseNestedRegions, splitterToMarker)
+
+
+data Token = StartTag | EndTag | EmptyTag
+ | ElementName | AttributeName | AttributeValue
+ | EntityReferenceToken | EntityName
+ | ProcessingInstruction | ProcessingInstructionText
+ | Comment | CommentText
+ | StartMarkedSectionCDATA | EndMarkedSection
+ | ErrorToken String
+ deriving (Eq, Show, Typeable)
+
+-- | Escapes a character for inclusion into an XML attribute value.
+escapeAttributeCharacter :: Char -> String
+escapeAttributeCharacter '"' = """
+escapeAttributeCharacter '\t' = " "
+escapeAttributeCharacter '\n' = "
"
+escapeAttributeCharacter '\r' = "
"
+escapeAttributeCharacter x = escapeContentCharacter x
+
+-- | Escapes a character for inclusion into the XML data content.
+escapeContentCharacter :: Char -> String
+escapeContentCharacter '<' = "<"
+escapeContentCharacter '&' = "&"
+escapeContentCharacter x = [x]
+
+-- | Converts an XML entity name into the text value it represents: @expandEntity \"lt\" = \"<\"@.
+expandEntity :: String -> String
+expandEntity "lt" = "<"
+expandEntity "gt" = ">"
+expandEntity "quot" = "\""
+expandEntity "apos" = "'"
+expandEntity "amp" = "&"
+expandEntity ('#' : 'x' : codePoint) = [chr (fst $ head $ readHex codePoint)]
+expandEntity ('#' : codePoint) = [chr (fst $ head $ readDec codePoint)]
+
+isNameStart x = isLetter x || x == '_'
+isNameChar x = isAlphaNum x || x == '_' || x == '-'
+
+-- | The 'tokens' splitter distinguishes XML markup from data content. It is used by 'parseTokens'.
+tokens :: (ParallelizableMonad m) => Splitter m Char (Boundary Token)
+tokens = liftAtomicSplitter "XML.tokens" 1 $
+ \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
+ content x = put false x
+ >>= cond getContent (return [x])
+ tag '?' = put edge (Start ProcessingInstruction)
+ >> putList ">= whenNull (put edge (Start ProcessingInstructionText)
+ >> processingInstruction)
+ tag '!' = dispatchOnString source
+ (\other-> put edge (Point (ErrorToken ("Expecting > return (" put edge (Start Comment)
+ >> putList match true
+ >>= whenNull (put edge (Start CommentText)
+ >> comment)),
+ ("[CDATA[",
+ \match-> put edge (Start StartMarkedSectionCDATA)
+ >> putList match true
+ >>= whenNull (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 ())
+ 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
+ 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 []
+ attributes x | isSpace x = put true x >> next 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
+ 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
+ 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."))
+ 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)
+ processingInstruction = {-# SCC "PI" #-}
+ dispatchOnString source
+ (\other-> if null other
+ then (put edge (Point (ErrorToken "Unterminated processing instruction"))
+ >> return [])
+ else putList other true >>= whenNull processingInstruction)
+ [("?>",
+ \match-> put edge (End ProcessingInstructionText)
+ >> putList match true
+ >>= whenNull (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)
+ [("-->",
+ \match-> put edge (End CommentText)
+ >> putList match true
+ >>= whenNull (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)
+ [("]]>",
+ \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
+ 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
+ in getContent
+
+-- | The XML token parser. This parser converts plain text to parsed text, which is a precondition for using the
+-- remaining XML components.
+parseTokens :: (ParallelizableMonad m) => Parser m Char Token
+parseTokens = parseNestedRegions tokens
+
+dispatchOnString :: Monad m => Source c Char -> (String -> Pipe c m r) -> [(String, String -> Pipe c m r)] -> Pipe c m r
+dispatchOnString source failure fullCases = dispatch fullCases id
+ where dispatch cases consumed
+ = case find (null . fst) cases
+ of Just ("", rhs) -> rhs (consumed "")
+ Nothing -> get source
+ >>= maybe
+ (failure (consumed ""))
+ (\x-> case mapMaybe (startingWith x) cases
+ of [] -> failure (consumed [x])
+ subcases -> dispatch (subcases ++ fullCases) (consumed . (x :)))
+ startingWith x (y:rest, rhs) | x == y = Just (rest, rhs)
+ | otherwise = Nothing
+
+getElementName :: Monad m => Source c (Markup Char Token) -> ([Markup Char Token] -> [Markup Char Token])
+ -> Pipe c m ([Markup Char Token], Maybe String)
+getElementName source f = get source
+ >>= maybe
+ (return (f [], Nothing))
+ (\x-> case x of Markup (Start ElementName) -> getRestOfRegion ElementName source (f . (x:)) id
+ Markup (Point ErrorToken{}) -> getElementName source (f . (x:))
+ Content{} -> getElementName source (f . (x:))
+ _ -> error ("Expected an ElementName, received " ++ show x))
+
+getRestOfRegion :: Monad m => Token -> Source c (Markup Char Token)
+ -> ([Markup Char Token] -> [Markup Char Token]) -> (String -> String)
+ -> Pipe c m ([Markup Char Token], Maybe String)
+getRestOfRegion token source f g = get source
+ >>= maybe
+ (return (f [], Nothing))
+ (\x-> case x of Markup (End token) -> return (f [x], Just (g ""))
+ Content y -> getRestOfRegion token source (f . (x:)) (g . (y:))
+ _ -> error ("Expected rest of " ++ show token ++ ", received " ++ show x))
+
+pourRestOfRegion :: Monad m
+ => Token -> Source c (Markup Char Token) -> Sink c (Markup Char Token) -> Sink c (Markup Char Token)
+ -> Pipe c m (Maybe [Markup Char Token])
+pourRestOfRegion token source sink endSink
+ = get source
+ >>= maybe
+ (return $ Just [])
+ (\x-> case x
+ of Markup (End token') | token == token' -> put endSink x
+ >>= cond (return Nothing) (return $ Just [x])
+ Content y -> put sink x
+ >>= cond (pourRestOfRegion token source sink endSink) (return $ Just [x])
+ _ -> error ("Expected rest of " ++ show token ++ ", received " ++ show x))
+
+pourRestOfTag :: Monad m => Source c (Markup Char Token) -> Sink c (Markup Char Token) -> Pipe c m Bool
+pourRestOfTag source sink = get source
+ >>= maybe
+ (return True)
+ (\x-> put sink x
+ >> case x of Markup (End StartTag) -> return True
+ Markup (End EndTag) -> return True
+ Markup (Point EmptyTag) -> pourRestOfTag source sink >> return False
+ _ -> pourRestOfTag source sink)
+
+findEndTag :: Monad m => Source c (Markup Char Token) -> Sink c (Markup Char Token) -> Sink c (Markup Char Token) -> String
+ -> Pipe c m [Markup Char Token]
+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]))
+
+findStartTag :: Monad m => Source c (Markup Char Token) -> Sink c (Markup Char Token)
+ -> Pipe c m (Either [Markup Char Token] (Markup Char Token))
+findStartTag source sink = get source
+ >>= maybe
+ (return $ Left [])
+ (\x-> case x of Markup (Start StartTag) -> return $ Right x
+ _ -> put sink x
+ >>= cond (findStartTag source sink) (return $ Left [x]))
+
+-- | Splits all top-level elements with all their content to /true/, all other input to /false/.
+element :: (Monad m) => Splitter m (Markup Char Token) ()
+element = liftAtomicSplitter "element" 1 $
+ \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]))
+ split1 name = findEndTag source true true name
+ >>= whenNull split0
+ in split0
+
+-- | Splits the content of all top-level elements to /true/, their tags and intervening input to /false/.
+elementContent :: (Monad m) => Splitter m (Markup Char Token) ()
+elementContent = liftAtomicSplitter "elementContent" 1 $
+ \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]))
+ split1 name = findEndTag source true false name
+ >>= whenNull 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 :: (ParallelizableMonad m, Typeable b)
+ => Splitter m (Markup Char Token) b -> Splitter m (Markup Char Token) b
+elementHavingTag test
+ = liftSplitter "elementHavingTag" (maxUsableThreads test) $
+ \threads-> let test' = usingThreads threads test
+ configuration = ComponentConfiguration [AnyComponent test'] threads (cost test' + 2)
+ split source true false edge = split0 where
+ split0 = findStartTag source false
+ >>= either return
+ (\x-> do (tokens, mn) <- getElementName source (x :)
+ maybe
+ (return tokens)
+ (\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))
+ mn)
+ split1 hasContent sink name = if hasContent
+ then findEndTag source sink sink name >>= whenNull split0
+ else split0
+ in (configuration, split)
+
+-- | Splits every attribute specification to /true/, everything else to /false/.
+attribute :: (ParallelizableMonad m) => Splitter m (Markup Char Token) ()
+attribute = liftAtomicSplitter "attribute" 1 $
+ \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]))
+ in split0
+
+-- | Splits every element name, including the names of nested elements and names in end tags, to /true/, all the rest of
+-- input to /false/.
+elementName :: (ParallelizableMonad m) => Splitter m (Markup Char Token) ()
+elementName = liftAtomicSplitter "elementName" 1 (splitSimpleRegions ElementName)
+
+-- | Splits every attribute name to /true/, all the rest of input to /false/.
+attributeName :: (ParallelizableMonad m) => Splitter m (Markup Char Token) ()
+attributeName = liftAtomicSplitter "attributeName" 1 (splitSimpleRegions AttributeName)
+
+-- | Splits every attribute value, excluding the quote delimiters, to /true/, all the rest of input to /false/.
+attributeValue :: (ParallelizableMonad m) => Splitter m (Markup Char Token) ()
+attributeValue = liftAtomicSplitter "attributeValue" 1 (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]))
+
+-- | 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 :: (ParallelizableMonad m, Typeable b1, Typeable b2)
+ => Splitter m (Markup Char Token) b1 -> Splitter m Char b2 -> Splitter m (Markup Char Token) b1
+havingText chunker tester
+ = liftSplitter "havingText" (maxUsableThreads chunker + maxUsableThreads tester) $
+ \threads-> let (configuration, chunker', tester', parallel) = optimalTwoParallelConfigurations threads chunker tester
+ split source true false edge
+ = liftM fst $
+ (if parallel then pipeP else pipe)
+ (transduce (splitterToMarker chunker') source)
+ (flip groupMarks test)
+ where 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 (configuration, split)
+
+-- | 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 :: (ParallelizableMonad m, Typeable b1, Typeable b2)
+ => Splitter m (Markup Char Token) b1 -> Splitter m Char b2 -> Splitter m (Markup Char Token) b1
+havingOnlyText chunker tester
+ = liftSplitter "havingOnlyText" (maxUsableThreads chunker + maxUsableThreads tester) $
+ \threads-> let (configuration, chunker', tester', parallel) = optimalTwoParallelConfigurations threads chunker tester
+ split source true false edge
+ = liftM fst $
+ (if parallel then pipeP else pipe)
+ (transduce (splitterToMarker chunker') source)
+ (flip groupMarks test)
+ where 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 (configuration, split)
diff --git a/Makefile b/Makefile
--- a/Makefile
+++ b/Makefile
@@ -1,27 +1,31 @@
-LibraryFiles=$(addprefix Control/Concurrent/SCC/, Foundation.hs ComponentTypes.hs Components.hs Combinators.hs)
+Executables=test test-prof shsh shsh-prof
+LibraryFiles=$(addprefix Control/Concurrent/SCC/, \
+ Foundation.hs ComponentTypes.hs Combinators.hs Components.hs XMLComponents.hs)
DocumentationFiles=$(LibraryFiles)
-CommonOptions=-hidir obj -odir obj
+OptimizingOptions=-O2 -threaded -hidir obj -odir obj
+ProfilingOptions=-prof -auto-all -hidir prof -odir prof
-all: test test-prof shsh shsh-prof docs
+all: $(Executables) doc/index.html
+
docs: doc/index.html
test: $(LibraryFiles) Test.hs | obj
- ghc --make Test.hs -O2 -threaded -o test $(CommonOptions)
+ ghc --make Test.hs -o test $(OptimizingOptions)
-test-prof: $(LibraryFiles) Test.hs | obj
- ghc --make Test.hs -o test-prof -prof -auto-all $(CommonOptions)
+test-prof: $(LibraryFiles) Test.hs | prof
+ ghc --make Test.hs -o test-prof $(ProfilingOptions)
shsh: $(LibraryFiles) Shell.hs | obj
- ghc --make Shell.hs -O2 -threaded -o shsh $(CommonOptions)
+ ghc --make Shell.hs -o shsh $(OptimizingOptions)
-shsh-prof: $(LibraryFiles) Shell.hs | obj
- ghc --make Shell.hs -o shsh-prof -prof -auto-all $(CommonOptions)
+shsh-prof: $(LibraryFiles) Shell.hs | prof
+ ghc --make Shell.hs -o shsh-prof $(ProfilingOptions)
doc/index.html: $(DocumentationFiles)
haddock -h -o doc $^
-obj:
+obj prof:
mkdir -p $@
clean:
- rm -r obj/* prof/* doc/*
+ rm -r obj/* prof/* doc/* $(Executables)
diff --git a/Shell.hs b/Shell.hs
--- a/Shell.hs
+++ b/Shell.hs
@@ -14,20 +14,22 @@
.
-}
-{-# LANGUAGE ScopedTypeVariables, Rank2Types, GADTs, FlexibleContexts, PatternSignatures #-}
+{-# LANGUAGE ScopedTypeVariables, Rank2Types, GADTs, FlexibleContexts #-}
module Main where
-import Prelude hiding ((&&), (||), appendFile, interact, last, sequence)
-import qualified Prelude
+import Prelude hiding (appendFile, interact, last, sequence)
import Data.List (intersperse, partition)
+import Data.Char (isAlphaNum)
import Data.Maybe (fromJust)
-import Data.Typeable (Typeable)
+import Data.Typeable (Typeable, Typeable1, Typeable2)
import Control.Concurrent (forkIO)
import Control.Exception (evaluate)
import Control.Monad (liftM, when)
-import Text.Parsec hiding (count)
-import Text.Parsec.String
+import qualified Text.Parsec as Parsec
+import qualified Text.Parsec.String as Parsec
+import Text.Parsec hiding (count, parse)
+import Text.Parsec.String hiding (Parser)
import Text.Parsec.Language (emptyDef)
import Text.Parsec.Token
import System.Console.GetOpt
@@ -43,8 +45,10 @@
import Control.Concurrent.SCC.Foundation
import Control.Concurrent.SCC.ComponentTypes
+import Control.Concurrent.SCC.Combinators hiding ((&&), (||))
+import qualified Control.Concurrent.SCC.Combinators as Combinators
import Control.Concurrent.SCC.Components
-import Control.Concurrent.SCC.Combinators
+import qualified Control.Concurrent.SCC.XMLComponents as XML
data Expression where
-- Compiled expressions
@@ -71,10 +75,12 @@
-- Transducer constructs
Select :: Expression -> Expression
While :: Expression -> Expression -> Expression
+ ExecuteTransducer :: Expression
IdentityTransducer :: Expression
Count :: Expression
Concatenate :: Expression
Group :: Expression
+ Unparse :: Expression
Uppercase :: Expression
ShowTransducer :: Expression
-- Splitter constructs
@@ -84,6 +90,7 @@
LineSplitter :: Expression
LetterSplitter :: Expression
DigitSplitter :: Expression
+ MarkedSplitter :: Expression
OneSplitter :: Expression
SubstringSplitter :: String -> Expression
And :: Expression -> Expression -> Expression
@@ -105,6 +112,17 @@
Substitute :: Expression -> Expression
StartOf :: Expression -> Expression
EndOf :: Expression -> Expression
+ -- XML Components
+ XMLTokenParser :: Expression
+ XMLAttribute :: Expression
+ XMLAttributeName :: Expression
+ XMLAttributeValue :: Expression
+ XMLElement :: Expression
+ XMLElementContent :: Expression
+ XMLElementName :: Expression
+ XMLElementHavingTag :: Expression -> Expression
+ XMLHavingText :: Expression -> Expression -> Expression
+ XMLHavingOnlyText :: Expression -> Expression -> Expression
instance Show Expression where
showsPrec _ (Compiled tag c) rest = "compiled " ++ shows tag rest
@@ -147,10 +165,12 @@
showsPrec p (Substitute s) rest | p < 4 = "substitute " ++ showsPrec 4 s rest
showsPrec p (StartOf s) rest | p < 4 = "start-of " ++ showsPrec 4 s rest
showsPrec p (EndOf s) rest | p < 4 = "end-of " ++ showsPrec 4 s rest
+ showsPrec _ ExecuteTransducer rest = "execute" ++ rest
showsPrec _ IdentityTransducer rest = "id" ++ rest
showsPrec _ Count rest = "count" ++ rest
showsPrec _ Concatenate rest = "concatenate" ++ rest
showsPrec _ Group rest = "group" ++ rest
+ showsPrec _ Unparse rest = "unparse" ++ rest
showsPrec _ Uppercase rest = "uppercase" ++ rest
showsPrec _ ShowTransducer rest = "show" ++ rest
showsPrec _ EverythingSplitter rest = "everything" ++ rest
@@ -159,8 +179,19 @@
showsPrec _ LineSplitter rest = "line" ++ rest
showsPrec _ LetterSplitter rest = "letters" ++ rest
showsPrec _ DigitSplitter rest = "digits" ++ rest
+ showsPrec _ MarkedSplitter rest = "marked" ++ rest
showsPrec _ OneSplitter rest = "one" ++ rest
- showsPrec _ (SubstringSplitter s) rest = "substring " ++ shows s rest
+ showsPrec _ (SubstringSplitter s) rest = "substring " ++ shows s (' ' : rest)
+ showsPrec _ XMLTokenParser rest = "XML.parse" ++ rest
+ showsPrec _ XMLElement rest = "XML.element" ++ rest
+ showsPrec _ XMLAttribute rest = "XML.attribute" ++ rest
+ showsPrec _ XMLAttributeName rest = "XML.attribute-name" ++ rest
+ showsPrec _ XMLAttributeValue rest = "XML.attribute-value" ++ rest
+ showsPrec _ XMLElementContent rest = "XML.element-content" ++ rest
+ showsPrec _ XMLElementName rest = "XML.element-name" ++ rest
+ showsPrec p (XMLElementHavingTag s) rest = "XML.element-having-tag " ++ showsPrec 4 s (' ' : rest)
+ showsPrec p (XMLHavingText s1 s2) rest = showsPrec 4 s1 (" XML.having-text " ++ showsPrec 4 s2 rest)
+ showsPrec p (XMLHavingOnlyText s1 s2) rest = showsPrec 4 s1 (" XML.having-only-text " ++ showsPrec 4 s2 rest)
showsPrec _ (TypeError tag1 tag2 e) rest = ("Type error: expecting " ++ show tag2 ++ ", received " ++ show tag1
++ "\nin expression " ++ showsPrec 9 e rest)
showsPrec p e rest | p > 0 = "(" ++ showsPrec 0 e (')' : rest)
@@ -172,13 +203,18 @@
ShowableTag :: (Typeable x, Show x) => TypeTag x
CharTag :: TypeTag Char
IntTag :: TypeTag Integer
+ XMLTokenTag :: TypeTag XML.Token
+ EitherTag :: TypeTag x -> TypeTag y -> TypeTag (Either x y)
ListTag :: Typeable x => TypeTag x -> TypeTag [x]
+ MaybeTag :: Typeable x => TypeTag x -> TypeTag (Maybe x)
PairTag :: TypeTag x -> TypeTag y -> TypeTag (x, y)
+ MarkupTag :: (Typeable x, Typeable y) => TypeTag x -> TypeTag y -> TypeTag (Markup x y)
+
-- Streaming component type tags
CommandTag :: TypeTag (Performer IO ())
ConsumerTag :: Typeable x => TypeTag x -> TypeTag (Consumer IO x ())
ProducerTag :: Typeable x => TypeTag x -> TypeTag (Producer IO x ())
- SplitterTag :: Typeable x => TypeTag x -> TypeTag (Splitter IO x)
+ SplitterTag :: forall x b. (Typeable x, Typeable b) => TypeTag x -> TypeTag b -> TypeTag (Splitter IO x b)
TransducerTag :: (Typeable x, Typeable y) => TypeTag x -> TypeTag y -> TypeTag (Transducer IO x y)
GenericInputTag :: forall x y. (Typeable x, Typeable y) => (TypeTag x -> TypeTag y) -> TypeTag y
@@ -187,12 +223,16 @@
show UnitTag = "()"
show CharTag = "Char"
show IntTag = "Int"
+ show XMLTokenTag = "XML.Token"
show (ListTag x) = '[' : shows x "]"
+ show (MaybeTag x) = "Maybe " ++ show x
+ show (EitherTag x y) = "Either " ++ shows x (" " ++ show y)
+ show (MarkupTag x y) = "Markup " ++ shows x (" " ++ show y)
show (PairTag x y) = "(" ++ shows x (", " ++ shows y ")")
show CommandTag = "Command"
show (ConsumerTag x) = "Consumer " ++ show x
show (ProducerTag x) = "Producer " ++ show x
- show (SplitterTag x) = "Splitter " ++ show x
+ show (SplitterTag x b) = "Splitter " ++ shows x (" " ++ show b)
show (TransducerTag x y) = "Transducer " ++ shows x (" -> " ++ show y)
show GenericInputTag{} = "Generic"
@@ -200,36 +240,57 @@
data CConsumer c x = CConsumer (c (Consumer IO x ()))
data CProducer c x = CProducer (c (Producer IO x ()))
-data CSplitter c x = CSplitter (c (Splitter IO x))
data CList c a = CList (c [a])
+data CMaybe c a = CMaybe (c (Maybe a))
data CFlip c b a = CFlip (c a b)
+data CEL c a d = CEL (c (Either d a))
+data CER c a d = CER (c (Either a d))
+data CML c a d = CML (c (Markup d a))
+data CMR c a d = CMR (c (Markup a d))
data CL c a d = CL (c (d,a))
data CR c a d = CR (c (a,d))
data CTL c a d = CTL (c (Transducer IO d a))
data CTR c a d = CTR (c (Transducer IO a d))
+data CSL c a d = CSL (c (Splitter IO d a))
+data CSR c a d = CSR (c (Splitter IO a d))
typecast :: forall a b c. TypeTag a -> TypeTag b -> c a -> Maybe (c b)
typecast UnitTag UnitTag x = Just x
typecast CharTag CharTag x = Just x
typecast IntTag IntTag x = Just x
+typecast XMLTokenTag XMLTokenTag x = Just x
typecast (ListTag a) (ListTag b) x = fmap (\(CList y)-> y) (typecast a b (CList x))
+typecast (MaybeTag a) (MaybeTag b) x = fmap (\(CMaybe y)-> y) (typecast a b (CMaybe x))
+typecast (EitherTag (ra::TypeTag a0) (rb::TypeTag b0)) (EitherTag (ra'::TypeTag a0') (rb'::TypeTag b0')) x =
+ let g = (typecast ra ra' :: (CEL c b0) a0 -> Maybe ((CEL c b0) a0'))
+ h = (typecast rb rb' :: (CER c a0') b0 -> Maybe ((CER c a0') b0'))
+ in case g (CEL x) of Just (CEL x') -> case h (CER x') of Just (CER y') -> Just y'
+ Nothing -> Nothing
+typecast (MarkupTag (ra::TypeTag a0) (rb::TypeTag b0)) (MarkupTag (ra'::TypeTag a0') (rb'::TypeTag b0')) x =
+ let g = (typecast ra ra' :: (CML c b0) a0 -> Maybe ((CML c b0) a0'))
+ h = (typecast rb rb' :: (CMR c a0') b0 -> Maybe ((CMR c a0') b0'))
+ in case g (CML x) of Just (CML x') -> case h (CMR x') of Just (CMR y') -> Just y'
+ Nothing -> Nothing
typecast (PairTag (ra::TypeTag a0) (rb::TypeTag b0)) (PairTag (ra'::TypeTag a0') (rb'::TypeTag b0')) x =
let g = (typecast ra ra' :: (CL c b0) a0 -> Maybe ((CL c b0) a0'))
h = (typecast rb rb' :: (CR c a0') b0 -> Maybe ((CR c a0') b0'))
- in case g (CL x)
- of Just (CL x') -> case h (CR x')
- of Just (CR y') -> Just y'
+ in case g (CL x) of Just (CL x') -> case h (CR x') of Just (CR y') -> Just y'
+ Nothing -> Nothing
typecast CommandTag CommandTag x = Just x
typecast (ConsumerTag a) (ConsumerTag b) x = fmap (\(CConsumer y)-> y) (typecast a b (CConsumer x))
typecast (ProducerTag a) (ProducerTag b) x = fmap (\(CProducer y)-> y) (typecast a b (CProducer x))
-typecast (SplitterTag a) (SplitterTag b) x = fmap (\(CSplitter y)-> y) (typecast a b (CSplitter x))
typecast (TransducerTag (ra::TypeTag a0) (rb::TypeTag b0)) (TransducerTag (ra'::TypeTag a0') (rb'::TypeTag b0')) x
= let g = (typecast ra ra' :: (CTL c b0) a0 -> Maybe ((CTL c b0) a0'))
h = (typecast rb rb' :: (CTR c a0') b0 -> Maybe ((CTR c a0') b0'))
- in case g (CTL x)
- of Just (CTL x') -> case h (CTR x')
- of Just (CTR y') -> Just y'
+ in case g (CTL x) of Nothing -> Nothing
+ Just (CTL x') -> case h (CTR x') of Nothing -> Nothing
+ Just (CTR y') -> Just y'
+typecast (SplitterTag (ra::TypeTag a0) (rb::TypeTag b0)) (SplitterTag (ra'::TypeTag a0') (rb'::TypeTag b0')) x
+ = let g = (typecast ra ra' :: (CSL c b0) a0 -> Maybe ((CSL c b0) a0'))
+ h = (typecast rb rb' :: (CSR c a0') b0 -> Maybe ((CSR c a0') b0'))
+ in case g (CSL x) of Just (CSL x') -> case h (CSR x') of Just (CSR y') -> Just y'
+ Nothing -> Nothing
typecast _ _ _ = Nothing
trycast :: forall a b. TypeTag a -> TypeTag b -> a -> Expression -> (b -> Expression) -> Expression
@@ -264,7 +325,8 @@
prettyPrintFlag = False,
threadCount = Nothing}
options = foldr extractOption emptyOptions specifiedOptions
- extractOption Command options@Flags{inputSourceFlag= UnspecifiedSource} = options{inputSourceFlag= CommandLineSource}
+ extractOption Command options@Flags{inputSourceFlag= UnspecifiedSource}
+ = options{inputSourceFlag= CommandLineSource}
extractOption Help options = options{helpFlag= True}
extractOption Interactive options@Flags{inputSourceFlag= UnspecifiedSource}
= options{inputSourceFlag= InteractiveSource}
@@ -274,7 +336,7 @@
extractOption (ScriptFile name) options@Flags{inputSourceFlag= UnspecifiedSource}
= options{inputSourceFlag= ScriptFileSource name}
extractOption (Threads count) options@Flags{threadCount= Nothing} = options{threadCount= Just (read count)}
- if not (null errors) Prelude.|| helpFlag options
+ if not (null errors) || helpFlag options
then showHelp
else case inputSourceFlag options
of CommandLineSource -> interpret options (concat (intersperse " " arguments)) >> return ()
@@ -337,10 +399,14 @@
Compiled tag@(TransducerTag tag3 tag4) t2 -> trycast tag (TransducerTag tag2 tag4) t2 right $
\t2'-> Compiled (TransducerTag tag1 tag4) (t >-> t2')
e@TypeError{} -> e
+ Compiled tag _ -> TypeError tag (TransducerTag tag2 AnyTag) right
+ Compiled tag _ -> TypeError tag (ProducerTag AnyTag) left
e@TypeError{} -> e
compile UnitTag (NativeCommand command)
= Compiled (ProducerTag CharTag) (liftAtomicProducer command ioCost $
- \sink-> do (_, stdout, _, pid) <- liftPipe (Process.runInteractiveCommand command)
+ \sink-> do (Nothing, Just stdout, Nothing, pid)
+ <- liftPipe (Process.createProcess
+ (Process.shell command){Process.std_out= Process.CreatePipe})
produce (fromHandle stdout True) sink)
compile UnitTag (FileProducer path) = Compiled (ProducerTag CharTag) (fromFile path)
compile UnitTag StdInProducer = Compiled (ProducerTag CharTag) fromStdIn
@@ -355,11 +421,11 @@
compile inputTag (ForEach splitter true false) = combineSplitterAndBranches foreach inputTag splitter true false
compile inputTag (If splitter true false) = combineSplitterAndBranches ifs inputTag splitter true false
compile inputTag (NativeCommand command) = Compiled (TransducerTag CharTag CharTag) (liftAtomicTransducer command ioCost f)
- where f source sink = do (stdin, stdout, stderr, pid) <- liftPipe (Process.runInteractiveCommand command)
- liftPipe (do hSetBuffering stdin NoBuffering
- hSetBuffering stdout NoBuffering
- err <- hGetContents stderr
- forkIO (evaluate (length err) >> return ()))
+ where f source sink = do (Just stdin, Just stdout, Nothing, pid)
+ <- liftPipe (Process.createProcess (Process.shell command){Process.std_in= Process.CreatePipe,
+ Process.std_out= Process.CreatePipe})
+ liftPipe (hSetBuffering stdin NoBuffering
+ >> hSetBuffering stdout NoBuffering)
interleave source stdin pid stdout sink
return []
interleave :: forall c. Source c Char -> Handle -> Process.ProcessHandle -> Handle -> Sink c Char -> Pipe c IO ()
@@ -385,19 +451,19 @@
>>= 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) e
+ of Compiled (SplitterTag tag _) s -> Compiled (TransducerTag tag tag) (select s)
+ Compiled tag _ -> TypeError tag (SplitterTag inputTag AnyTag) e
e'@TypeError{} -> e'
compile inputTag (While condition body)
= case (compile inputTag condition, compile inputTag body)
- of (Compiled (SplitterTag tag1) s, Compiled tag2@TransducerTag{} t)
+ of (Compiled (SplitterTag tag1 _) s, Compiled tag2@TransducerTag{} t)
-> let tag2' = TransducerTag tag1 tag1
in trycast tag2 tag2' t body (\t'-> Compiled tag2' (while t' s))
-compile inputTag (FollowedBy left right) = combineSplittersOfSameType followedBy inputTag left right
-compile inputTag (And left right) = combineSplittersOfSameType (>&) inputTag left right
-compile inputTag (Or left right) = combineSplittersOfSameType (>|) inputTag left right
-compile inputTag (ZipWithAnd left right) = combineSplittersOfSameType (&&) inputTag left right
-compile inputTag (ZipWithOr left right) = combineSplittersOfSameType (||) inputTag left right
+compile inputTag (FollowedBy left right) = combineSplitters followedBy inputTag PairTag left right
+compile inputTag (And left right) = combineSplitters (>&) inputTag PairTag left right
+compile inputTag (Or left right) = combineSplitters (>|) inputTag EitherTag left right
+compile inputTag (ZipWithAnd left right) = combineSplitters (Combinators.&&) inputTag PairTag left right
+compile inputTag (ZipWithOr left right) = combineSplitters (Combinators.||) inputTag EitherTag left right
compile inputTag (Nested left right) = combineSplittersOfSameType nestedIn inputTag left right
compile inputTag (Having left right) = combineSplittersOfSameType having inputTag left right
compile inputTag (HavingOnly left right) = combineSplittersOfSameType havingOnly inputTag left right
@@ -407,20 +473,33 @@
compile inputTag (Last splitter) = wrapSplitter last inputTag splitter
compile inputTag (Prefix splitter) = wrapSplitter prefix inputTag splitter
compile inputTag (Suffix splitter) = wrapSplitter suffix inputTag splitter
-compile inputTag (StartOf splitter) = wrapSplitter startOf inputTag splitter
-compile inputTag (EndOf splitter) = wrapSplitter endOf inputTag splitter
+compile inputTag (StartOf splitter) = wrapSplitter' startOf inputTag MaybeTag splitter
+compile inputTag (EndOf splitter) = wrapSplitter' endOf inputTag MaybeTag splitter
compile inputTag (Prepend prefix) = wrapProducerIntoTransducer prepend inputTag prefix
compile inputTag (Append suffix) = wrapProducerIntoTransducer append inputTag suffix
compile inputTag (Substitute replacement) = wrapGenericProducerIntoTransducer substitute inputTag replacement
+compile inputTag ExecuteTransducer
+ = Compiled (TransducerTag CharTag CharTag) (liftAtomicTransducer "execute" ioCost execute)
+ where execute source sink = do ((), command) <- pipe (pour source) getList
+ (Nothing, Just stdout, Nothing, pid)
+ <- liftPipe (Process.createProcess
+ (Process.shell command){Process.std_out= Process.CreatePipe})
+ produce (fromHandle stdout True) sink
+ return []
+
compile inputTag IdentityTransducer = Compiled (TransducerTag inputTag inputTag) asis
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
compile inputTag Group = Compiled (TransducerTag inputTag (ListTag inputTag)) group
+compile t@(MarkupTag t1 t2) Unparse = Compiled (TransducerTag t t1) unparse
+compile inputTag Unparse
+ = TypeError (TransducerTag (MarkupTag AnyTag AnyTag) AnyTag) (TransducerTag inputTag AnyTag) Unparse
compile CharTag Uppercase = Compiled (TransducerTag CharTag CharTag) uppercase
-compile inputTag Uppercase = TypeError (TransducerTag CharTag CharTag) (TransducerTag inputTag inputTag) Uppercase
+compile inputTag Uppercase = TypeError (TransducerTag CharTag CharTag) (TransducerTag inputTag AnyTag) Uppercase
compile inputTag@CharTag ShowTransducer = Compiled (TransducerTag inputTag (ListTag CharTag)) toString
compile inputTag@IntTag ShowTransducer = Compiled (TransducerTag inputTag (ListTag CharTag)) toString
+compile inputTag@(MarkupTag CharTag XMLTokenTag) ShowTransducer = Compiled (TransducerTag inputTag (ListTag CharTag)) toString
compile inputTag ShowTransducer
= TypeError (TransducerTag IntTag (ListTag CharTag)) (TransducerTag inputTag AnyTag) ShowTransducer
{-
@@ -428,15 +507,28 @@
actualType = TransducerTag inputTag (ListTag CharTag)
in trycast targetType actualType toString ShowTransducer (Compiled actualType)
-}
-compile inputTag EverythingSplitter = Compiled (SplitterTag inputTag) everything
-compile inputTag NothingSplitter = Compiled (SplitterTag inputTag) nothing
-compile inputTag WhitespaceSplitter = Compiled (SplitterTag CharTag) whitespace
-compile inputTag LineSplitter = Compiled (SplitterTag CharTag) line
-compile inputTag LetterSplitter = Compiled (SplitterTag CharTag) letters
-compile inputTag DigitSplitter = Compiled (SplitterTag CharTag) digits
-compile inputTag OneSplitter = Compiled (SplitterTag inputTag) one
-compile CharTag (SubstringSplitter part) = Compiled (SplitterTag CharTag) (substring part)
-compile inputTag e@SubstringSplitter{} = TypeError (SplitterTag CharTag) (SplitterTag inputTag) e
+compile inputTag EverythingSplitter = Compiled (SplitterTag inputTag UnitTag) everything
+compile inputTag NothingSplitter = Compiled (SplitterTag inputTag UnitTag) nothing
+compile inputTag WhitespaceSplitter = Compiled (SplitterTag CharTag UnitTag) whitespace
+compile inputTag LineSplitter = Compiled (SplitterTag CharTag UnitTag) line
+compile inputTag LetterSplitter = Compiled (SplitterTag CharTag UnitTag) letters
+compile inputTag DigitSplitter = Compiled (SplitterTag CharTag UnitTag) digits
+compile inputTag MarkedSplitter = Compiled (SplitterTag (MarkupTag AnyTag AnyTag) UnitTag) marked
+compile inputTag OneSplitter = Compiled (SplitterTag inputTag UnitTag) one
+compile CharTag (SubstringSplitter part) = Compiled (SplitterTag CharTag UnitTag) (substring part)
+compile inputTag e@SubstringSplitter{} = TypeError (SplitterTag CharTag UnitTag) (SplitterTag inputTag UnitTag) e
+compile CharTag XMLTokenParser = Compiled (TransducerTag CharTag (MarkupTag CharTag XMLTokenTag)) XML.parseTokens
+compile t@(MarkupTag CharTag XMLTokenTag) XMLElement = Compiled (SplitterTag t UnitTag) (XML.element)
+compile t@(MarkupTag CharTag XMLTokenTag) XMLAttribute = Compiled (SplitterTag t UnitTag) (XML.attribute)
+compile t@(MarkupTag CharTag XMLTokenTag) XMLAttributeName = Compiled (SplitterTag t UnitTag) (XML.attributeName)
+compile t@(MarkupTag CharTag XMLTokenTag) XMLAttributeValue = Compiled (SplitterTag t UnitTag) (XML.attributeValue)
+compile t@(MarkupTag CharTag XMLTokenTag) XMLElementContent = Compiled (SplitterTag t UnitTag) XML.elementContent
+compile t@(MarkupTag CharTag XMLTokenTag) XMLElementName = Compiled (SplitterTag t UnitTag) XML.elementName
+compile t@(MarkupTag CharTag XMLTokenTag) (XMLElementHavingTag s) = wrapConcreteSplitter XML.elementHavingTag t s
+compile t@(MarkupTag CharTag XMLTokenTag) (XMLHavingText left right)
+ = combineSplittersOfDifferentTypes XML.havingText t CharTag left right
+compile t@(MarkupTag CharTag XMLTokenTag) (XMLHavingOnlyText left right)
+ = combineSplittersOfDifferentTypes XML.havingOnlyText t CharTag left right
compile inputTag expression = error ("Cannot compile " ++ show expression ++ " with input " ++ show inputTag)
@@ -481,13 +573,44 @@
(Compiled tag@SplitterTag{} _, _) -> TypeError tag (ProducerTag AnyTag) e1
(_, Compiled tag@SplitterTag{} _) -> TypeError tag (ProducerTag AnyTag) e2
-wrapSplitter :: forall x. Typeable x =>
- (forall x. Typeable x => Splitter IO x -> Splitter IO x) -> TypeTag x -> Expression -> Expression
-wrapSplitter combinator inputTag expression = case compile inputTag expression
- of Compiled tag@SplitterTag{} splitter -> Compiled tag (combinator splitter)
- Compiled tag _ -> TypeError tag (SplitterTag inputTag) expression
- e@TypeError{} -> e
+wrapSplitter :: forall x. (Typeable x) =>
+ (forall x b. (Typeable x, Typeable b) => Splitter IO x b -> Splitter IO x b) ->
+ TypeTag x -> Expression -> Expression
+wrapSplitter combinator inputTag expression
+ = case compile inputTag expression
+ of Compiled tag@(SplitterTag tx tb) splitter -> Compiled (SplitterTag tx tb) (combinator splitter)
+ Compiled tag _ -> TypeError tag (SplitterTag inputTag AnyTag) expression
+ e@TypeError{} -> e
+wrapConcreteSplitter :: forall x. (Typeable x) =>
+ (forall b. (Typeable b) => Splitter IO x b -> Splitter IO x b) ->
+ TypeTag x -> Expression -> Expression
+wrapConcreteSplitter combinator inputTag expression
+ = case compile inputTag expression
+ of Compiled tag@(SplitterTag tx tb) splitter -> trycast tag (SplitterTag inputTag tb) splitter expression $
+ \s'-> Compiled (SplitterTag inputTag tb) (combinator s')
+ Compiled tag _ -> TypeError tag (SplitterTag inputTag AnyTag) expression
+ e@TypeError{} -> e
+
+wrapConcreteSplitter' :: forall x y. (Typeable x, Typeable y) =>
+ (forall b. (Typeable b) => Splitter IO x b -> Splitter IO y ()) ->
+ TypeTag x -> TypeTag y -> Expression -> Expression
+wrapConcreteSplitter' combinator inputTag outputTag expression
+ = case compile inputTag expression
+ of Compiled tag@(SplitterTag tx tb) splitter -> trycast tag (SplitterTag inputTag tb) splitter expression $
+ \s'-> Compiled (SplitterTag outputTag UnitTag) (combinator s')
+ Compiled tag _ -> TypeError tag (SplitterTag inputTag AnyTag) expression
+ e@TypeError{} -> e
+
+wrapSplitter' :: forall x c. (Typeable x, Typeable1 c) =>
+ (forall x b. (Typeable x, Typeable b) => Splitter IO x b -> Splitter IO x (c b)) ->
+ TypeTag x -> (forall b. Typeable b => TypeTag b -> TypeTag (c b)) -> Expression -> Expression
+wrapSplitter' combinator inputTag constructor expression
+ = case compile inputTag expression
+ of Compiled tag@(SplitterTag tx tb) splitter -> Compiled (SplitterTag tx (constructor tb)) (combinator splitter)
+ Compiled tag _ -> TypeError tag (SplitterTag inputTag AnyTag) expression
+ e@TypeError{} -> e
+
wrapProducerIntoTransducer :: forall x. Typeable x =>
(Producer IO x () -> Transducer IO x x) -> TypeTag x -> Expression -> Expression
wrapProducerIntoTransducer combinator inputTag expression
@@ -505,14 +628,48 @@
Compiled tag _ -> TypeError tag (ProducerTag inputTag) expression
e@TypeError{} -> e
+combineSplitters :: forall x c. (Typeable x, Typeable2 c) =>
+ (forall x b1 b2. (Typeable x, Typeable b1, Typeable b2)
+ => Splitter IO x b1 -> Splitter IO x b2 -> Splitter IO x (c b1 b2))
+ -> TypeTag x -> (forall b1 b2. (Typeable b1, Typeable b2) => TypeTag b1 -> TypeTag b2 -> TypeTag (c b1 b2))
+ -> Expression -> Expression -> Expression
+combineSplitters combinator inputTag constructor left right
+ = case (compile inputTag left, compile inputTag right)
+ of (Compiled tag1@(SplitterTag x1 b1) s1, Compiled tag2@(SplitterTag x2 b2) s2)
+ -> trycast tag2 (SplitterTag x1 b2) s2 right $
+ \s2'-> Compiled (SplitterTag x1 (constructor b1 b2)) (combinator s1 s2')
+ (e@TypeError{}, _) -> e
+ (_, e@TypeError{}) -> e
+ (Compiled tag1 _, Compiled tag2@SplitterTag{} _) -> TypeError tag1 tag2 left
+ (Compiled tag1@SplitterTag{} _, Compiled tag2 _) -> TypeError tag2 tag1 right
+
combineSplittersOfSameType :: forall x. Typeable x =>
- (forall x. Typeable x => Splitter IO x -> Splitter IO x -> Splitter IO x)
+ (forall x b. (Typeable x, Typeable b) => Splitter IO x b -> Splitter IO x b -> Splitter IO x b)
-> TypeTag x -> Expression -> Expression -> Expression
combineSplittersOfSameType combinator inputTag left right
= case (compile inputTag left, compile inputTag right)
of (Compiled tag1@SplitterTag{} s1, Compiled tag2@SplitterTag{} s2)
-> trycast tag2 tag1 s2 right (\s2'-> Compiled tag1 (combinator s1 s2'))
+ (e@TypeError{}, _) -> e
+ (_, e@TypeError{}) -> e
+ (Compiled tag1 _, Compiled tag2@SplitterTag{} _) -> TypeError tag1 tag2 left
+ (Compiled tag1@SplitterTag{} _, Compiled tag2 _) -> TypeError tag2 tag1 right
+combineSplittersOfDifferentTypes :: forall x1 x2. (Typeable x1, Typeable x2) =>
+ (forall b1 b2. (Typeable b1, Typeable b2)
+ => Splitter IO x1 b1 -> Splitter IO x2 b2 -> Splitter IO x1 b1)
+ -> TypeTag x1 -> TypeTag x2 -> Expression -> Expression -> Expression
+combineSplittersOfDifferentTypes combinator tag1 tag2 left right
+ = case (compile tag1 left, compile tag2 right)
+ of (Compiled tag1'@(SplitterTag _ b1) s1, Compiled tag2'@(SplitterTag _ b2) s2)
+ -> trycast tag1' (SplitterTag tag1 b1) s1 left $
+ \s1'-> trycast tag2' (SplitterTag tag2 b2) s2 right $
+ \s2'-> Compiled (SplitterTag tag1 b1) (combinator s1' s2')
+ (e@TypeError{}, _) -> e
+ (_, e@TypeError{}) -> e
+ (Compiled tag1 _, Compiled tag2@SplitterTag{} _) -> TypeError tag1 tag2 left
+ (Compiled tag1@SplitterTag{} _, Compiled tag2 _) -> TypeError tag2 tag1 right
+
combineTransducersOfSameType :: forall x. Typeable x =>
(forall x y. (Typeable x, Typeable y)=> Transducer IO x y -> Transducer IO x y -> Transducer IO x y)
-> TypeTag x -> Expression -> Expression -> Expression
@@ -522,11 +679,12 @@
-> trycast tag2 tag1 t2 right (\t2'-> Compiled tag1 (combinator t1 t2'))
combineSplitterAndBranches :: forall x. Typeable x =>
- (forall x cc. (Typeable x, BranchComponent cc IO x [x])=> Splitter IO x -> cc -> cc -> cc)
- -> TypeTag x -> Expression -> Expression -> Expression -> Expression
+ (forall x b cc.
+ (Typeable x, Typeable b, BranchComponent cc IO x [x]) => Splitter IO x b -> cc -> cc -> cc)
+ -> TypeTag x -> Expression -> Expression -> Expression -> Expression
combineSplitterAndBranches combinator inputTag splitter true false
= case (compile inputTag splitter, compile inputTag true, compile inputTag false)
- of (Compiled (SplitterTag tag1) s, Compiled tag2@ConsumerTag{} t, Compiled tag3@ConsumerTag{} f)
+ of (Compiled (SplitterTag tag1 _) s, Compiled tag2@ConsumerTag{} t, Compiled tag3@ConsumerTag{} f)
-> trycast tag2 (ConsumerTag tag1) t true $
\t'-> trycast tag3 (ConsumerTag tag1) f false $
\f'-> Compiled (ConsumerTag tag1) (combinator s t' f')
@@ -534,47 +692,67 @@
-> trycast tag2 tag1 t true $
\t'-> trycast tag3 tag1 f false $
\f'-> Compiled tag1 (combinator s t' f')
- (Compiled (SplitterTag tag1) s, Compiled tag2@(TransducerTag tag2a tag2b) t, Compiled tag3@TransducerTag{} f)
+ (Compiled (SplitterTag tag1 _) s, Compiled tag2@(TransducerTag tag2a tag2b) t, Compiled tag3@TransducerTag{} f)
-> let tag2' = TransducerTag tag1 tag2b
in trycast tag2 tag2' t true $
\t'-> trycast tag3 tag2' f false $
\f'-> Compiled tag2' (combinator s t' f')
- (Compiled (SplitterTag tag1) s, Compiled tag2@(TransducerTag tag2a tag2b) t, Compiled tag3@ConsumerTag{} f)
+ (Compiled (SplitterTag tag1 _) s, Compiled tag2@(TransducerTag tag2a tag2b) t, Compiled tag3@ConsumerTag{} f)
-> let tag2' = TransducerTag tag1 tag2b
in trycast tag2 tag2' t true $
\t'-> trycast tag3 (ConsumerTag tag1) f false $
\f'-> Compiled tag2' (combinator s t' (consumeBy f'))
- (Compiled (SplitterTag tag1) s, Compiled tag2@ConsumerTag{} t, Compiled tag3@(TransducerTag tag3a tag3b) f)
+ (Compiled (SplitterTag tag1 _) s, Compiled tag2@ConsumerTag{} t, Compiled tag3@(TransducerTag tag3a tag3b) f)
-> let tag3' = TransducerTag tag1 tag3b
in trycast tag2 (ConsumerTag tag1) t true $
\t'-> trycast tag3 tag3' f false $
\f'-> Compiled tag3' (combinator s (consumeBy t') f')
+ (Compiled (SplitterTag tag1 _) s, Compiled tag2@(TransducerTag tag2a tag2b) t, Compiled tag3@ProducerTag{} f)
+ -> let tag2' = TransducerTag tag1 tag2b
+ in trycast tag2 tag2' t true $
+ \t'-> trycast tag3 (ProducerTag tag2b) f false $
+ \f'-> Compiled tag2' (combinator s t' (substitute f'))
+ (Compiled (SplitterTag tag1 _) s, Compiled tag2@ProducerTag{} t, Compiled tag3@(TransducerTag tag3a tag3b) f)
+ -> let tag3' = TransducerTag tag1 tag3b
+ in trycast tag2 (ProducerTag tag3b) t true $
+ \t'-> trycast tag3 tag3' f false $
+ \f'-> Compiled tag3' (combinator s (substitute t') f')
+ (Compiled (SplitterTag tag1 _) s, Compiled tag2@(ConsumerTag tag2a) t, Compiled tag3@(ProducerTag tag3a) f)
+ -> trycast tag2 (ConsumerTag tag1) t true $
+ \t'-> Compiled (TransducerTag tag1 tag3a) (combinator s (consumeBy t') (substitute f))
+ (Compiled (SplitterTag tag1 _) s, Compiled tag2@(ProducerTag tag2a) t, Compiled tag3@(ConsumerTag tag3a) f)
+ -> trycast tag3 (ConsumerTag tag1) f true $
+ \f'-> Compiled (TransducerTag tag1 tag2a) (combinator s (substitute t) (consumeBy f'))
(e@TypeError{}, _, _) -> e
(_, e@TypeError{}, _) -> e
(_, _, e@TypeError{}) -> e
(Compiled SplitterTag{} _, Compiled tag _, _) -> TypeError tag (TransducerTag inputTag AnyTag) true
(Compiled SplitterTag{} _, _, Compiled tag _) -> TypeError tag (TransducerTag inputTag AnyTag) false
- (Compiled tag _, _, _) -> TypeError tag (SplitterTag inputTag) splitter
+ (Compiled tag _, _, _) -> TypeError tag (SplitterTag inputTag AnyTag) splitter
parseExpression :: String -> Either Int (Expression, [Char], Int)
-parseExpression s = case parse partialExpressionParser "" s of
+parseExpression s = case Parsec.parse partialExpressionParser "" s of
Left error -> Left (sourceLine (errorPos error))
Right result -> Right result
lexer = (makeTokenParser language) {stringLiteral= stringLexemeParser}
language = emptyDef{commentLine= "#",
+ identLetter= satisfy (\char-> isAlphaNum char || char == '-' || char == '_'),
reservedOpNames= ["...", ">!", ">", ">&", ">,", ">>", ">|", "|", "||", ";", "&"],
reservedNames= ["append", "concatenate", "count", "digits", "do",
"else", "end", "error", "exit", "everything", "first", "foreach",
"group", "having", "having-only", "id", "if", "in",
- "last", "letters", "line", "nested", "nothing", "prefix", "prepend",
+ "last", "letters", "line", "marked", "nested", "nothing", "prefix", "prepend",
"select", "show", "stdin", "substitute", "substring", "suffix", "suppress",
- "then", "uppercase", "while", "whitespace"]}
+ "then", "unparse", "uppercase", "while", "whitespace",
+ "XML.parse-tags", "XML.serialize-tags",
+ "XML.element", "XML.element-content", "XML.element-having-tag",
+ "XML.element-name", "XML.having-text"]}
reservedTokens = reservedOpNames language ++ reservedNames language
-partialExpressionParser :: Parser (Expression, [Char], Int)
+partialExpressionParser :: Parsec.Parser (Expression, [Char], Int)
partialExpressionParser = do whiteSpace lexer
t <- expressionParser
whiteSpace lexer
@@ -582,7 +760,7 @@
pos <- getPosition
return (t, rest, sourceLine pos - 1)
-expressionParser :: Parser Expression
+expressionParser :: Parsec.Parser Expression
expressionParser = do head <- stepParser
whiteSpace lexer
(do tail <- many1 (try (symbol lexer ";" >> stepParser))
@@ -594,13 +772,13 @@
return head
)
-stepParser :: Parser Expression
+stepParser :: Parsec.Parser Expression
stepParser = do head <- termParser
whiteSpace lexer
tail <- many (try (char '|' >> whiteSpace lexer >> termParser))
return (foldr1 Pipe (head:tail))
-termParser :: Parser Expression
+termParser :: Parsec.Parser Expression
termParser =
do first <- prefixTermParser
whiteSpace lexer
@@ -619,9 +797,13 @@
liftM (Having first) (try (symbol lexer "having" >> prefixTermParser))
<|>
liftM (HavingOnly first) (try (symbol lexer "having-only" >> prefixTermParser))
+ <|>
+ liftM (XMLHavingOnlyText first) (try (symbol lexer "XML.having-only-text" >> prefixTermParser))
+ <|>
+ liftM (XMLHavingText first) (try (symbol lexer "XML.having-text" >> prefixTermParser))
)
-prefixTermParser :: Parser Expression
+prefixTermParser :: Parsec.Parser Expression
prefixTermParser =
try (symbol lexer ">!" >> liftM Not prefixTermParser)
<|> try (symbol lexer "prefix" >> liftM Prefix prefixTermParser)
@@ -634,9 +816,10 @@
<|> try (symbol lexer "start-of" >> liftM StartOf prefixTermParser)
<|> try (symbol lexer "end-of" >> liftM EndOf prefixTermParser)
<|> try (symbol lexer "select" >> liftM Select prefixTermParser)
+ <|> try (symbol lexer "XML.element-having-tag" >> liftM XMLElementHavingTag prefixTermParser)
<|> primaryParser
-primaryParser :: Parser Expression
+primaryParser :: Parsec.Parser Expression
primaryParser =
try (do char '('
whiteSpace lexer
@@ -661,19 +844,29 @@
<|> try (do symbol lexer "error"
message <- (try (parameterParser True) <|> return "Error sink reached!")
return (ErrorConsumer message))
- <|> try (symbol lexer "id" >> return IdentityTransducer)
- <|> try (symbol lexer "uppercase" >> return Uppercase)
- <|> try (symbol lexer "count" >> return Count)
- <|> try (symbol lexer "show" >> return ShowTransducer)
<|> try (symbol lexer "concatenate" >> return Concatenate)
- <|> try (symbol lexer "group" >> return Group)
+ <|> try (symbol lexer "count" >> return Count)
+ <|> try (symbol lexer "digits" >> return DigitSplitter)
<|> try (symbol lexer "everything" >> return EverythingSplitter)
- <|> try (symbol lexer "nothing" >> return NothingSplitter)
- <|> try (symbol lexer "whitespace" >> return WhitespaceSplitter)
- <|> try (symbol lexer "line" >> return LineSplitter)
+ <|> try (symbol lexer "execute" >> return ExecuteTransducer)
+ <|> try (symbol lexer "group" >> return Group)
+ <|> try (symbol lexer "id" >> return IdentityTransducer)
<|> try (symbol lexer "letters" >> return LetterSplitter)
- <|> try (symbol lexer "digits" >> return DigitSplitter)
+ <|> try (symbol lexer "line" >> return LineSplitter)
+ <|> try (symbol lexer "marked" >> return MarkedSplitter)
+ <|> try (symbol lexer "nothing" >> return NothingSplitter)
<|> try (symbol lexer "one" >> return OneSplitter)
+ <|> try (symbol lexer "show" >> return ShowTransducer)
+ <|> try (symbol lexer "uppercase" >> return Uppercase)
+ <|> try (symbol lexer "unparse" >> return Unparse)
+ <|> try (symbol lexer "whitespace" >> return WhitespaceSplitter)
+ <|> try (symbol lexer "XML.attribute-name" >> return XMLAttributeName)
+ <|> try (symbol lexer "XML.attribute-value" >> return XMLAttributeValue)
+ <|> try (symbol lexer "XML.attribute" >> return XMLAttribute)
+ <|> try (symbol lexer "XML.element-content" >> return XMLElementContent)
+ <|> try (symbol lexer "XML.element-name" >> return XMLElementName)
+ <|> try (symbol lexer "XML.element" >> return XMLElement)
+ <|> try (symbol lexer "XML.parse" >> return XMLTokenParser)
<|> try (do symbol lexer "substring"
part <- parameterParser True
return (SubstringSplitter part))
@@ -719,12 +912,12 @@
return (ForEach splitter trueBranch falseBranch))
<|> liftM NativeCommand (nativeCommand False)
-nativeSourceParser :: String -> Parser Expression
+nativeSourceParser :: String -> Parsec.Parser Expression
nativeSourceParser command = do symbol lexer command
params <- nativeCommand False
return (NativeCommand (command ++ " " ++ params))
-nativeCommand :: Bool -> Parser String
+nativeCommand :: Bool -> Parsec.Parser String
nativeCommand normalize = do parts <- try (lexeme lexer (parameterParser normalize)
`manyTill`
((eof >> return "") <|> lookAhead (choice (map (try . symbol lexer) reservedTokens))))
@@ -737,7 +930,7 @@
<|>
return []
-parameterParser :: Bool -> Parser String
+parameterParser :: Bool -> Parsec.Parser String
parameterParser normalize = do chars <- many (noneOf " \t\n'\"`\\()[]{}<>|&;")
(do try (string "\\n")
rest <- option "" (parameterParser normalize)
@@ -781,7 +974,7 @@
do when (null chars) parserZero
return chars)
-escape :: Parser Char
+escape :: Parsec.Parser Char
escape = do char '\\'
escaped <- anyChar
return (case escaped of 'n' -> '\n'
@@ -789,7 +982,7 @@
't' -> '\t'
_ -> escaped)
-stringLexemeParser :: Parser String
+stringLexemeParser :: Parsec.Parser String
stringLexemeParser = do terminator <- oneOf "'\"`"
content <- many (try (noneOf ['\\', terminator]
<|> (string "\\t" >> return '\t')
diff --git a/Test.hs b/Test.hs
--- a/Test.hs
+++ b/Test.hs
@@ -14,22 +14,24 @@
.
-}
-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, ScopedTypeVariables, PatternSignatures #-}
+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, ScopedTypeVariables #-}
module Main where
import Control.Concurrent.SCC.Foundation
import Control.Concurrent.SCC.ComponentTypes
-import Control.Concurrent.SCC.Components
import Control.Concurrent.SCC.Combinators hiding ((&&), (||))
-import qualified Control.Concurrent.SCC.Combinators as Combinators
+import Control.Concurrent.SCC.Components
+import qualified Control.Concurrent.SCC.XMLComponents as XML
+import qualified Control.Concurrent.SCC.Combinators as C
-import Control.Monad (liftM)
-import Control.Monad.Identity (Identity (Identity))
+import Control.Monad (liftM, when)
+import Control.Monad.Identity (Identity (Identity, runIdentity))
import Data.Char (ord, isLetter, isSpace, toUpper)
import Data.Dynamic (Typeable)
-import Data.List (find, stripPrefix, groupBy, intersect, union, intercalate, isInfixOf, isPrefixOf, isSuffixOf, sort)
-import Data.Maybe (fromJust)
+import Data.List (find, findIndices, groupBy, intersect, union,
+ intercalate, isInfixOf, isPrefixOf, isSuffixOf, nub, sort, tails)
+import Data.Maybe (fromJust, isJust, mapMaybe)
import qualified Data.List as List
import qualified Data.Foldable as Foldable
import qualified Data.Sequence as Seq
@@ -43,10 +45,17 @@
sublists [] _ = []
sublists _ [] = []
-sublists sublist input = case stripPrefix sublist input
- of Just rest -> sublist ++ sublists sublist rest
- Nothing -> sublists sublist (tail input)
+sublists sublist input = map
+ (input !!)
+ (nub $ sort $ concatMap
+ (\n-> [n .. n + length sublist - 1])
+ (findIndices (isPrefixOf sublist) (tails input)))
+contentIn :: [Markup x y] -> [x]
+contentIn = mapMaybe (\x-> case x of {Content y -> Just y; _ -> Nothing})
+
+both f (x, y) = (f x, f y)
+
main = mapM_ quickCheck tests
tests = [label "pipe" $ \(input :: [Int])-> runPipes (pipe (putList input) getList) == Just ([], input),
@@ -82,6 +91,13 @@
label "ifs (substring X) uppercase asis" $
\s (LowercaseLetter c)-> transducerOutput (ifs (substring [c]) uppercase asis) s
== map (\x-> if x == c then toUpper x else x) s,
+ label "parseSubstring" $ \s (c :: TestEnum)-> transducerOutput (parseSubstring [c] >-> select markedContent >-> unparse) s
+ == filter (==c) s,
+ label "uppercase `wherever` parseSubstring" $
+ \s (LowercaseLetter c)-> transducerOutput (parseSubstring [c] >-> (liftComponent uppercase `wherever` markedContent)
+ >-> unparse) s
+ == map (\x-> if x == c then toUpper x else x) s,
+ 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 \"]\")" $
@@ -97,7 +113,7 @@
\s-> transducerOutput (uppercase `wherever` (snot whitespace `havingOnly` letters)) s
== mapWords (\w-> if all isLetter w then map toUpper w else w) s,
- label "select $ substring" $ transducerOutput (select $ substring "o, ") "Hello, World!" == "o, ",
+ label "select $ substring" (transducerOutput (select $ substring "o, ") "Hello, World!" == "o, "),
label "(uppercase `wherever` (first letters))"
(transducerOutput (uppercase `wherever` (first letters)) "... Hello, World !" == "... HELLO, World !"
@@ -116,10 +132,18 @@
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)"
- (transducerOutput (foreach (letters `having` prefix (substring "H")) uppercase asis) "Hello, World! Hola, Mundo!"
+ (transducerOutput (foreach
+ (letters `having` prefix (substring "H"))
+ uppercase
+ asis)
+ "Hello, World! Hola, Mundo!"
== "HELLO, World! HOLA, Mundo!"),
label "(foreach (letters `having` suffix (substring \"o\")) uppercase asis)"
- (transducerOutput (foreach (letters `having` suffix (substring "o")) uppercase asis) "Hello, World! Hola, Mundo!"
+ (transducerOutput (foreach
+ (letters `having` suffix (substring "o"))
+ uppercase
+ asis)
+ "Hello, World! Hola, Mundo!"
== "HELLO, World! Hola, MUNDO!"),
label "first one" $ \s-> splitterOutputs (first one) s == if null s then ("", "") else ([head s], tail s),
@@ -145,15 +169,22 @@
label "uptoFirst" $ prop_uptoFirst . splitterFromTrace,
label "lastAndAfter" $ prop_lastAndAfter . splitterFromTrace,
label "followedBy prefix" $ \trace1 trace2 n-> prop_followedBy1 (splitterFromTrace trace1) (splitterFromTrace trace2) n,
- label "first followedBy" $ \trace1 trace2 n-> prop_followedBy2 (splitterFromTrace trace1) (splitterFromTrace trace2) n,
+ label "followedBy startOf everything" $ \trace n-> prop_followedBy2 (splitterFromTrace trace) n,
label "substring followedBy substring 1" prop_followedBy3,
label "substring followedBy substring 2" prop_followedBy4,
label "substring followedBy substring 3" prop_followedBy5,
+ label "endOf followedBy U followedBy startOf"
+ $ \trace1 trace2 n-> prop_followedBy6 (splitterFromTrace trace1) (splitterFromTrace trace2) n,
label "... followedBy ..." prop_followedByBetween,
label "start ... end" $ \trace n-> prop_between1 (simpleSplitterFromTrace trace) n,
- label "start everything ... end" $ \trace n-> prop_between2 (simpleSplitterFromTrace trace) n]
+ label "start everything ... end" $ \trace n-> prop_between2 (simpleSplitterFromTrace trace) n,
+ label "XML.tokens" prop_XMLtokens1,
+ label "XML.tokens with attributes" prop_XMLtokens2,
+ label "XML.parseTokens >-> select elementContent >-> unparse" prop_XMLtokens3,
+ label "XML.parseTokens >-> unparse" prop_XMLtokens4]
+
prop_pour :: [Int] -> Bool
prop_pour input = runPipes (pipeD "input" (putList input) (\source-> pipeD "output" (\sink-> pour source sink) getList))
== Just ([], ((), input))
@@ -182,9 +213,19 @@
prop_allFalse input = splitterOutputs nothing input == ([], input)
prop_substring :: [TestEnum] -> [TestEnum] -> Property
-prop_substring input sublist = trivial (not (isInfixOf sublist input)) (fst (splitterOutputs (substring sublist) input)
- == sublists sublist input)
+prop_substring input sublist = trivial
+ (not (isInfixOf sublist input))
+ (transducerOutput (select (substring sublist)) input == sublists sublist input)
+prop_substringVsParse :: [TestEnum] -> [TestEnum] -> Property
+prop_substringVsParse input sublist = not (null sublist) && length sublist < length input
+ && not (sublist `isInfixOf` (tail sublist ++ init sublist))
+ ==> trivial (not (sublist `isInfixOf` input))
+ (transducerOutput (parseRegions (substring sublist)) input
+ == map unitFromOccurrence (transducerOutput (parseSubstring sublist) input))
+ where unitFromOccurrence (Content x) = Content x
+ unitFromOccurrence (Markup b) = Markup (fmap (const ()) b)
+
prop_group :: [Int] -> Bool
prop_group input = transducerOutput group input == [input]
@@ -194,13 +235,14 @@
prop_concatSeparate :: [[TestEnum]] -> [TestEnum] -> Bool
prop_concatSeparate input separator = transducerOutput (concatSeparate separator) input == intercalate separator input
-prop_snot :: Splitter Identity Int -> [Int] -> Bool
+prop_snot :: Splitter Identity Int () -> [Int] -> Bool
prop_snot splitter input = splitterOutputs (snot splitter) input == swap (splitterOutputs splitter input)
prop_andAssoc :: SplitterTrace -> SplitterTrace -> SplitterTrace -> [Int] -> Int -> Int -> Property
prop_andAssoc st1 st2 st3 input t1 t2
= t1 > 0 && t2 > 0
- ==> splitterOutputs (usingThreads t1 $ s1 >& (s2 >& s3)) input == splitterOutputs (usingThreads t2 $ (s1 >& s2) >& s3) input
+ ==> splitterOutputs (usingThreads t1 $ s1 C.&& (s2 C.&& s3)) input
+ == splitterOutputs (usingThreads t2 $ (s1 C.&& s2) C.&& s3) input
where s1 = splitterFromTrace st1
s2 = splitterFromTrace st2
s3 = splitterFromTrace st3
@@ -208,62 +250,65 @@
prop_orAssoc :: SplitterTrace -> SplitterTrace -> SplitterTrace -> [Int] -> Int -> Int -> Property
prop_orAssoc st1 st2 st3 input t1 t2
= t1 > 0 && t2 > 0
- ==> splitterOutputs (usingThreads t1 $ s1 >| (s2 >| s3)) input == splitterOutputs (usingThreads t2 $ (s1 >| s2) >| s3) input
+ ==> splitterOutputs (usingThreads t1 $ s1 C.|| (s2 C.|| s3)) input
+ == splitterOutputs (usingThreads t2 $ (s1 C.|| s2) C.|| s3) input
where s1 = splitterFromTrace st1
s2 = splitterFromTrace st2
s3 = splitterFromTrace st3
-prop_DeMorgan1 :: Splitter Identity Int -> Splitter Identity Int -> [Int] -> Int -> Int -> Property
+prop_DeMorgan1 :: Splitter Identity Int () -> Splitter Identity Int () -> [Int] -> Int -> Int -> Property
prop_DeMorgan1 s1 s2 input t1 t2
= t1 > 0 && t2 > 0
- ==> splitterOutputs (usingThreads t1 $ snot (s1 >& s2)) input == splitterOutputs (usingThreads t2 $ snot s1 >| snot s2) input
+ ==> splitterOutputs (usingThreads t1 $ snot (s1 C.&& s2)) input
+ == splitterOutputs (usingThreads t2 $ snot s1 C.|| snot s2) input
-prop_DeMorgan2 :: Splitter Identity Int -> Splitter Identity Int -> [Int] -> Int -> Int -> Property
+prop_DeMorgan2 :: Splitter Identity Int () -> Splitter Identity Int () -> [Int] -> Int -> Int -> Property
prop_DeMorgan2 s1 s2 input t1 t2
= t1 > 0 && t2 > 0
- ==> splitterOutputs (usingThreads t1 $ snot (s1 >| s2)) input == splitterOutputs (usingThreads t2 $ snot s1 >& snot s2) input
+ ==> splitterOutputs (usingThreads t1 $ snot (s1 C.|| s2)) input
+ == splitterOutputs (usingThreads t2 $ snot s1 C.&& snot s2) input
-prop_and :: Splitter Identity Int -> Splitter Identity Int -> Int -> Bool
-prop_and s1 s2 n = fst (splitterOutputs (s1 Combinators.&& s2) l)
+prop_and :: Splitter Identity Int () -> Splitter Identity Int () -> Int -> Bool
+prop_and s1 s2 n = fst (splitterOutputs (s1 C.&& s2) l)
== fst (splitterOutputs s1 l) `intersect` fst (splitterOutputs s2 l)
where l = [1 .. abs n]
-prop_or :: Splitter Identity Int -> Splitter Identity Int -> Int -> Bool
-prop_or s1 s2 n = fst (splitterOutputs (s1 Combinators.|| s2) l)
+prop_or :: Splitter Identity Int () -> Splitter Identity Int () -> Int -> Bool
+prop_or s1 s2 n = fst (splitterOutputs (s1 C.|| s2) l)
== sort (fst (splitterOutputs s1 l) `union` fst (splitterOutputs s2 l))
where l = [1 .. abs n]
-prop_even :: Splitter Identity TestEnum -> [TestEnum] -> Bool
+prop_even :: Splitter Identity TestEnum () -> [TestEnum] -> Bool
prop_even splitter input = let splitOddEven [] = ([], [])
splitOddEven (head:tail) = let (evens, odds) = splitOddEven tail in (head:odds, evens)
in fst (splitterOutputs (even splitter) input)
== concat (snd $ splitOddEven $ transducerOutput (foreach splitter group (consumeBy suppress)) input)
-prop_prefix_1 :: Splitter Identity TestEnum -> [TestEnum] -> Bool
+prop_prefix_1 :: Splitter Identity TestEnum () -> [TestEnum] -> Bool
prop_prefix_1 splitter input = let (pfx, rest) = splitterOutputs (prefix splitter) input
(true, false) = splitterOutputs splitter input
in pfx ++ rest == input && pfx `isPrefixOf` true
-prop_prefix_2 :: Splitter Identity TestEnum -> [TestEnum] -> Bool
+prop_prefix_2 :: Splitter Identity TestEnum () -> [TestEnum] -> Bool
prop_prefix_2 splitter input = let (prefix1, rest1) = splitterOutputs (prefix splitter) input
in case splitterOutputChunks splitter input
of (prefix2, True):rest2 -> prefix1 == prefix2 && rest1 == concat (map fst rest2)
(prefix2, False):rest2 -> prefix1 == [] && rest1 == prefix2 ++ concat (map fst rest2)
[] -> prefix1 ++ rest1 == []
-prop_suffix_1 :: Splitter Identity TestEnum -> [TestEnum] -> Bool
+prop_suffix_1 :: Splitter Identity TestEnum () -> [TestEnum] -> Bool
prop_suffix_1 splitter input = let (sfx, rest) = splitterOutputs (suffix splitter) input
(true, false) = splitterOutputs splitter input
in rest ++ sfx == input && sfx `isSuffixOf` true
-prop_suffix_2 :: Splitter Identity TestEnum -> [TestEnum] -> Bool
+prop_suffix_2 :: Splitter Identity TestEnum () -> [TestEnum] -> Bool
prop_suffix_2 splitter input = let (suffix1, rest1) = splitterOutputs (suffix splitter) input
in case reverse (splitterOutputChunks splitter input)
of (suffix2, True):rest2 -> suffix1 == suffix2 && rest1 == concat (map fst (reverse rest2))
(suffix2, False):rest2 -> suffix1 == [] && rest1 == concat (map fst (reverse rest2)) ++ suffix2
[] -> rest1 ++ suffix1 == []
-prop_first :: Splitter Identity TestEnum -> [TestEnum] -> Bool
+prop_first :: Splitter Identity TestEnum () -> [TestEnum] -> Bool
prop_first splitter input = let (first1, rest1) = splitterOutputs (first splitter) input
in case splitterOutputChunks splitter input
of (first2, True):rest2 -> first1 == first2 && rest1 == concat (map fst rest2)
@@ -272,7 +317,7 @@
(prefix, False):[] -> first1 == [] && rest1 == prefix
[] -> first1 ++ rest1 == []
-prop_last :: Splitter Identity TestEnum -> [TestEnum] -> Bool
+prop_last :: Splitter Identity TestEnum () -> [TestEnum] -> Bool
prop_last splitter input = let (last1, rest1) = splitterOutputs (last splitter) input
in -- trace (show (last1, rest1)) $ trace (show (splitterOutputChunks splitter input)) $
case reverse (splitterOutputChunks splitter input)
@@ -282,7 +327,7 @@
(suffix, False):[] -> last1 == [] && rest1 == suffix
[] -> last1 ++ rest1 == []
-prop_uptoFirst :: Splitter Identity TestEnum -> [TestEnum] -> Bool
+prop_uptoFirst :: Splitter Identity TestEnum () -> [TestEnum] -> Bool
prop_uptoFirst splitter input = let (first1, rest1) = splitterOutputs (uptoFirst splitter) input
in case splitterOutputChunks splitter input
of (first2, True):rest2 -> first1 == first2 && rest1 == concat (map fst rest2)
@@ -291,7 +336,7 @@
(prefix, False):[] -> first1 == [] && rest1 == prefix
[] -> first1 ++ rest1 == []
-prop_lastAndAfter :: Splitter Identity TestEnum -> [TestEnum] -> Bool
+prop_lastAndAfter :: Splitter Identity TestEnum () -> [TestEnum] -> Bool
prop_lastAndAfter splitter input = let (last1, rest1) = splitterOutputs (lastAndAfter splitter) input
in case reverse (splitterOutputChunks splitter input)
of (last2, True):rest2 -> last1 == last2 && rest1 == concat (map fst (reverse rest2))
@@ -300,12 +345,12 @@
(suffix, False):[] -> last1 == [] && rest1 == suffix
[] -> last1 ++ rest1 == []
-prop_followedBy1 :: Splitter Identity Int -> Splitter Identity Int -> Int -> Bool
+prop_followedBy1 :: Splitter Identity Int () -> Splitter Identity Int () -> Int -> Bool
prop_followedBy1 s1 s2 n = splitterOutputs (s1 `followedBy` s2) l == splitterOutputs (s1 `followedBy` prefix s2) l
where l = [1 .. abs n]
-prop_followedBy2 :: Splitter Identity Int -> Splitter Identity Int -> Int -> Bool
-prop_followedBy2 s1 s2 n = splitterOutputs (first (s1 `followedBy` s2)) l == splitterOutputs (first s1 `followedBy` s2) l
+prop_followedBy2 :: Splitter Identity Int () -> Int -> Bool
+prop_followedBy2 s n = splitterOutputs (s `followedBy` startOf everything) l == splitterOutputs s l
where l = [1 .. abs n]
prop_followedBy3 :: [TestEnum] -> [TestEnum] -> [TestEnum] -> Property
@@ -326,6 +371,12 @@
in splitterOutputs (substring [n1 .. n2] `followedBy` substring [n2 + 1 .. n3]) [0 .. n4]
== ([n1 .. n3], [0 .. n1 - 1] ++ [n3 + 1 .. n4])
+prop_followedBy6 :: Splitter Identity Int () -> Splitter Identity Int () -> Int -> Bool
+prop_followedBy6 s1 s2 n = sort (fst (splitterOutputs (endOf s1 `followedBy` s2) l)
+ `union` fst (splitterOutputs (s1 `followedBy` startOf s2) l))
+ == fst (splitterOutputs (s1 `followedBy` s2) l)
+ where l = [1 .. abs n]
+
prop_followedByBetween :: Int -> Int -> Int -> Int -> Bool
prop_followedByBetween i1 i2 i3 i4 = let n1 = abs i1
n2 = n1 + abs i2
@@ -338,16 +389,53 @@
== ([n1 .. n3], [0 .. n1 - 1] ++ [n3 + 1 .. n4])
-prop_between1 :: Splitter Identity Int -> Int -> Bool
+prop_between1 :: Splitter Identity Int () -> Int -> Bool
prop_between1 splitter n = splitterOutputs (startOf splitter ... endOf splitter) input == splitterOutputs splitter input
&& splitterOutputs (endOf splitter ... startOf splitter) input == ([], input)
where input = [1 .. abs n]
-prop_between2 :: Splitter Identity Int -> Int -> Bool
+prop_between2 :: Splitter Identity Int () -> Int -> Bool
prop_between2 splitter n = splitterOutputs (startOf everything ... endOf splitter) input == splitterOutputs (uptoFirst splitter) input
|| null (fst $ splitterOutputs splitter input)
where input = [1 .. abs n]
+prop_XMLtokens1 :: [LowercaseLetter] -> String -> Property
+prop_XMLtokens1 name content = name /= [] && intersect content "<&" == []
+ ==> splitterOutputs XML.tokens (start ++ content ++ end) == (start ++ end, content)
+ where name' = map letterChar name
+ start = "<" ++ name' ++ ">"
+ end = ""
+
+prop_XMLtokens2 :: [LowercaseLetter] -> [([LowercaseLetter], String)] -> String -> Property
+prop_XMLtokens2 name attrs content = name /= [] && all validAttribute attrs && intersect content "<&" == []
+ ==> splitterOutputs XML.tokens (start ++ content ++ end)
+ == (start ++ end, content)
+ where name' = map letterChar name
+ start = "<" ++ name' ++ concatMap attribute attrs ++ ">"
+ end = ""
+
+prop_XMLtokens3 :: [LowercaseLetter] -> [([LowercaseLetter], String)] -> String -> Property
+prop_XMLtokens3 name attrs content = name /= [] && all validAttribute attrs && intersect content "<&" == []
+ ==> transducerOutput
+ (XML.parseTokens >-> select XML.elementContent >-> unparse)
+ (start ++ content ++ end)
+ == content
+ where name' = map letterChar name
+ start = "<" ++ name' ++ concatMap attribute attrs ++ ">"
+ end = ""
+
+prop_XMLtokens4 :: [LowercaseLetter] -> [([LowercaseLetter], String)] -> String -> Property
+prop_XMLtokens4 name attrs content = name /= [] && all ((/= []) . fst) attrs
+ ==> transducerOutput (XML.parseTokens >-> unparse) input == input
+ where name' = map letterChar name
+ start = "<" ++ name' ++ concatMap attribute attrs ++ ">"
+ end = ""
+ content' = concatMap XML.escapeContentCharacter content
+ input = start ++ content' ++ end
+
+attribute (name, value) = " " ++ map letterChar name ++ "=\"" ++ concatMap XML.escapeAttributeCharacter value ++ "\""
+validAttribute (name, value) = name /= [] && intersect value "<&\"" == []
+
transducerOutput :: (Typeable x, Typeable y) => Transducer Identity x y -> [x] -> [y]
transducerOutput t input = case runPipes (pipeD "transducerOutput input"
(putList input)
@@ -356,44 +444,55 @@
getList))
of Identity ([], ([], output)) -> output
-splitterOutputs :: Typeable x => Splitter Identity x -> [x] -> ([x], [x])
+splitterOutputs :: (Typeable x, Typeable b) => Splitter Identity x b -> [x] -> ([x], [x])
splitterOutputs s input = case runPipes (pipeD "splitterOutputs input"
(putList input)
- (\source-> pipeD "splitterOutputs true"
- (\true-> pipeD "splitterOutputs false"
- (split s source true)
- getList)
- getList))
- of Identity ([], (([], false), true)) -> (true, false)
+ (\source-> splitToConsumers s source
+ getList
+ getList
+ consumeAndSuppress))
+ of Identity ([], ([], true, false, ())) -> (true, false)
-splitterOutputChunks :: Typeable x => Splitter Identity x -> [x] -> [([x], Bool)]
+splitterUnifiedOutput :: (Typeable x, Typeable b) => Splitter Identity x b -> [x] -> [Either (x, Bool) b]
+splitterUnifiedOutput s input = snd $ runIdentity
+ $ runPipes (pipe
+ (\sink-> pipe
+ (putList input)
+ (\source-> splitToConsumers s source
+ (flip (pourMap (Left . (\x-> (x, True)))) sink)
+ (flip (pourMap (Left . (\x-> (x, False)))) sink)
+ (flip (pourMap Right) sink)))
+ getList)
+
+splitterOutputChunks :: (Typeable x, Typeable b) => Splitter Identity x b -> [x] -> [([x], Bool)]
splitterOutputChunks s input = transducerOutput (foreach s
(group >-> lift121Transducer "true" (\chunk-> (chunk, True)))
(group >-> lift121Transducer "false" (\chunk-> (chunk, False))))
input
-simpleSplitterFromTrace :: (Show x, Typeable x) => SimpleSplitterTrace -> Splitter Identity x
-simpleSplitterFromTrace (init, last) = splitterFromTrace (map (maybe Nothing (Just . (,) True)) init, last)
+simpleSplitterFromTrace :: (Show x, Typeable x) => SimpleSplitterTrace -> Splitter Identity x ()
+simpleSplitterFromTrace (init, last) = splitterFromTrace (fmap Just init, last)
-splitterFromTrace :: (Show x, Typeable x) => SplitterTrace -> Splitter Identity x
-splitterFromTrace trace1 = liftAtomicSectionSplitter "splitterFromTrace" 1 $
- \source true false->
- let follow trace2@(head:tail) q = get source >>= maybe fail succeed
- where succeed x = let q' = q |> Just x
+splitterFromTrace :: (Show x, Typeable x) => SplitterTrace -> Splitter Identity x ()
+splitterFromTrace trace1 = liftAtomicSplitter "splitterFromTrace" 1 $
+ \source true false edge->
+ let follow previous trace2@(head:tail) q = get source >>= maybe fail succeed
+ where succeed x = let q' = q |> x
in case head
- of Nothing -> follow tail q'
- Just (False, b) -> (if b then put true else put false) Nothing
- >>= cond
- (follow tail q')
- (return $ Foldable.toList (Seq.viewl q))
- Just (True, True) -> putList (Foldable.toList (Seq.viewl q')) true
- >>= whenNull (follow tail Seq.empty)
- Just (True, False) -> putList (Foldable.toList (Seq.viewl q')) false
- >>= whenNull (follow tail Seq.empty)
- fail = if find (maybe False fst) trace2 == Just (Just (True, True))
- then putList (Foldable.toList (Seq.viewl q)) true
+ of Nothing -> follow previous tail q'
+ Just Nothing -> when (not previous) (put edge () >> return ())
+ >> follow False tail q'
+ Just (Just True) -> when (not previous) (put edge () >> return ())
+ >> putList (Foldable.toList (Seq.viewl q')) true
+ >>= whenNull (follow True tail Seq.empty)
+ Just (Just False) -> putList (Foldable.toList (Seq.viewl q')) false
+ >>= whenNull (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
else putList (Foldable.toList (Seq.viewl q)) false
- in liftM (map fromJust) $ follow (cycle (fst trace1 ++ [Just (True, snd trace1)])) Seq.empty
+ in follow False (cycle (fst trace1 ++ [Just (Just $ snd trace1)])) Seq.empty
swap :: (x, y) -> (y, x)
swap (x, y) = (y, x)
@@ -403,11 +502,11 @@
type SimpleSplitterTrace = ([Maybe Bool], Bool)
-type SplitterTrace = ([Maybe (Bool, Bool)], Bool)
+type SplitterTrace = ([Maybe (Maybe Bool)], Bool)
data TestEnum = One | Two | Three | Four | Five deriving (Enum, Eq, Show, Typeable)
-newtype LowercaseLetter = LowercaseLetter Char deriving (Eq, Show, Typeable)
+newtype LowercaseLetter = LowercaseLetter{letterChar:: Char} deriving (Eq, Show, Typeable)
instance Arbitrary TestEnum where
arbitrary = oneof (map return [One, Two, Three, Four, Five])
@@ -421,7 +520,7 @@
arbitrary = fmap LowercaseLetter (choose ('a', 'z'))
coarbitrary (LowercaseLetter c) = variant ((ord c - 65) `rem` 26)
-instance Arbitrary (Splitter Identity Int) where
+instance Arbitrary (Splitter Identity Int ()) where
arbitrary = fmap splitterFromTrace arbitrary
coarbitrary s gen = sized (\n-> coarbitrary (transducerOutput (ifs s
(lift121Transducer "true" $ const True)
diff --git a/grammar.bnf b/grammar.bnf
--- a/grammar.bnf
+++ b/grammar.bnf
@@ -14,10 +14,13 @@
| {">," PrefixTerm}
| "having" PrefixTerm
| "having-only" PrefixTerm
+ | "XML.having-text" PrefixTerm
+ | "XML.having-only-text" PrefixTerm
| "..." PrefixTerm].
PrefixTerm ::=
Primary
+ | "XML.element-having-tag" PrefixTerm
| "first" PrefixTerm
| "last" PrefixTerm
| "prefix" PrefixTerm
@@ -32,28 +35,40 @@
Primary ::=
"(" Expression ")"
- | "exit"
+ | ">" File
+ | ">>" File
| "cat" Parameters
+ | "concatenate"
+ | "count"
+ | "digits"
| "echo" Parameters
- | "ls" Parameters
- | "stdin"
- | "{" [String {"," String}] "}"
| "error" [String]
- | "suppress"
- | ">" File
- | ">>" File
- | "if" Expression "then" Expression ["else" Expression] "end" ["if"]
+ | "execute"
+ | "everything"
+ | "exit"
| "foreach" Expression "then" Expression ["else" Expression] "end" ["foreach"].
- | "id"
- | "count"
| "group"
- | "concatenate"
+ | "id"
+ | "if" Expression "then" Expression ["else" Expression] "end" ["if"]
+ | "letters"
+ | "line"
+ | "ls" Parameters
+ | "marked"
+ | "nested" Expression "in" Expression "end" ["nested"]
+ | "nothing"
+ | "stdin"
+ | "substring" String
+ | "suppress"
+ | "unparse"
| "uppercase"
| "while" Expression "do" Expression "end" ["while"]
- | "nested" Expression "in" Expression "end" ["nested"]
| "whitespace"
- | "line"
- | "letters"
- | "digits"
- | "substring" String
+ | "XML.parse"
+ | "XML.element"
+ | "XML.attribute"
+ | "XML.attribute-name"
+ | "XML.attribute-value"
+ | "XML.element-content"
+ | "XML.element-name"
+ | "{" [String {"," String}] "}"
| NativeCommand.
diff --git a/scc.cabal b/scc.cabal
--- a/scc.cabal
+++ b/scc.cabal
@@ -1,5 +1,5 @@
Name: scc
-Version: 0.2
+Version: 0.3
Cabal-Version: >= 1.2
Build-Type: Simple
Synopsis: Streaming component combinators
@@ -10,13 +10,13 @@
types, a number of primitive streaming components and a set of component combinators. Finally,
there is an executable that exposes all functionality in a command-line shell.
.
- The original library design is based on paper
+ The original library design is based on paper
.
Mario Blažević, Streaming component combinators, Extreme Markup Languages, 2006.
License: GPL
License-file: LICENSE.txt
-Copyright: (c) 2008 Mario Blazevic
+Copyright: (c) 2008-2009 Mario Blazevic
Author: Mario Blazevic
Maintainer: blamario@yahoo.com
Extra-source-files: grammar.bnf Makefile LICENSE.txt Test.hs
@@ -24,11 +24,21 @@
Executable shsh
Main-is: Shell.hs
Other-Modules: Control.Concurrent.SCC.Foundation, Control.Concurrent.SCC.ComponentTypes,
- Control.Concurrent.SCC.Components, Control.Concurrent.SCC.Combinators
+ Control.Concurrent.SCC.Combinators,
+ Control.Concurrent.SCC.Components, Control.Concurrent.SCC.XMLComponents
Build-Depends: base, containers, mtl, parallel, process, readline, parsec >= 3
GHC-options: "-threaded"
+Executable test
+ Main-is: Test.hs
+ Other-Modules: Control.Concurrent.SCC.Foundation, Control.Concurrent.SCC.ComponentTypes,
+ Control.Concurrent.SCC.Combinators,
+ Control.Concurrent.SCC.Components, Control.Concurrent.SCC.XMLComponents
+ Build-Depends: base, containers, mtl, parallel, QuickCheck < 2
+ GHC-options: "-threaded"
+
Library
Exposed-Modules: Control.Concurrent.SCC.Foundation, Control.Concurrent.SCC.ComponentTypes,
- Control.Concurrent.SCC.Components, Control.Concurrent.SCC.Combinators
+ Control.Concurrent.SCC.Combinators,
+ Control.Concurrent.SCC.Components, Control.Concurrent.SCC.XMLComponents
Build-Depends: base, containers, mtl, parallel