scc 0.2 → 0.3
raw patch · 10 files changed
+2663/−1493 lines, 10 filesdep +QuickChecknew-component:exe:test
Dependencies added: QuickCheck
Files
- Control/Concurrent/SCC/Combinators.hs +1212/−1092
- Control/Concurrent/SCC/ComponentTypes.hs +169/−106
- Control/Concurrent/SCC/Components.hs +216/−100
- Control/Concurrent/SCC/Foundation.hs +30/−8
- Control/Concurrent/SCC/XMLComponents.hs +528/−0
- Makefile +15/−11
- Shell.hs +276/−83
- Test.hs +171/−72
- grammar.bnf +31/−16
- scc.cabal +15/−5
Control/Concurrent/SCC/Combinators.hs view
@@ -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- <http://www.gnu.org/licenses/>.--}--{-# 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+ <http://www.gnu.org/licenses/>.+-}++{-# 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)
Control/Concurrent/SCC/ComponentTypes.hs view
@@ -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 @@ <http://www.gnu.org/licenses/>. -} -{-# 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
Control/Concurrent/SCC/Components.hs view
@@ -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
Control/Concurrent/SCC/Foundation.hs view
@@ -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
+ Control/Concurrent/SCC/XMLComponents.hs view
@@ -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+ <http://www.gnu.org/licenses/>.+-}++-- | 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 "<?" true+ >>= whenNull (put edge (Start ProcessingInstructionText)+ >> processingInstruction)+ tag '!' = dispatchOnString source+ (\other-> put edge (Point (ErrorToken ("Expecting <![CDATA[ or <!--, received "+ ++ show ("<![" ++ other))))+ >> return ("<!" ++ other))+ [("--",+ \match-> 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 "<![CDATA[" #-}+ dispatchOnString source+ (\other-> 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)
Makefile view
@@ -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)
Shell.hs view
@@ -14,20 +14,22 @@ <http://www.gnu.org/licenses/>. -} -{-# 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')
Test.hs view
@@ -14,22 +14,24 @@ <http://www.gnu.org/licenses/>. -} -{-# 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 = "</" ++ name' ++ ">"++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 = "</" ++ name' ++ ">"++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 = "</" ++ name' ++ ">"++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 = "</" ++ name' ++ ">"+ 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)
grammar.bnf view
@@ -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.
scc.cabal view
@@ -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 <http://www.idealliance.org/papers/extreme/Proceedings/html/2006/Blazevic01/EML2006Blazevic01.html>+ The original library design is based on paper <http://conferences.idealliance.org/extreme/html/2006/Blazevic01/EML2006Blazevic01.html> . 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