scc 0.7.1 → 0.8
raw patch · 16 files changed
+1695/−1520 lines, 16 filesdep +haskelinedep +monoid-subclassesdep +test-frameworkdep −readlinedep ~incremental-parserdep ~monad-coroutinedep ~parsec
Dependencies added: haskeline, monoid-subclasses, test-framework, test-framework-quickcheck2
Dependencies removed: readline
Dependency ranges changed: incremental-parser, monad-coroutine, parsec, transformers
Files
- Control/Concurrent/Configuration.hs +3/−3
- Control/Concurrent/SCC/Coercions.hs +32/−14
- Control/Concurrent/SCC/Combinators.hs +394/−502
- Control/Concurrent/SCC/Combinators/Parallel.hs +23/−22
- Control/Concurrent/SCC/Combinators/Sequential.hs +22/−22
- Control/Concurrent/SCC/Configurable.hs +126/−125
- Control/Concurrent/SCC/Parallel.hs +3/−6
- Control/Concurrent/SCC/Primitives.hs +144/−125
- Control/Concurrent/SCC/Sequential.hs +3/−7
- Control/Concurrent/SCC/Streams.hs +303/−188
- Control/Concurrent/SCC/Types.hs +118/−59
- Control/Concurrent/SCC/XML.hs +90/−95
- Makefile +14/−13
- Shell.hs +253/−204
- Test/TestSCC.hs +133/−112
- scc.cabal +34/−23
Control/Concurrent/Configuration.hs view
@@ -1,5 +1,5 @@ {- - Copyright 2008-2010 Mario Blazevic+ Copyright 2008-2013 Mario Blazevic This file is part of the Streaming Component Combinators (SCC) project. @@ -25,9 +25,9 @@ module Control.Concurrent.Configuration (-- * The Component type Component (..),- -- * Utility functions+ -- ** Utility functions showComponentTree,- -- * Constructors+ -- ** Constructors atomic, lift, liftParallelPair, liftSequentialPair, parallelRouterAndBranches, recursiveComponentTree ) where
Control/Concurrent/SCC/Coercions.hs view
@@ -1,5 +1,5 @@ {- - Copyright 2009-2010 Mario Blazevic+ Copyright 2009-2012 Mario Blazevic This file is part of the Streaming Component Combinators (SCC) project. @@ -32,8 +32,11 @@ import Prelude hiding ((.)) import Control.Category ((.)) import Control.Monad (liftM)+import Data.Monoid (Monoid(mempty)) import Data.Text (Text, pack, unpack)- ++import Control.Monad.Coroutine (sequentialBinder)+ import Control.Concurrent.SCC.Streams import Control.Concurrent.SCC.Types @@ -42,41 +45,56 @@ class Coercible x y where -- | A 'Transducer' that converts a stream of one type to another. coerce :: Monad m => Transducer m x y- adaptConsumer :: Monad m => Consumer m y r -> Consumer m x r+ adaptConsumer :: (Monad m, Monoid x, Monoid y) => Consumer m y r -> Consumer m x r adaptConsumer consumer = isolateConsumer $ \source-> liftM snd $ pipe (transduce coerce source) (consume consumer)- adaptProducer :: Monad m => Producer m x r -> Producer m y r+ adaptProducer :: (Monad m, Monoid x, Monoid y) => Producer m x r -> Producer m y r adaptProducer producer = isolateProducer $ \sink-> liftM fst $ pipe (produce producer) (flip (transduce coerce) sink) instance Coercible x x where- coerce = Transducer pour+ coerce = Transducer pour_ adaptConsumer = id adaptProducer = id -instance Coercible Char Text where+instance Monoid x => Coercible [x] x where+ coerce = statelessTransducer id++instance Coercible [Char] [Text] where coerce = Transducer (mapStreamChunks ((:[]) . pack)) -instance Coercible Text Char where+instance Coercible String Text where+ coerce = Transducer (mapStreamChunks pack)++instance Coercible [Text] [Char] where coerce = statelessTransducer unpack -instance Coercible x y => Coercible [x] y where- coerce = coerce . statelessTransducer id+instance Coercible Text String where+ coerce = statelessChunkTransducer unpack -instance Coercible x y => Coercible (Markup b x) y where- coerce = coerce . statelessTransducer unmark+instance Coercible [x] [y] => Coercible [[x]] [y] where+ coerce = compose sequentialBinder (statelessTransducer id) coerce++instance Coercible [x] [y] => Coercible [Markup b x] [y] where+ coerce = compose sequentialBinder (statelessTransducer unmark) coerce where unmark (Content x) = [x] unmark (Markup _) = [] +instance (Monoid x, Monoid y, Coercible x y) => Coercible [Markup b x] y where+ coerce = compose sequentialBinder (statelessTransducer unmark) coerce+ where unmark (Content x) = x+ unmark (Markup _) = mempty+ -- | Adjusts the argument splitter to split the stream of a data type 'Isomorphic' to the type it was meant to split.-adaptSplitter :: forall m x y b. (Monad m, Coercible x y, Coercible y x) => Splitter m x b -> Splitter m y b+adaptSplitter :: forall m x y b. (Monad m, Monoid x, Monoid y, Coercible x y, Coercible y x) =>+ Splitter m x -> Splitter m y adaptSplitter sx = - isolateSplitter $ \source true false edge->+ isolateSplitter $ \source true false-> pipe (transduce coerce source) (\source'-> pipe (\true'-> pipe- (\false'-> split sx source' true' false' edge) + (\false'-> split sx source' true' false') (flip (transduce coerce) false)) (flip (transduce coerce) true)) >> return ()
Control/Concurrent/SCC/Combinators.hs view
@@ -1,5 +1,5 @@-{- - Copyright 2008-2010 Mario Blazevic+{-+ Copyright 2008-2013 Mario Blazevic This file is part of the Streaming Component Combinators (SCC) project. @@ -15,7 +15,8 @@ -} {-# LANGUAGE ScopedTypeVariables, RankNTypes, KindSignatures, EmptyDataDecls,- MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, FunctionalDependencies, TypeFamilies #-}+ MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, OverlappingInstances,+ FunctionalDependencies, TypeFamilies #-} {-# OPTIONS_HADDOCK hide #-} -- | The "Combinators" module defines combinators applicable to values of the 'Transducer' and 'Splitter' types defined@@ -24,7 +25,7 @@ module Control.Concurrent.SCC.Combinators ( -- * Consumer, producer, and transducer combinators consumeBy, prepend, append, substitute,- PipeableComponentPair (compose), JoinableComponentPair (join, sequence),+ JoinableComponentPair (join, sequence), -- * Splitter combinators sNot, -- ** Pseudo-logic flow combinators@@ -66,21 +67,25 @@ -- ** positional splitters startOf, endOf, between, -- * Parser support- splitterToMarker, parserToSplitter, parseRegions, parseNestedRegions, parseEachNestedRegion,+ splitterToMarker, splittersToPairMarker, parserToSplitter, parseRegions, -- * Helper functions groupMarks, findsTrueIn, findsFalseIn, teeConsumers ) where--import Prelude hiding (even, last, sequence, head)-import Control.Monad (liftM, when)+ +import Prelude hiding (drop, even, last, length, map, null, sequence)+import Control.Monad (liftM, void, when) import Control.Monad.Trans.Class (lift) import Data.Maybe (isJust, mapMaybe)+import Data.Monoid (Monoid, mempty, mconcat) import qualified Data.Foldable as Foldable+import qualified Data.List as List (map) import qualified Data.Sequence as Seq-import Data.Sequence (Seq, (|>), (><), ViewL (EmptyL, (:<)))+import Data.Sequence (Seq, (<|), (|>), (><), ViewL (EmptyL, (:<))) import Control.Monad.Coroutine+import Data.Monoid.Null (MonoidNull(null))+import Data.Monoid.Factorial (FactorialMonoid, length, drop, map) import Control.Concurrent.SCC.Streams import Control.Concurrent.SCC.Types@@ -90,54 +95,12 @@ consumeBy :: forall m x y r. (Monad m) => Consumer m x r -> Transducer m x y consumeBy c = Transducer $ \ source _sink -> consume c source >> return () --- | Class 'PipeableComponentPair' applies to any two components that can be combined into a third component with the--- following properties:------ * The input of the result, if any, becomes the input of the first component.------ * The output produced by the first child component is consumed by the second child component.------ * The result output, if any, is the output of the second component.-class PipeableComponentPair (m :: * -> *) w c1 c2 c3 | c1 c2 -> c3, c1 c3 -> c2, c2 c3 -> c2,- c1 -> m w, c2 -> m w, c3 -> m- where compose :: PairBinder m -> c1 -> c2 -> c3--instance forall m x. Monad m => PipeableComponentPair m x (Producer m x ()) (Consumer m x ()) (Performer m ())- where compose binder p c = let performPipe :: Coroutine Naught m ((), ())- performPipe = pipeG binder (produce p) (consume c)- in Performer (runCoroutine performPipe >> return ())--instance Monad m => PipeableComponentPair m y (Transducer m x y) (Consumer m y r) (Consumer m x r)- where compose binder t c = isolateConsumer $ \source-> - liftM snd $- pipeG binder- (transduce t source)- (consume c)--instance Monad m => PipeableComponentPair m x (Producer m x r) (Transducer m x y) (Producer m y r)- where compose binder p t = isolateProducer $ \sink-> - liftM fst $- pipeG binder- (produce p)- (\source-> transduce t source sink)--instance Monad m => PipeableComponentPair m y (Transducer m x y) (Transducer m y z) (Transducer m x z)- where compose binder t1 t2 = - isolateTransducer $ \source sink-> - pipeG binder (transduce t1 source) (\source'-> transduce t2 source' sink)- >> return ()- class CompatibleSignature c cons (m :: * -> *) input output | c -> cons m -class AnyListOrUnit c--instance AnyListOrUnit [x]-instance AnyListOrUnit ()--instance (AnyListOrUnit x, AnyListOrUnit y) => CompatibleSignature (Performer m r) (PerformerType r) m x y-instance AnyListOrUnit y => CompatibleSignature (Consumer m x r) (ConsumerType r) m [x] y-instance AnyListOrUnit y => CompatibleSignature (Producer m x r) (ProducerType r) m y [x]-instance CompatibleSignature (Transducer m x y) TransducerType m [x] [y]+instance CompatibleSignature (Performer m r) (PerformerType r) m x y+instance CompatibleSignature (Consumer m x r) (ConsumerType r) m x y+instance 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@@ -163,21 +126,21 @@ sequence :: c1 -> c2 -> c3 instance forall m x r1 r2. Monad m =>- JoinableComponentPair (ProducerType r1) (ProducerType r2) (ProducerType r2) m () [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 = Producer $ \sink-> produce p1 sink >> produce p2 sink instance forall m x. Monad m =>- JoinableComponentPair (ConsumerType ()) (ConsumerType ()) (ConsumerType ()) m [x] ()+ JoinableComponentPair (ConsumerType ()) (ConsumerType ()) (ConsumerType ()) m x () (Consumer m x ()) (Consumer m x ()) (Consumer m x ()) where join binder c1 c2 = Consumer (liftM (const ()) . teeConsumers binder (consume c1) (consume c2)) sequence c1 c2 = Consumer $ \source->- teeConsumers sequentialBinder (consume c1) getList source- >>= \((), list)-> pipe (putList list) (consume c2)+ teeConsumers sequentialBinder (consume c1) getAll source+ >>= \((), list)-> pipe (flip putChunk list) (consume c2) >> return () -instance forall m x y. Monad m =>- JoinableComponentPair TransducerType TransducerType TransducerType m [x] [y]+instance forall m x y. (Monad m, Monoid x, Monoid y) =>+ JoinableComponentPair TransducerType TransducerType TransducerType m x y (Transducer m x y) (Transducer m x y) (Transducer m x y) where join binder t1 t2 = isolateTransducer $ \source sink-> pipe@@ -185,12 +148,12 @@ (\source'-> transduce t1 source' sink) (\source'-> transduce t2 source' buffer) source)- getList- >>= \(_, list)-> putList list sink+ getAll+ >>= \(_, list)-> putChunk sink list >> return () sequence t1 t2 = isolateTransducer $ \source sink->- teeConsumers sequentialBinder (flip (transduce t1) sink) getList source- >>= \(_, list)-> pipe (putList list) (\source'-> transduce t2 source' sink)+ teeConsumers sequentialBinder (flip (transduce t1) sink) getAll source+ >>= \(_, list)-> pipe (flip putChunk list) (\source'-> transduce t2 source' sink) >> return () instance forall m r1 r2. Monad m =>@@ -200,31 +163,31 @@ sequence p1 p2 = Performer $ perform p1 >> perform p2 instance forall m x r1 r2. Monad m =>- JoinableComponentPair (PerformerType r1) (ProducerType r2) (ProducerType r2) m () [x]+ JoinableComponentPair (PerformerType r1) (ProducerType r2) (ProducerType r2) m () x (Performer m r1) (Producer m x r2) (Producer m x r2) where join binder pe pr = Producer $ \sink-> liftBinder binder (const return) (lift (perform pe)) (produce pr sink) sequence pe pr = Producer $ \sink-> lift (perform pe) >> produce pr sink instance forall m x r1 r2. Monad m =>- JoinableComponentPair (ProducerType r1) (PerformerType r2) (ProducerType r2) m () [x]+ JoinableComponentPair (ProducerType r1) (PerformerType r2) (ProducerType r2) m () x (Producer m x r1) (Performer m r2) (Producer m x r2) where join binder pr pe = Producer $ \sink-> liftBinder binder (const return) (produce pr sink) (lift (perform pe)) sequence pr pe = Producer $ \sink-> produce pr sink >> lift (perform pe) instance forall m x r1 r2. Monad m =>- JoinableComponentPair (PerformerType r1) (ConsumerType r2) (ConsumerType r2) m [x] ()+ JoinableComponentPair (PerformerType r1) (ConsumerType r2) (ConsumerType r2) m x () (Performer m r1) (Consumer m x r2) (Consumer m x r2) where join binder p c = Consumer $ \source-> liftBinder binder (const return) (lift (perform p)) (consume c source) sequence p c = Consumer $ \source-> lift (perform p) >> consume c source instance forall m x r1 r2. Monad m =>- JoinableComponentPair (ConsumerType r1) (PerformerType r2) (ConsumerType r2) m [x] ()+ JoinableComponentPair (ConsumerType r1) (PerformerType r2) (ConsumerType r2) m x () (Consumer m x r1) (Performer m r2) (Consumer m x r2) where join binder c p = Consumer $ \source-> liftBinder binder (const return) (consume c source) (lift (perform p)) sequence c p = Consumer $ \source-> consume c source >> lift (perform p) instance forall m x y r. Monad m =>- JoinableComponentPair (PerformerType r) TransducerType TransducerType m [x] [y]+ JoinableComponentPair (PerformerType r) TransducerType TransducerType m x y (Performer m r) (Transducer m x y) (Transducer m x y) where join binder p t = Transducer $ \ source sink -> @@ -232,7 +195,7 @@ sequence p t = Transducer $ \ source sink -> lift (perform p) >> transduce t source sink instance forall m x y r. Monad m- => JoinableComponentPair TransducerType (PerformerType r) TransducerType m [x] [y]+ => JoinableComponentPair TransducerType (PerformerType r) TransducerType m x y (Transducer m x y) (Performer m r) (Transducer m x y) where join binder t p = Transducer $ \ source sink -> @@ -241,56 +204,56 @@ _ <- lift (perform p) return result -instance forall m x y. Monad m =>- JoinableComponentPair (ProducerType ()) TransducerType TransducerType m [x] [y]+instance forall m x y. (Monad m, Monoid x, Monoid y) =>+ JoinableComponentPair (ProducerType ()) TransducerType TransducerType m x y (Producer m y ()) (Transducer m x y) (Transducer m x y) where join binder p t = isolateTransducer $ \source sink->- pipe (\buffer-> liftBinder binder (const return) (produce p sink) (transduce t source buffer)) getList- >>= \(_, out)-> putList out sink >> return ()+ pipe (\buffer-> liftBinder binder (const return) (produce p sink) (transduce t source buffer)) getAll+ >>= \(_, out)-> putChunk sink out >> return () sequence p t = Transducer $ \ source sink -> produce p sink >> transduce t source sink -instance forall m x y. Monad m =>- JoinableComponentPair TransducerType (ProducerType ()) TransducerType m [x] [y]+instance forall m x y. (Monad m, Monoid x, Monoid y) =>+ JoinableComponentPair TransducerType (ProducerType ()) TransducerType m x y (Transducer m x y) (Producer m y ()) (Transducer m x y) where join binder t p = isolateTransducer $ \source sink->- pipe (\buffer-> liftBinder binder (const . return) (transduce t source sink) (produce p buffer)) getList- >>= \(_, out)-> putList out sink >> return ()+ pipe (\buffer-> liftBinder binder (const . return) (transduce t source sink) (produce p buffer)) getAll+ >>= \(_, out)-> putChunk sink out >> return () sequence t p = Transducer $ \ source sink -> do result <- transduce t source sink produce p sink return result -instance forall m x y. Monad m =>- JoinableComponentPair (ConsumerType ()) TransducerType TransducerType m [x] [y]+instance forall m x y. (Monad m, Monoid x, Monoid y) =>+ JoinableComponentPair (ConsumerType ()) TransducerType TransducerType m x y (Consumer m x ()) (Transducer m x y) (Transducer m x y) where join binder c t = isolateTransducer $ \source sink-> teeConsumers binder (consume c) (\source'-> transduce t source' sink) source >> return () sequence c t = isolateTransducer $ \source sink->- teeConsumers sequentialBinder (consume c) getList source- >>= \(_, list)-> pipe (putList list) (\source'-> transduce t source' sink)+ teeConsumers sequentialBinder (consume c) getAll source+ >>= \(_, list)-> pipe (flip putChunk list) (\source'-> transduce t source' sink) >> return () -instance forall m x y. Monad m =>- JoinableComponentPair TransducerType (ConsumerType ()) TransducerType m [x] [y]+instance forall m x y. (Monad m, Monoid x, Monoid y) =>+ JoinableComponentPair TransducerType (ConsumerType ()) TransducerType m x y (Transducer m x y) (Consumer m x ()) (Transducer m x y) where join binder t c = join binder c t sequence t c = isolateTransducer $ \source sink->- teeConsumers sequentialBinder (\source'-> transduce t source' sink) getList source- >>= \(_, list)-> pipe (putList list) (consume c)+ teeConsumers sequentialBinder (\source'-> transduce t source' sink) getAll source+ >>= \(_, list)-> pipe (flip putChunk list) (consume c) >> return () instance forall m x y. Monad m =>- JoinableComponentPair (ProducerType ()) (ConsumerType ()) TransducerType m [x] [y]+ JoinableComponentPair (ProducerType ()) (ConsumerType ()) TransducerType m x y (Producer m y ()) (Consumer m x ()) (Transducer m x y) where join binder p c = Transducer $ \ source sink -> liftBinder binder (\ _ _ -> return ()) (produce p sink) (consume c source) sequence p c = Transducer $ \ source sink -> produce p sink >> consume c source instance forall m x y. Monad m =>- JoinableComponentPair (ConsumerType ()) (ProducerType ()) TransducerType m [x] [y]+ JoinableComponentPair (ConsumerType ()) (ProducerType ()) TransducerType m x y (Consumer m x ()) (Producer m y ()) (Transducer m x y) where join binder c p = join binder p c sequence c p = Transducer $ \ source sink -> consume c source >> produce p sink@@ -299,7 +262,7 @@ -- input through unmodified, except for prepending the output of the argument producer to it. The following law holds: @ -- 'prepend' /prefix/ = 'join' ('substitute' /prefix/) 'Control.Category.id' @ prepend :: forall m x r. Monad m => Producer m x r -> Transducer m x x-prepend prefixProducer = Transducer $ \ source sink -> produce prefixProducer sink >> pour source sink+prepend prefixProducer = Transducer $ \ source sink -> produce prefixProducer sink >> pour_ source sink -- | Combinator 'append' converts the given producer to a 'Control.Concurrent.SCC.Types.Transducer' that passes all its -- input through unmodified, finally appending the output of the argument producer to it. The following law holds: @@@ -309,139 +272,95 @@ -- | The 'substitute' combinator converts its argument producer to a 'Control.Concurrent.SCC.Types.Transducer' that -- produces the same output, while consuming its entire input and ignoring it.-substitute :: forall m x y r. Monad m => Producer m y r -> Transducer m x y-substitute feed = Transducer $ \ source sink -> mapMStream_ (const $ return ()) source >> produce feed sink >> return ()+substitute :: forall m x y r. (Monad m, Monoid x) => Producer m y r -> Transducer m x y+substitute feed = Transducer $ + \ source sink -> mapMStreamChunks_ (const $ return ()) source >> produce feed sink >> return () -- | The 'sNot' (streaming not) combinator simply reverses the outputs of the argument splitter. In other words, data -- that the argument splitter sends to its /true/ sink goes to the /false/ sink of the result, and vice versa.-sNot :: forall m x b. Monad m => Splitter m x b -> Splitter m x b+sNot :: forall m x. (Monad m, Monoid x) => Splitter m x -> Splitter m x sNot splitter = isolateSplitter s- where s :: forall d. Functor d => Source m d x -> Sink m d x -> Sink m d x -> Sink m d b -> Coroutine d m ()- s source true false _edge = split splitter source false true (nullSink :: Sink m d b)+ where s :: forall d. Functor d => Source m d x -> Sink m d x -> Sink m d x -> Coroutine d m ()+ s source true false = split splitter source false true -- | The 'sAnd' combinator sends the /true/ sink output of its left operand to the input of its right operand for -- further splitting. Both operands' /false/ sinks are connected to the /false/ sink of the combined splitter, but any -- input value to reach the /true/ sink of the combined component data must be deemed true by both splitters.-sAnd :: forall m x b1 b2. Monad m => PairBinder m -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)+sAnd :: forall m x. (Monad m, Monoid x) => PairBinder m -> Splitter m x -> Splitter m x -> Splitter m x sAnd binder s1 s2 =- isolateSplitter $ \ source true false edge ->- liftM (fst . fst) $- pipe- (\edges-> pipeG binder- (\true'-> split s1 source true' false (mapSink Left edges))- (\source'-> split s2 source' true false (mapSink Right edges)))- (flip intersectRegions edge)--intersectRegions :: forall m a1 a2 d b1 b2. Monad m => OpenTransducer m a1 a2 d (Either b1 b2) (b1, b2) ()-intersectRegions source sink = next Nothing Nothing- where next lastLeft lastRight = getWith- (either- (flip pair lastRight . Just)- (pair lastLeft . Just))- source- pair (Just x) (Just y) = put sink (x, y)- >> next Nothing Nothing- pair l r = next l r+ isolateSplitter $ \ source true false ->+ liftM fst $+ pipeG binder+ (\true'-> split s1 source true' false)+ (\source'-> split s2 source' true false) -- | A 'sOr' combinator's input value can reach its /false/ sink only by going through both argument splitters' /false/ -- sinks.-sOr :: forall m x b1 b2. Monad m => PairBinder m -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x (Either b1 b2)+sOr :: forall m x. (Monad m, Monoid x) => PairBinder m -> Splitter m x -> Splitter m x -> Splitter m x sOr binder s1 s2 = - isolateSplitter $ \ source true false edge ->+ isolateSplitter $ \ source true false -> liftM fst $ pipeG binder- (\false'-> split s1 source true false' (mapSink Left edge))- (\source'-> split s2 source' true false (mapSink Right edge))+ (\false'-> split s1 source true false')+ (\source'-> split s2 source' true false) -- | Combinator 'pAnd' is a pairwise logical conjunction of two splitters run in parallel on the same input.-pAnd :: forall m x b1 b2. Monad m => PairBinder m -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)-pAnd binder s1 s2 = - isolateSplitter $ \ source true false edge ->- pipeG binder- (transduce (splittersToPairMarker binder s1 s2) source)- (\source'-> let next l r = getWith (test l r) source'- test l r (Left (x, t1, t2)) = - (if t1 && t2 then put true x else put false x)- >> next (if t1 then l else Nothing) (if t2 then r else Nothing)- test _ Nothing (Right (Left l)) = next (Just l) Nothing- test _ (Just r) (Right (Left l)) = put edge (l, r) >> next (Just l) (Just r)- test Nothing _ (Right (Right r)) = next Nothing (Just r)- test (Just l) _ (Right (Right r)) = put edge (l, r) >> next (Just l) (Just r)- in next Nothing Nothing)- >> return ()+pAnd :: forall m x. (Monad m, FactorialMonoid x) => PairBinder m -> Splitter m x -> Splitter m x -> Splitter m x+pAnd = zipSplittersWith (&&) -- | Combinator 'pOr' is a pairwise logical disjunction of two splitters run in parallel on the same input.-pOr :: forall m x b1 b2. Monad m => PairBinder m -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x (Either b1 b2)-pOr = zipSplittersWith (||) pour+pOr :: forall m x. (Monad m, FactorialMonoid x) => PairBinder m -> Splitter m x -> Splitter m x -> Splitter m x+pOr = zipSplittersWith (||) -ifs :: forall c m x b. (Monad m, Branching c m x ()) => PairBinder m -> Splitter m x b -> c -> c -> c+ifs :: forall c m x. (Monad m, Branching c m x ()) => PairBinder m -> Splitter m x -> c -> c -> c ifs binder s c1 c2 = combineBranches if' binder c1 c2 where if' :: forall d. PairBinder m -> (forall a d'. AncestorFunctor d d' => OpenConsumer m a d' x ()) -> (forall a d'. AncestorFunctor d d' => OpenConsumer m a d' x ()) -> forall a. OpenConsumer m a d x () if' binder' c1' c2' source = splitInputToConsumers binder' s source c1' c2' -wherever :: forall m x b. Monad m => PairBinder m -> Transducer m x x -> Splitter m x b -> Transducer m x x+wherever :: forall m x. (Monad m, Monoid x) => PairBinder m -> Transducer m x x -> Splitter m x -> Transducer m x x wherever binder t s = isolateTransducer wherever' where wherever' :: forall d. Functor d => Source m d x -> Sink m d x -> Coroutine d m () wherever' source sink = pipeG binder- (\true-> split s source true sink (nullSink :: Sink m d b))+ (\true-> split s source true sink) (flip (transduce t) sink) >> return () -unless :: forall m x b. Monad m => PairBinder m -> Transducer m x x -> Splitter m x b -> Transducer m x x+unless :: forall m x. (Monad m, Monoid x) => PairBinder m -> Transducer m x x -> Splitter m x -> Transducer m x x unless binder t s = wherever binder t (sNot s) -select :: forall m x b. Monad m => Splitter m x b -> Transducer m x x+select :: forall m x. (Monad m, Monoid x) => Splitter m x -> Transducer m x x select s = isolateTransducer t where t :: forall d. Functor d => Source m d x -> Sink m d x -> Coroutine d m ()- t source sink = split s source sink (nullSink :: Sink m d x) (nullSink :: Sink m d b)+ t source sink = split s source sink (nullSink :: Sink m d x) -- | Converts a splitter into a parser.-parseRegions :: forall m x b. Monad m => Splitter m x b -> Parser m x b+parseRegions :: forall m x. (Monad m, MonoidNull x) => Splitter m x -> Parser m x () parseRegions s = isolateTransducer $ \source sink-> pipe (transduce (splitterToMarker s) source) (\source'-> concatMapAccumStream wrap Nothing source' sink >>= maybe (return ()) (put sink . flush)) >> return ()- where wrap Nothing (Left (x, _)) = (Nothing, [Content x])- wrap (Just p) (Left (x, False)) = (Nothing, [flush p, Content x])- wrap (Just (b, t)) (Left (x, True)) = (Just (b, True), if t then [Content x] else [Markup (Start b), Content x])- wrap (Just p) (Right b') = (Just (b', False), [flush p])- wrap Nothing (Right b) = (Just (b, False), [])+ where wrap Nothing (x, False) = (Nothing, if null x then [] else [Content x])+ wrap Nothing (x, True) | null x = (Just ((), False), [])+ | otherwise = (Just ((), True), [Markup (Start ()), Content x])+ wrap (Just p) (x, False) = (Nothing, if null x then [flush p] else [flush p, Content x])+ wrap (Just (b, t)) (x, True) = (Just (b, True), if t then [Content x] else [Markup (Start b), Content x]) flush (b, t) = Markup $ (if t then End else Point) b --- | Converts a boundary-marking splitter into a parser.-parseNestedRegions :: forall m x b. Monad m => Splitter m x (Boundary b) -> Parser m x b-parseNestedRegions s = isolateTransducer $ \source sink->- split s source (mapSink Content sink) (mapSink Content sink) (mapSink Markup sink)---- | Converts a boundary-marking splitter into a parser.-parseEachNestedRegion :: forall m x y b. Monad m =>- PairBinder m -> Splitter m x (Boundary b) -> Transducer m x y -> Transducer m x (Markup b y)-parseEachNestedRegion binder s t =- isolateTransducer $ \source sink->- let transformContent contentSource = transduce t contentSource (mapSink Content sink)- in pipeG binder- (transduce (splitterToMarker s) source)- (flip groupMarks (maybe transformContent (\mark group-> maybe (return ()) (put sink . Markup) mark- >> transformContent group)))- >> return ()- -- | The recursive combinator 'while' feeds the true sink of the argument splitter back to itself, modified by the -- argument transducer. Data fed to the splitter's false sink is passed on unmodified.-while :: forall m x b. Monad m => - PairBinder m -> Transducer m x x -> Splitter m x b -> Transducer m x x -> Transducer m x x+while :: forall m x. (Monad m, MonoidNull x) => + PairBinder m -> Transducer m x x -> Splitter m x -> Transducer m x x -> Transducer m x x while binder t s whileRest = isolateTransducer while' where while' :: forall d. Functor d => Source m d x -> Sink m d x -> Coroutine d m () while' source sink = pipeG binder- (\true'-> split s source true' sink (nullSink :: Sink m d b))- (\source'-> peek source'- >>= maybe - (return ())- (\_-> transduce (compose binder t whileRest) source' sink))+ (\true'-> split s source true' sink)+ (\source'-> getRead readEof source'+ >>= flip (when . not) (transduce (compose binder t whileRest) source' sink)) >> return () -- | The recursive combinator 'nestedIn' combines two splitters into a mutually recursive loop acting as a single@@ -450,26 +369,24 @@ -- hierarchically structured streams. If we gave it some input containing a flat sequence of values, and assuming both -- component splitters are deterministic and stateless, an input value would either not loop at all or it would loop -- forever.-nestedIn :: forall m x b. Monad m => - PairBinder m -> Splitter m x b -> Splitter m x b -> Splitter m x b -> Splitter m x b+nestedIn :: forall m x. (Monad m, MonoidNull x) => + PairBinder m -> Splitter m x -> Splitter m x -> Splitter m x -> Splitter m x nestedIn binder s1 s2 nestedRest =- isolateSplitter $ \ source true false edge ->+ isolateSplitter $ \ source true false -> liftM fst $ pipeG binder- (\false'-> split s1 source true false' edge)+ (\false'-> split s1 source true false') (\source'-> pipe (\true'-> splitInput s2 source' true' false)- (\source''-> peek source''- >>= maybe- (return ())- (\_-> split nestedRest source'' true false edge)))+ (\source''-> getRead readEof source''+ >>= flip (when . not) (split nestedRest source'' true false))) -- | The 'foreach' combinator is similar to the combinator 'ifs' in that it combines a splitter and two transducers into -- another transducer. However, in this case the transducers are re-instantiated for each consecutive portion of the -- input as the splitter chunks it up. Each contiguous portion of the input that the splitter sends to one of its two -- sinks gets transducered through the appropriate argument transducer as that transducer's whole input. As soon as the -- contiguous portion is finished, the transducer gets terminated.-foreach :: forall m x b c. (Monad m, Branching c m x ()) => PairBinder m -> Splitter m x b -> c -> c -> c+foreach :: forall m x c. (Monad m, MonoidNull x, Branching c m x ()) => PairBinder m -> Splitter m x -> c -> c -> c foreach binder s c1 c2 = combineBranches foreach' binder c1 c2 where foreach' :: forall d. PairBinder m -> (forall a d'. AncestorFunctor d d' => OpenConsumer m a d' x ()) ->@@ -479,79 +396,75 @@ liftM fst $ pipeG binder' (transduce (splitterToMarker s) (liftSource source :: Source m d x))- (\source'-> groupMarks source' (maybe c2' (const c1')))+ (\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 :: forall m x y b1 b2. (Monad m, Coercible x y) =>- PairBinder m -> Splitter m x b1 -> Splitter m y b2 -> Splitter m x b1+having :: forall m x y. (Monad m, MonoidNull x, MonoidNull y, Coercible x y) =>+ PairBinder m -> Splitter m x -> Splitter m y -> Splitter m x having binder s1 s2 = isolateSplitter s- where s :: forall d. Functor d => Source m d x -> Sink m d x -> Sink m d x -> Sink m d b1 -> Coroutine d m ()- s source true false edge = pipeG binder- (transduce (splitterToMarker s1) source)- (flip groupMarks test)- >> return ()- where test Nothing chunk = pour chunk false- test (Just mb) chunk = - do chunkBuffer <- getList chunk- (_, maybeFound) <- - pipe (produce $ adaptProducer $ Producer $ putList chunkBuffer) (findsTrueIn s2)- if isJust maybeFound - then maybe (return ()) (put edge) mb >> putList chunkBuffer true >> return ()- else putList chunkBuffer false >> return ()+ where s :: forall d. Functor d => Source m d x -> Sink m d x -> Sink m d x -> Coroutine d m ()+ s source true false = pipeG binder+ (transduce (splitterToMarker s1) source)+ (flip groupMarks test)+ >> return ()+ where test False chunk = pour_ chunk false+ test True chunk =+ do chunkBuffer <- getAll chunk+ (_, found) <- pipe (produce $ adaptProducer $ Producer $ putAll chunkBuffer) (findsTrueIn s2)+ if found+ then putChunk true chunkBuffer+ else putAll chunkBuffer false+ return () -- | The 'havingOnly' combinator is analogous to the 'having' combinator, but it succeeds and passes each chunk of the -- input to its /true/ sink only if the second splitter sends no part of it to its /false/ sink.-havingOnly :: forall m x y b1 b2. (Monad m, Coercible x y) =>- PairBinder m -> Splitter m x b1 -> Splitter m y b2 -> Splitter m x b1+havingOnly :: forall m x y. (Monad m, MonoidNull x, MonoidNull y, Coercible x y) =>+ PairBinder m -> Splitter m x -> Splitter m y -> Splitter m x havingOnly binder s1 s2 = isolateSplitter s- where s :: forall d. Functor d => Source m d x -> Sink m d x -> Sink m d x -> Sink m d b1 -> Coroutine d m ()- s source true false edge = pipeG binder- (transduce (splitterToMarker s1) source)- (flip groupMarks test)- >> return ()- where test Nothing chunk = pour chunk false- test (Just mb) chunk = - do chunkBuffer <- getList chunk- (_, anyFalse) <- - pipe (produce $ adaptProducer $ Producer $ putList chunkBuffer) (findsFalseIn s2)+ where s :: forall d. Functor d => Source m d x -> Sink m d x -> Sink m d x -> Coroutine d m ()+ s source true false = pipeG binder+ (transduce (splitterToMarker s1) source)+ (flip groupMarks test)+ >> return ()+ where test False chunk = pour_ chunk false+ test True chunk =+ do chunkBuffer <- getAll chunk+ (_, anyFalse) <-+ pipe (produce $ adaptProducer $ Producer $ putAll chunkBuffer) (findsFalseIn s2) if anyFalse- then putList chunkBuffer false >> return ()- else maybe (return ()) (put edge) mb >> putList chunkBuffer true >> return ()+ then putAll chunkBuffer false+ else putChunk true chunkBuffer+ return () -- | The result of combinator 'first' behaves the same as the argument splitter up to and including the first portion of -- the input which goes into the argument's /true/ sink. All input following the first true portion goes into the -- /false/ sink.-first :: forall m x b. Monad m => Splitter m x b -> Splitter m x b+first :: forall m x. (Monad m, MonoidNull x) => Splitter m x -> Splitter m x first splitter = wrapMarkedSplitter splitter $- \source true false edge-> - let true' = mapSink (\(Left (x, True))-> x) true- in pourUntil (either snd (const True)) source (mapSink (\(Left (x, False))-> x) false)- >>= maybe- (return ())- (\x-> either (const $ return ()) (\b-> put edge b >> get source >> return ()) x- >> pourWhile (either snd (const False)) source true'- >> mapMaybeStream (either (Just . fst) (const Nothing)) source false)+ \source true false->+ pourUntil (snd . head) source (markDown false)+ >>= Foldable.mapM_+ (\_-> pourWhile (snd . head) source (markDown true)+ >> concatMapStream fst source false) -- | The result of combinator 'uptoFirst' takes all input up to and including the first portion of the input which goes -- into the argument's /true/ sink and feeds it to the result splitter's /true/ sink. All the rest of the input goes -- into the /false/ sink. The only difference between 'first' and 'uptoFirst' combinators is in where they direct the -- /false/ portion of the input preceding the first /true/ part.-uptoFirst :: forall m x b. Monad m => Splitter m x b -> Splitter m x b+uptoFirst :: forall m x. (Monad m, MonoidNull x) => Splitter m x -> Splitter m x uptoFirst splitter = wrapMarkedSplitter splitter $- \source true false edge->- do (pfx, mx) <- getUntil (either snd (const True)) source- let prefix' = map (\(Left (x, False))-> x) pfx- true' = mapSink (\(Left (x, True))-> x) true+ \source true false->+ do (pfx, mx) <- getUntil (snd . head) source+ let prefix' = mconcat $ List.map (\(x, False)-> x) pfx maybe- (putList prefix' false >> return ())- (\x-> putList prefix' true- >> either (const $ return ()) (\b-> put edge b >> get source >> return ()) x- >> pourWhile (either snd (const False)) source true'- >> mapMaybeStream (either (Just . fst) (const Nothing)) source false)+ (putAll prefix' false >> return ())+ (\[x]-> putAll prefix' true+ >> pourWhile (snd . head) source (markDown true)+ >> concatMapStream fst source false) mx -- | The result of the combinator 'last' is a splitter which directs all input to its /false/ sink, up to the last@@ -559,365 +472,340 @@ -- the resulting component's /true/ sink. The splitter returned by the combinator 'last' has to buffer the previous two -- portions of its input, because it cannot know if a true portion of the input is the last one until it sees the end of -- the input or another portion succeeding the previous one.-last :: forall m x b. Monad m => Splitter m x b -> Splitter m x b+last :: forall m x. (Monad m, MonoidNull x) => Splitter m x -> Splitter m x last splitter = - wrapMarkedSplitter splitter $ \source true false edge->- let true' = mapSink (\(Left (x, _))-> x) true- false' = mapSink (\(Left (x, _))-> x) false- split1 Nothing = return []- split1 (Just (Left ~(_, True))) = split2 Nothing- split1 (Just (Right b)) = get source >> split2 (Just b)- split2 mb = getUntil (either (not . snd) (const True)) source >>= split3 mb- split3 mb (trues, Nothing) = maybe (return ()) (put edge) mb >> putList trues true'- split3 mb (trues, Just (Left ~(_, False))) = getUntil (either snd (const True)) source >>= split4 mb trues- split3 _ (trues, b@(Just Right{})) = putList trues false' >> split1 b- split4 mb ts (fs, Nothing) = maybe (return ()) (put edge) mb >> putList ts true' >> putList fs false'- split4 _ ts (fs, x@Just{}) = putList ts false' >> putList fs false' >> split1 x- in pourUntil (either snd (const True)) source false' >>= split1 >> return ()+ wrapMarkedSplitter splitter $ + \source true false->+ let split1 = getUntil (not . snd . head) source >>= split2+ split2 (trues, Nothing) = putChunk true (mconcat $ List.map fst trues)+ split2 (trues, Just [~(_, False)]) = getUntil (snd . head) source >>= split3 trues+ split3 ts (fs, Nothing) = putChunk true (mconcat $ List.map fst ts) >> putAll (mconcat $ List.map fst fs) false+ split3 ts (fs, x@Just{}) = putAll (mconcat $ List.map fst ts) false >> putAll (mconcat $ List.map fst fs) false + >> split1+ in pourUntil (snd . head) source (markDown false) + >>= Foldable.mapM_ (const split1) -- | The result of the combinator 'lastAndAfter' is a splitter which directs all input to its /false/ sink, up to the -- last portion of the input which goes to its argument's /true/ sink. That portion and the remainder of the input is -- fed to the resulting component's /true/ sink. The difference between 'last' and 'lastAndAfter' combinators is where -- they feed the /false/ portion of the input, if any, remaining after the last /true/ part.-lastAndAfter :: forall m x b. Monad m => Splitter m x b -> Splitter m x b+lastAndAfter :: forall m x. (Monad m, MonoidNull x) => Splitter m x -> Splitter m x lastAndAfter splitter = wrapMarkedSplitter splitter $- \source true false edge->- let true' = mapSink (\(Left (x, _))-> x) true- false' = mapSink (\(Left (x, _))-> x) false- split1 Nothing = return []- split1 (Just (Left ~(_, True))) = split2 Nothing- split1 (Just (Right b)) = get source >> split2 (Just b)- split2 mb = getUntil (either (not . snd) (const True)) source >>= split3 mb- split3 mb (trues, Nothing) = maybe (return ()) (put edge) mb >> putList trues true'- split3 mb (trues, Just (Left ~(_, False))) = getUntil (either snd (const True)) source >>= split4 mb trues- split3 _ (trues, b@(Just Right{})) = putList trues false' >> split1 b- split4 mb ts (fs, Nothing) = maybe (return ()) (put edge) mb >> putList ts true' >> putList fs true'- split4 _ ts (fs, x@Just{}) = putList ts false' >> putList fs false' >> split1 x- in pourUntil (either snd (const True)) source false' >>= split1 >> return ()+ \source true false->+ let split1 = getUntil (not . snd . head) source >>= split2+ split2 (trues, Nothing) = putChunk true (mconcat $ List.map fst trues)+ split2 (trues, Just [~(_, False)]) = getUntil (snd . head) source >>= split3 trues+ split3 ts (fs, Nothing) = putChunk true (mconcat $ List.map fst ts) >> putChunk true (mconcat $ List.map fst fs)+ split3 ts (fs, x@Just{}) = putAll (mconcat $ List.map fst ts) false >> putAll (mconcat $ List.map fst fs) false + >> split1+ in pourUntil (snd . head) source (markDown false) + >>= Foldable.mapM_ (const split1) -- | The 'prefix' combinator feeds its /true/ sink only the prefix of the input that its argument feeds to its /true/ -- sink. All the rest of the input is dumped into the /false/ sink of the result.-prefix :: forall m x b. Monad m => Splitter m x b -> Splitter m x b-prefix splitter = wrapMarkedSplitter splitter $- \source true false edge->- peek source- >>= maybe- (return ())- (\x0-> either (return . snd) (\x-> put edge x >> get source >> return True) x0- >>= flip when (pourWhile (either snd (const False))- source - (mapSink (\(Left (x, True))-> x) true))- >> mapMaybeStream (either (Just . fst) (const Nothing)) source false)+prefix :: forall m x. (Monad m, MonoidNull x) => Splitter m x -> Splitter m x+prefix splitter = wrapMarkedSplitter splitter splitMarked+ where splitMarked :: forall a1 a2 a3 d. (AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d,+ AncestorFunctor a1 (SinkFunctor d [(x, Bool)]),+ AncestorFunctor a2 (SourceFunctor d [(x, Bool)])) =>+ Source m a1 [(x, Bool)] -> Sink m a2 x -> Sink m a3 x -> Coroutine d m ()+ splitMarked source true false =+ pourUntil (not . null . fst . head) source (nullSink :: Sink m d [(x, Bool)])+ >>= maybe+ (return ())+ (\[x0]-> when (snd x0) (pourWhile (snd . head) source (markDown true))+ >> concatMapStream fst source false) -- | The 'suffix' combinator feeds its /true/ sink only the suffix of the input that its argument feeds to its /true/ -- sink. All the rest of the input is dumped into the /false/ sink of the result.-suffix :: forall m x b. Monad m => Splitter m x b -> Splitter m x b+suffix :: forall m x. (Monad m, MonoidNull x) => Splitter m x -> Splitter m x suffix splitter = wrapMarkedSplitter splitter $- \source true false edge->- let true' = mapSink (\(Left (x, _))-> x) true- false' = mapSink (\(Left (x, _))-> x) false- split0 = pourUntil (either snd (const True)) source false' >>= split1- split1 Nothing = return []- split1 (Just Left{}) = split2 Nothing- split1 (Just (Right b)) = get source >> split2 (Just b)- split2 mb = getUntil (either (not . snd) (const True)) source >>= split3 mb- split3 mb (trues, Nothing) = maybe (return ()) (put edge) mb >> putList trues true'- split3 _ (trues, Just{}) = putList trues false' >> split0- in split0 >> return ()+ \source true false->+ let split0 = pourUntil (snd . head) source (markDown false)+ >>= Foldable.mapM_ (const split1)+ split1 = getUntil (not . snd . head) source >>= split2+ split2 (trues, Nothing) = putAll (mconcat $ List.map fst trues) true >> return ()+ split2 (trues, Just [(x, False)]) + | null x = do (_, mr) <- getUntil (not . null . fst . head) source+ case mr of Nothing -> putAll (mconcat $ List.map fst trues) true + >> return ()+ Just{} -> putAll (mconcat $ List.map fst trues) false + >> split0+ | otherwise = putAll (mconcat $ List.map fst trues) false >> split0+ in split0 -- | The 'even' combinator takes every input section that its argument /splitter/ deems /true/, and feeds even ones into -- its /true/ sink. The odd sections and parts of input that are /false/ according to its argument splitter are fed to -- 'even' splitter's /false/ sink.-even :: forall m x b. Monad m => Splitter m x b -> Splitter m x b+even :: forall m x. (Monad m, MonoidNull x) => Splitter m x -> Splitter m x even splitter = wrapMarkedSplitter splitter $- \source true false edge->- let true' = mapSink (\(Left (x, _))-> x) true- false' = mapSink (\(Left (x, _))-> x) false- split0 = pourUntil (either snd (const True)) source false' >>= split1+ \source true false->+ let false' = markDown false+ split0 = pourUntil (snd . head) source false' >>= split1 split1 Nothing = return ()- split1 (Just (Left ~(_, True))) = split2- split1 (Just Right{}) = get source >> split2- split2 = pourUntil (either (not . snd) (const True)) source false' >>= split3+ split1 (Just [~(_, True)]) = split2+ split2 = pourUntil (not . snd . head) source false' >>= split3 split3 Nothing = return ()- split3 (Just (Left ~(_, False))) = pourUntil (either snd (const True)) source false' >>= split4- split3 r@(Just Right{}) = split4 r+ split3 (Just [~(_, False)]) = pourUntil (snd . head) source false' >>= split4 split4 Nothing = return ()- split4 (Just (Left ~(_, True))) = split5- split4 (Just (Right b)) = put edge b >> get source >> split5- split5 = pourWhile (either snd (const False)) source true' >> split0+ split4 (Just [~(_, True)]) = split5+ split5 = pourWhile (snd . head) source (markDown true) >> split0 in split0 -- | Splitter 'startOf' issues an empty /true/ section at the beginning of every section considered /true/ by its -- argument splitter, otherwise the entire input goes into its /false/ sink.-startOf :: forall m x b. Monad m => Splitter m x b -> Splitter m x (Maybe b)+startOf :: forall m x. (Monad m, MonoidNull x) => Splitter m x -> Splitter m x startOf splitter = wrapMarkedSplitter splitter $- \source _true false edge->- let false' = mapSink (\(Left (x, _))-> x) false- split0 = pourUntil (either snd (const True)) source false' >>= split1+ \source true false->+ let false' = markDown false+ split0 = pourUntil (snd . head) source false' >>= split1 split1 Nothing = return ()- split1 (Just (Left ~(_, True))) = put edge Nothing >> split2- split1 (Just (Right b)) = put edge (Just b) >> get source >> split2- split2 = pourUntil (either (not . snd) (const True)) source false' >>= split3+ split1 (Just [~(_, True)]) = putChunk true mempty >> split2+ split2 = pourUntil (not . snd . head) source false' >>= split3 split3 Nothing = return ()- split3 (Just (Left ~(_, False))) = split0- split3 mb@(Just Right{}) = split1 mb+ split3 (Just [~(_, False)]) = split0 in split0 -- | Splitter 'endOf' issues an empty /true/ section at the end of every section considered /true/ by its argument -- splitter, otherwise the entire input goes into its /false/ sink.-endOf :: forall m x b. Monad m => Splitter m x b -> Splitter m x (Maybe b)+endOf :: forall m x. (Monad m, MonoidNull x) => Splitter m x -> Splitter m x endOf splitter = wrapMarkedSplitter splitter $- \source _true false edge->- let false' = mapSink (\(Left (x, _))-> x) false- split0 = pourUntil (either snd (const True)) source false' >>= split1+ \source true false->+ let false' = markDown false+ split0 = pourUntil (snd . head) source false' >>= split1 split1 Nothing = return ()- split1 (Just (Left ~(_, True))) = split2 Nothing- split1 (Just (Right b)) = get source >> split2 (Just b)- split2 mb = pourUntil (either (not . snd) (const True)) source false' - >>= (put edge mb >>) . split3+ split1 (Just [~(_, True)]) = split2+ split2 = pourUntil (not . snd . head) source false'+ >>= (putChunk true mempty >>) . split3 split3 Nothing = return ()- split3 (Just (Left ~(_, False))) = split0- split3 mb@(Just Right{}) = split1 mb+ split3 (Just [~(_, False)]) = split0 in split0 -- | 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. Monad m => PairBinder m -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)-followedBy binder s1 s2 = - isolateSplitter $ \ source true false edge ->+followedBy :: forall m x. (Monad m, FactorialMonoid x) => PairBinder m -> Splitter m x -> Splitter m x -> Splitter m x+followedBy binder s1 s2 =+ isolateSplitter $ \ source true false -> pipeG binder (transduce (splitterToMarker s1) source)- (\source'-> let get0 q = case Seq.viewl q- of Seq.EmptyL -> split0- (Left (x, False)) :< rest -> put false x >> get0 rest- (Left (_, True)) :< _ -> get2 Nothing Seq.empty q- (Right b) :< rest -> get2 (Just b) Seq.empty rest- false' = mapSink (\(Left (x, _))-> x) false- true' = mapSink (\(Left (x, _))-> x) true- split0 = pourUntil (either snd (const True)) source' false'- >>= maybe - (return ()) - (either (const $ split1 Nothing) (\b-> get source' >> split1 (Just b)))- split1 mb = do (list, mx) <- getUntil (either (not . snd) (const True)) source'- let list' = Seq.fromList $ map (\(Left (x, True))-> x) list- maybe- (testEnd mb (Seq.fromList $ map (\(Left (x, True))-> x) list))- ((get source' >>) . get3 mb list' . Seq.singleton)- mx- 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 (_, False)) :< _ -> get3 mb q q'- Right{} :< _ -> get3 mb q q'- get3 mb q q' = do let list = mapMaybe - (either (Just . fst) (const Nothing)) - (Foldable.toList $ Seq.viewl q')- (q'', mn) <- pipe (\sink-> putList list sink >> get7 q' sink) (test mb q)- case mn of Nothing -> putQueue q false >> get0 q''- Just 0 -> get0 q''- Just n -> get8 (Just mb) n q''- get7 q sink = do list <- getWhile (either (const True) (const False)) source'- rest <- putList (map (\(Left (x, _))-> x) list) sink- let q' = q >< Seq.fromList list- if null rest - then get source' >>= maybe (return q') (\x-> get7 (q' |> x) sink)- else return q'- testEnd mb q = do ((), n) <- pipe (const $ return ()) (test mb q)- case n of Nothing -> putQueue q false >> return ()- _ -> return ()- test mb q source'' = liftM snd $- pipe- (transduce (splitterToMarker s2) source'')- (\source'''-> let test0 (Left (_, False)) = get source''' - >> return Nothing- test0 (Left (_, True)) = test1- test0 (Right b') = maybe - (return ()) - (\b-> put edge (b, b')) - mb- >> get source'''- >> test1- test1 = putQueue q true- >> getWhile (either snd (const False)) source'''- >>= \list-> putList list true'- >> get source'''- >> return (Just $ length list)- in peek source''' >>= maybe (return Nothing) test0)- 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 (_, False) :< rest -> get8 Nothing (pred n) rest- Left (_, True) :< rest -> get8 (maybe (Just Nothing) Just mmb) (pred n) rest- Right b :< rest -> get8 (Just (Just b)) n rest- EmptyL -> error "Expecting a non-empty queue!" - in split0)- >> return ()+ (\source'->+ let false' = markDown false+ get0 q = case Seq.viewl q+ of Seq.EmptyL -> split0+ (x, False) :< rest -> putChunk false x >> get0 rest+ (_, True) :< _ -> get2 Seq.empty q+ split0 = pourUntil (snd . head) source' false'+ >>= maybe+ (return ())+ (const $ split1) + split1 = do (list, mx) <- getUntil (not . snd . head) source'+ let list' = Seq.fromList $ List.map (\(x, True)-> x) list+ maybe+ (testEnd (Seq.fromList $ List.map (\(x, True)-> x) list))+ ((getPrime source' >>) . get3 list' . Seq.singleton . head)+ mx+ 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+ (_, False) :< _ -> get3 q q'+ get3 q q' = do let list = mconcat $ List.map fst (Foldable.toList $ Seq.viewl q')+ (q'', mn) <- pipe (\sink-> putAll list sink >> get7 q' sink) (test q)+ case mn of Nothing -> putQueue q false >> get0 q''+ Just 0 -> get0 q''+ Just n -> get8 True n q''+ get7 q sink = do list <- getWhile (const True . head) source'+ rest <- putAll (mconcat $ List.map (\(x, _)-> x) list) sink+ let q' = q >< Seq.fromList list+ if null rest+ then get source' >>= maybe (return q') (\x-> get7 (q' |> x) sink)+ else return q'+ testEnd q = do ((), n) <- pipe (const $ return ()) (test q)+ case n of Nothing -> putQueue q false >> return ()+ _ -> return ()+ test q source'' = liftM snd $+ pipe+ (transduce (splitterToMarker s2) source'')+ (\source'''-> + let test0 (x, False) = getPrime source'''+ >> if null x then try0 else return Nothing+ test0 (_, True) = test1+ test1 = do putQueue q true+ list <- getWhile (snd . head) source'''+ let chunk = mconcat (List.map fst list)+ putChunk true chunk+ getPrime source'''+ return (Just $ length chunk)+ try0 = peek source''' >>= maybe (return Nothing) test0+ in try0)+ get8 False 0 q = get0 q+ get8 True 0 q = get2 Seq.empty q+ get8 _ n q | n > 0 =+ case Seq.viewl q+ of (x, False) :< rest | length x > n -> get0 ((drop n x, False) <| rest)+ | otherwise -> get8 False (n - length x) rest+ (x, True) :< rest | length x > n -> get2 Seq.empty ((drop n x, True) <| rest)+ | otherwise -> get8 True (n - length x) rest+ EmptyL -> error "Expecting a non-empty queue!"+ in split0)+ >> return () -- | Combinator 'between' tracks the running balance of difference between the number of preceding starts of sections -- considered /true/ according to its first argument and the ones according to its second argument. The combinator -- passes to /true/ all input values for which the difference balance is positive. This combinator is typically used -- with 'startOf' and 'endOf' in order to count entire input sections and ignore their lengths.-between :: forall m x b1 b2. Monad m => PairBinder m -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x b1-between binder s1 s2 = isolateSplitter $ \ source true false edge ->- pipeG binder- (transduce (splittersToPairMarker binder s1 s2) source)- (let pass n x = (if n > 0 then put true x else put false x)- >> return n- pass' n x = (if n >= 0 then put true x else put false x)- >> return n- state n (Left (x, True, False)) = pass (succ n) x- state n (Left (x, False, True)) = pass' (pred n) x- state n (Left (x, True, True)) = pass' n x- state n (Left (x, False, False)) = pass n x- state 0 (Right (Left b)) = put edge b >> return 1- state n (Right (Left _)) = return (succ n)- state n (Right (Right _)) = return (pred n)- in foldMStream_ state (0 :: Int))- >> return ()+between :: forall m x. (Monad m, FactorialMonoid x) => PairBinder m -> Splitter m x -> Splitter m x -> Splitter m x+between binder s1 s2 = isolateSplitter $+ \ source true false ->+ pipeG binder+ (transduce (splittersToPairMarker binder s1 s2) source)+ (let pass n x = (if n > 0 then putChunk true x else putChunk false x)+ >> return n+ pass' n x = (if n >= 0 then putChunk true x else putChunk false x)+ >> return n+ state n (x, True, False) = pass (succ n) x+ state n (x, False, True) = pass' (pred n) x+ state n (x, True, True) = pass' n x+ state n (x, False, False) = pass n x+ in foldMStream_ state (0 :: Int))+ >> return () -- Helper functions wrapMarkedSplitter ::- forall m x b1 b2. Monad m =>- Splitter m x b1- -> (forall a1 a2 a3 a4 d. (AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d, AncestorFunctor a4 d) =>- Source m a1 (Either (x, Bool) b1) -> Sink m a2 x -> Sink m a3 x -> Sink m a4 b2 -> Coroutine d m ())- -> Splitter m x b2-wrapMarkedSplitter splitter splitMarked = isolateSplitter $ \ source true false edge ->+ forall m x. (Monad m, MonoidNull x) =>+ Splitter m x+ -> (forall a1 a2 a3 d. (AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d,+ AncestorFunctor a1 (SinkFunctor d [(x, Bool)]),+ AncestorFunctor a2 (SourceFunctor d [(x, Bool)])) =>+ Source m a1 [(x, Bool)] -> Sink m a2 x -> Sink m a3 x -> Coroutine d m ())+ -> Splitter m x+wrapMarkedSplitter splitter splitMarked = isolateSplitter $ + \ source true false -> pipe (transduce (splitterToMarker splitter) source)- (\source'-> splitMarked source' true false edge)+ (\source'-> splitMarked source' true false) >> return () -splitterToMarker :: forall m x b. Monad m => Splitter m x b -> Transducer m x (Either (x, Bool) b)-splitterToMarker s = isolateTransducer $ \source sink->- split s source- (mapSink (\x-> Left (x, True)) sink)- (mapSink (\x-> Left (x, False)) sink)- (mapSink Right sink)+splitterToMarker :: forall m x. (Monad m, MonoidNull x) => Splitter m x -> Transducer m x [(x, Bool)]+splitterToMarker s = isolateTransducer mark+ where mark :: forall d. Functor d => Source m d x -> Sink m d [(x, Bool)] -> Coroutine d m ()+ mark source sink = split s source (markUpWith True sink) (markUpWith False sink) -parserToSplitter :: forall m x b. Monad m => Parser m x b -> Splitter m x (Boundary b)-parserToSplitter t = isolateSplitter $ \ source true false edge ->+parserToSplitter :: forall m x b. (Monad m, Monoid x) => Parser m x b -> Splitter m x+parserToSplitter t = isolateSplitter $ \ source true false -> pipe (transduce t source)- (\source-> let true' = mapSink fromContent true- false' = mapSink fromContent false- topLevel = pourWhile isContent source false'- >> get source - >>= maybe (return ()) (\x-> handleMarkup x >> topLevel)- handleMarkup (Markup p@Point{}) = put edge p >> return True- handleMarkup (Markup s@Start{}) = put edge s >> handleRegion >> return True- handleMarkup (Markup e@End{}) = put edge e >> return False- handleRegion = pourWhile isContent source true'- >> get source- >>= maybe (return ()) (\x -> handleMarkup x - >>= flip when handleRegion)- in topLevel)+ (\source-> + pipe (\true'->+ pipe (\false'->+ let topLevel = pourWhile isContent source false'+ >> get source + >>= maybe (return ()) (\x-> handleMarkup x >> topLevel)+ handleMarkup (Markup p@Point{}) = putChunk true mempty >> return True+ handleMarkup (Markup s@Start{}) = putChunk true mempty >> handleRegion >> return True+ handleMarkup (Markup e@End{}) = putChunk false mempty >> return False+ handleRegion = pourWhile isContent source true'+ >> get source+ >>= maybe (return ()) (\x -> handleMarkup x + >>= flip when handleRegion)+ in topLevel)+ (\src-> concatMapStream (\(Content x)-> x) src false))+ (\src-> concatMapStream (\(Content x)-> x) src true))+ >> return ()- where isContent Markup{} = False- isContent Content{} = True+ where isContent [Markup{}] = False+ isContent [Content{}] = True fromContent (Content x) = x -splittersToPairMarker :: forall m x b1 b2. Monad m => PairBinder m -> Splitter m x b1 -> Splitter m x b2 ->- Transducer m x (Either (x, Bool, Bool) (Either b1 b2))+splittersToPairMarker :: forall m x. (Monad m, FactorialMonoid x) => PairBinder m -> Splitter m x -> Splitter m x ->+ Transducer m x [(x, Bool, Bool)] splittersToPairMarker binder s1 s2 = let synchronizeMarks :: forall a1 a2 d. (AncestorFunctor a1 d, AncestorFunctor a2 d) =>- Sink m a1 (Either (x, Bool, Bool) (Either b1 b2))- -> Source m a2 (Either ((x, Bool), Bool) (Either b1 b2))- -> Coroutine d m (Maybe (Seq (Either (x, Bool) (Either b1 b2)), Bool))+ Sink m a1 [(x, Bool, Bool)]+ -> Source m a2 [((x, Bool), Bool)]+ -> Coroutine d m (Maybe (Seq (x, Bool), Bool)) synchronizeMarks sink source = foldMStream handleMark Nothing source where- handleMark Nothing (Right b) = put sink (Right b) >> return Nothing- handleMark Nothing (Left (p, head)) = return (Just (Seq.singleton (Left p), head))- handleMark (Just (q, head)) (Left (p, head')) | head == head' = return (Just (q |> Left p, head))- handleMark (Just (q, True)) (Right b@Left{}) = return (Just (q |> Right b, True))- handleMark (Just (q, False)) (Right b@Right{}) = return (Just (q |> Right b, False))- handleMark state (Right b) = put sink (Right b) >> return state- handleMark (Just (q, pos')) mark@(Left (p@(_, t), pos))- = case Seq.viewl q- of Seq.EmptyL -> return (Just (Seq.singleton (Left p), pos))- Right b :< rest -> put sink (Right b)- >> handleMark (if Seq.null rest then Nothing else Just (rest, pos')) mark- Left (y, t') :< rest -> put sink (Left $ if pos then (y, t, t') else (y, t', t))- >> return (if Seq.null rest then Nothing else Just (rest, pos'))+ handleMark Nothing (p@(x, _), b) = return (Just (Seq.singleton p, b))+ handleMark (Just (q, b)) mark@(p@(x, t), b')+ | b == b' = return (Just (q |> p, b))+ | otherwise = case Seq.viewl q+ of Seq.EmptyL -> handleMark Nothing mark+ (y, t') :< rest -> put sink (if b then (common, t', t) else (common, t, t'))+ >> if lx == ly+ then return (if Seq.null rest then Nothing else Just (rest, b))+ else if lx < ly + then return (Just ((leftover, t') <| rest, b))+ else handleMark (if Seq.null rest then Nothing + else Just (rest, b)) + ((leftover, t), b')+ where lx = length x+ ly = length y+ (common, leftover) = if lx < ly then (x, drop lx y) else (y, drop ly x) in isolateTransducer $ \source sink-> pipe (\sync-> teeConsumers binder- (\source1-> split s1 source1- (mapSink (\x-> Left ((x, True), True)) sync)- (mapSink (\x-> Left ((x, False), True)) sync)- (mapSink (Right. Left) sync))- (\source2-> split s2 source2- (mapSink (\x-> Left ((x, True), False)) sync)- (mapSink (\x-> Left ((x, False), False)) sync)- (mapSink (Right . Right) sync))+ (\source1-> transduce (splitterToMarker s1) source1 (mapSink (\x-> (x, True)) sync))+ (\source2-> transduce (splitterToMarker s2) source2 (mapSink (\x-> (x, False)) sync)) source)- (synchronizeMarks sink)+ (synchronizeMarks sink) >> return () -zipSplittersWith :: forall m x b1 b2 b. Monad m => - (Bool -> Bool -> Bool) -> - (forall a1 a2 d. (AncestorFunctor a1 d, AncestorFunctor a2 d) =>- Source m a1 (Either b1 b2) -> Sink m a2 b -> Coroutine d m ()) -> - PairBinder m -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x b-zipSplittersWith f boundaries binder s1 s2- = isolateSplitter $ \ source true false edge ->- pipe- (\edge'->- pipeG binder- (transduce (splittersToPairMarker binder s1 s2) source)- (mapMStream_- (either- (\(x, t1, t2)-> if f t1 t2 then put true x else put false x)- (put edge'))))- (flip boundaries edge)+zipSplittersWith :: forall m x. (Monad m, FactorialMonoid x) =>+ (Bool -> Bool -> Bool) -> PairBinder m -> Splitter m x -> Splitter m x -> Splitter m x+zipSplittersWith f binder s1 s2+ = isolateSplitter $ \ source true false ->+ pipeG binder+ (transduce (splittersToPairMarker binder s1 s2) source)+ (mapMStream_ (\[(x, t1, t2)]-> if f t1 t2 then putChunk true x else putChunk false x)) >> return () -- | Runs the second argument on every contiguous region of input source (typically produced by 'splitterToMarker') -- whose all values either match @Left (_, True)@ or @Left (_, False)@.-groupMarks :: (Monad m, AncestorFunctor a d, AncestorFunctor a (SinkFunctor d x)) =>- Source m a (Either (x, Bool) b) ->- (Maybe (Maybe b) -> Source m (SourceFunctor d x) x -> Coroutine (SourceFunctor d x) m r) ->+groupMarks :: (Monad m, MonoidNull x, AncestorFunctor a d, AncestorFunctor a (SinkFunctor d x), + AncestorFunctor a (SinkFunctor (SinkFunctor d x) [(x, Bool)])) =>+ Source m a [(x, Bool)] ->+ (Bool -> Source m (SourceFunctor d x) x -> Coroutine (SourceFunctor d x) m r) -> Coroutine d m () groupMarks source getConsumer = peek source >>= loop- where loop = maybe (return ()) ((>>= loop . fst) . either startContent startRegion)- startContent (_, False) = pipe (next False) (getConsumer Nothing)- startContent (_, True) = pipe (next True) (getConsumer $ Just Nothing)- startRegion b = get source >> pipe (next True) (getConsumer (Just $ Just b))- next t sink = pourUntil (either (\(_, t')-> t /= t') (const True)) source (mapSink (\(Left (x, _))-> x) sink)+ where loop = maybe (return ()) ((>>= loop . fst) . startContent)+ startContent (_, False) = pipe (next False) (getConsumer False)+ startContent (_, True) = pipe (next True) (getConsumer True)+ next t sink = liftM (fmap head) $+ pourUntil ((\(_, t')-> t /= t') . head) source (markDown sink) -splitInput :: forall m a1 a2 a3 d x b. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d) =>- Splitter m x b -> Source m a1 x -> Sink m a2 x -> Sink m a3 x -> Coroutine d m ()-splitInput splitter source true false = split splitter source true false (nullSink :: Sink m d b)+splitInput :: forall m a1 a2 a3 d x. (Monad m, Monoid x, + AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d) =>+ Splitter m x -> Source m a1 x -> Sink m a2 x -> Sink m a3 x -> Coroutine d m ()+splitInput splitter source true false = split splitter source true false -findsTrueIn :: forall m a d x b. (Monad m, AncestorFunctor a d)- => Splitter m x b -> Source m a x -> Coroutine d m (Maybe (Maybe b))+findsTrueIn :: forall m a d x. (Monad m, MonoidNull x, AncestorFunctor a d)+ => Splitter m x -> Source m a x -> Coroutine d m Bool findsTrueIn splitter source = pipe- (\testTrue-> pipe- (split splitter (liftSource source :: Source m d x)- testTrue- (nullSink :: Sink m d x))- get)- get- >>= \(((), maybeEdge), maybeTrue)-> return $- case maybeEdge- of Nothing -> fmap (const Nothing) maybeTrue- _ -> Just maybeEdge+ (\testTrue-> split splitter (liftSource source :: Source m d x)+ testTrue+ (nullSink :: Sink m d x))+ (getRead readEof)+ >>= \((), eof)-> return $ not eof -findsFalseIn :: forall m a d x b. (Monad m, AncestorFunctor a d) => Splitter m x b -> Source m a x -> Coroutine d m Bool+findsFalseIn :: forall m a d x. (Monad m, MonoidNull x, AncestorFunctor a d) =>+ Splitter m x -> Source m a x -> Coroutine d m Bool findsFalseIn splitter source = pipe (\testFalse-> split splitter (liftSource source :: Source m d x) (nullSink :: Sink m d x)- testFalse- (nullSink :: Sink m d b))- get- >>= \((), maybeFalse)-> return (isJust maybeFalse)+ testFalse)+ (getRead readEof)+ >>= \((), eof)-> return $ not eof +readEof :: forall x. MonoidNull x => Reader x (Bool -> Bool) Bool+readEof x | null x = Deferred readEof True+ | otherwise = Final x False+ teeConsumers :: forall m a d x r1 r2. Monad m => PairBinder m -> (forall a'. OpenConsumer m a' (SourceFunctor (SinkFunctor d x) x) x r1)@@ -930,17 +818,21 @@ -- | Given a 'Splitter', a 'Source', and two consumer functions, 'splitInputToConsumers' runs the splitter on the source -- and feeds the splitter's /true/ and /false/ outputs, respectively, to the two consumers.-splitInputToConsumers :: forall m a d d1 x b. (Monad m, d1 ~ SinkFunctor d x, AncestorFunctor a d) =>- PairBinder m -> Splitter m x b -> Source m a x ->+splitInputToConsumers :: forall m a d d1 x. (Monad m, Monoid x, d1 ~ SinkFunctor d x, AncestorFunctor a d) =>+ PairBinder m -> Splitter m x -> Source m a x -> (Source m (SourceFunctor d1 x) x -> Coroutine (SourceFunctor d1 x) m ()) -> (Source m (SourceFunctor d x) x -> Coroutine (SourceFunctor d x) m ()) -> Coroutine d m () splitInputToConsumers binder s source trueConsumer falseConsumer = pipeG binder (\false-> pipeG binder- (\true-> split s source' true false (nullSink :: Sink m d b))+ (\true-> split s source' true false) trueConsumer) falseConsumer >> return () where source' :: Source m d x source' = liftSource source++-- | Like 'putAll', except it puts the contents of the given 'Data.Sequence.Seq' into the sink.+putQueue :: forall m a d x. (Monad m, MonoidNull x, AncestorFunctor a d) => Seq x -> Sink m a x -> Coroutine d m x+putQueue q sink = putAll (mconcat $ Foldable.toList $ Seq.viewl q) sink
Control/Concurrent/SCC/Combinators/Parallel.hs view
@@ -22,7 +22,7 @@ module Control.Concurrent.SCC.Combinators.Parallel ( -- * Consumer, producer, and transducer combinators Combinators.consumeBy, Combinators.prepend, Combinators.append, Combinators.substitute,- Combinators.PipeableComponentPair, (>->), Combinators.JoinableComponentPair (Combinators.sequence), join,+ PipeableComponentPair, (>->), Combinators.JoinableComponentPair (Combinators.sequence), join, -- * Splitter combinators Combinators.sNot, -- ** Pseudo-logic flow combinators@@ -64,15 +64,19 @@ -- ** positional splitters Combinators.startOf, Combinators.endOf, (...), -- * Parser support- Combinators.splitterToMarker, Combinators.parseRegions, Combinators.parseNestedRegions, parseEachNestedRegion,+ Combinators.splitterToMarker, Combinators.parseRegions, ) where import Prelude hiding ((&&), (||), even, last, sequence)+import Data.Monoid (Monoid) import Data.Text (Text) import Control.Monad.Parallel (MonadParallel) import Control.Monad.Coroutine (parallelBinder)+import Data.Monoid.Null (MonoidNull)+import Data.Monoid.Factorial (FactorialMonoid)+ import Control.Concurrent.SCC.Types import Control.Concurrent.SCC.Coercions (Coercible) import qualified Control.Concurrent.SCC.Combinators as Combinators@@ -86,8 +90,8 @@ -- * 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.-(>->) :: (MonadParallel m, Combinators.PipeableComponentPair m w c1 c2 c3) => c1 -> c2 -> c3-(>->) = Combinators.compose parallelBinder+(>->) :: (MonadParallel m, PipeableComponentPair m w c1 c2 c3) => c1 -> c2 -> c3+(>->) = compose parallelBinder -- | The 'join' combinator may apply the components in any order. join :: (MonadParallel m, Combinators.JoinableComponentPair t1 t2 t3 m x y c1 c2 c3) => c1 -> c2 -> c3@@ -96,38 +100,34 @@ -- | The '>&' combinator sends the /true/ sink output of its left operand to the input of its right operand for further -- splitting. Both operands' /false/ sinks are connected to the /false/ sink of the combined splitter, but any input -- value to reach the /true/ sink of the combined component data must be deemed true by both splitters.-(>&) :: forall m x b1 b2. MonadParallel m => Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)+(>&) :: (MonadParallel m, Monoid x) => Splitter m x -> Splitter m x -> Splitter m x (>&) = Combinators.sAnd parallelBinder -- | A '>|' combinator's input value can reach its /false/ sink only by going through both argument splitters' /false/ -- sinks.-(>|) :: forall m x b1 b2. MonadParallel m => Splitter m x b1 -> Splitter m x b2 -> Splitter m x (Either b1 b2) +(>|) :: (MonadParallel m, Monoid x) => Splitter m x -> Splitter m x -> Splitter m x (>|) = Combinators.sOr parallelBinder -- | Combinator '&&' is a pairwise logical conjunction of two splitters run in parallel on the same input.-(&&) :: forall m x b1 b2. MonadParallel m => Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)+(&&) :: (MonadParallel m, FactorialMonoid x) => Splitter m x -> Splitter m x -> Splitter m x (&&) = Combinators.pAnd parallelBinder -- | Combinator '||' is a pairwise logical disjunction of two splitters run in parallel on the same input.-(||) :: forall m x b1 b2. MonadParallel m => Splitter m x b1 -> Splitter m x b2 -> Splitter m x (Either b1 b2)+(||) :: (MonadParallel m, FactorialMonoid x) => Splitter m x -> Splitter m x -> Splitter m x (||) = Combinators.pOr parallelBinder -ifs :: (MonadParallel m, Branching c m x ()) => Splitter m x b -> c -> c -> c+ifs :: (MonadParallel m, Monoid x, Branching c m x ()) => Splitter m x -> c -> c -> c ifs = Combinators.ifs parallelBinder -wherever :: MonadParallel m => Transducer m x x -> Splitter m x b -> Transducer m x x+wherever :: (MonadParallel m, Monoid x) => Transducer m x x -> Splitter m x -> Transducer m x x wherever = Combinators.wherever parallelBinder -unless :: MonadParallel m => Transducer m x x -> Splitter m x b -> Transducer m x x+unless :: (MonadParallel m, Monoid x) => Transducer m x x -> Splitter m x -> Transducer m x x unless = Combinators.unless parallelBinder --- | Converts a boundary-marking splitter into a parser.-parseEachNestedRegion :: MonadParallel m => Splitter m x (Boundary b) -> Transducer m x y -> Transducer m x (Markup b y)-parseEachNestedRegion = Combinators.parseEachNestedRegion parallelBinder- -- | 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 :: MonadParallel m => Transducer m x x -> Splitter m x b -> Transducer m x x+while :: (MonadParallel m, MonoidNull x) => Transducer m x x -> Splitter m x -> Transducer m x x while t s = Combinators.while parallelBinder t s (while t s) -- | The recursive combinator 'nestedIn' combines two splitters into a mutually recursive loop acting as a single@@ -136,7 +136,7 @@ -- 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 :: MonadParallel m => Splitter m x b -> Splitter m x b -> Splitter m x b+nestedIn :: (MonadParallel m, MonoidNull x) => Splitter m x -> Splitter m x -> Splitter m x nestedIn s1 s2 = Combinators.nestedIn parallelBinder s1 s2 (nestedIn s1 s2) -- | The 'foreach' combinator is similar to the combinator 'ifs' in that it combines a splitter and two transducers into@@ -144,7 +144,7 @@ -- input as the splitter chunks it up. Each contiguous portion of the input that the splitter sends to one of its two -- sinks gets transducered through the appropriate argument transducer as that transducer's whole input. As soon as the -- contiguous portion is finished, the transducer gets terminated.-foreach :: (MonadParallel m, Branching c m x ()) => Splitter m x b -> c -> c -> c+foreach :: (MonadParallel m, MonoidNull x, Branching c m x ()) => Splitter m x -> c -> c -> c foreach = Combinators.foreach parallelBinder -- | The 'having' combinator combines two pure splitters into a pure splitter. One splitter is used to chunk the input@@ -152,24 +152,25 @@ -- 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 :: (MonadParallel m, Coercible x y) => Splitter m x b1 -> Splitter m y b2 -> Splitter m x b1+having :: (MonadParallel m, MonoidNull x, MonoidNull y, Coercible x y) => Splitter m x -> Splitter m y -> Splitter m x having = Combinators.having parallelBinder -- | 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 :: (MonadParallel m, Coercible x y) => Splitter m x b1 -> Splitter m y b2 -> Splitter m x b1+havingOnly :: (MonadParallel m, MonoidNull x, MonoidNull y, Coercible x y) => + Splitter m x -> Splitter m y -> Splitter m x havingOnly = Combinators.havingOnly parallelBinder -- | 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 :: MonadParallel m => Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)+followedBy :: (MonadParallel m, FactorialMonoid x) => Splitter m x -> Splitter m x -> Splitter m x followedBy = Combinators.followedBy parallelBinder -- | 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.-(...) :: MonadParallel m => Splitter m x b1 -> Splitter m x b2 -> Splitter m x b1+(...) :: (MonadParallel m, FactorialMonoid x) => Splitter m x -> Splitter m x -> Splitter m x (...) = Combinators.between parallelBinder
Control/Concurrent/SCC/Combinators/Sequential.hs view
@@ -22,7 +22,7 @@ module Control.Concurrent.SCC.Combinators.Sequential ( -- * Consumer, producer, and transducer combinators Combinators.consumeBy, Combinators.prepend, Combinators.append, Combinators.substitute,- Combinators.PipeableComponentPair, (>->), Combinators.JoinableComponentPair (Combinators.sequence), join,+ PipeableComponentPair, (>->), Combinators.JoinableComponentPair (Combinators.sequence), join, -- * Splitter combinators Combinators.sNot, -- ** Pseudo-logic flow combinators@@ -64,14 +64,18 @@ -- ** positional splitters Combinators.startOf, Combinators.endOf, (...), -- * Parser support- Combinators.splitterToMarker, Combinators.parseRegions, Combinators.parseNestedRegions, parseEachNestedRegion,+ Combinators.splitterToMarker, Combinators.parseRegions, ) where import Prelude hiding ((&&), (||), even, last, sequence)+import Data.Monoid (Monoid) import Data.Text (Text) import Control.Monad.Coroutine (sequentialBinder)+import Data.Monoid.Null (MonoidNull)+import Data.Monoid.Factorial (FactorialMonoid)+ import Control.Concurrent.SCC.Types import Control.Concurrent.SCC.Coercions (Coercible) import qualified Control.Concurrent.SCC.Combinators as Combinators@@ -85,8 +89,8 @@ -- * 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.-(>->) :: (Monad m, Combinators.PipeableComponentPair m w c1 c2 c3) => c1 -> c2 -> c3-(>->) = Combinators.compose sequentialBinder+(>->) :: (Monad m, PipeableComponentPair m w c1 c2 c3) => c1 -> c2 -> c3+(>->) = compose sequentialBinder -- | The 'join' combinator may apply the components in any order. join :: (Monad m, Combinators.JoinableComponentPair t1 t2 t3 m x y c1 c2 c3) => c1 -> c2 -> c3@@ -95,38 +99,34 @@ -- | 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.-(>&) :: Monad m => Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)+(>&) :: (Monad m, Monoid x) => Splitter m x -> Splitter m x -> Splitter m x (>&) = Combinators.sAnd sequentialBinder -- | A '>|' combinator's input value can reach its /false/ sink only by going through both argument splitters' /false/ -- sinks.-(>|) :: Monad m => Splitter m x b1 -> Splitter m x b2 -> Splitter m x (Either b1 b2) +(>|) :: (Monad m, Monoid x) => Splitter m x -> Splitter m x -> Splitter m x (>|) = Combinators.sOr sequentialBinder -- | Combinator '&&' is a pairwise logical conjunction of two splitters run in parallel on the same input.-(&&) :: Monad m => Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)+(&&) :: (Monad m, FactorialMonoid x) => Splitter m x -> Splitter m x -> Splitter m x (&&) = Combinators.pAnd sequentialBinder -- | Combinator '||' is a pairwise logical disjunction of two splitters run in parallel on the same input.-(||) :: Monad m => Splitter m x b1 -> Splitter m x b2 -> Splitter m x (Either b1 b2)+(||) :: (Monad m, FactorialMonoid x) => Splitter m x -> Splitter m x -> Splitter m x (||) = Combinators.pOr sequentialBinder -ifs :: (Monad m, Branching c m x ()) => Splitter m x b -> c -> c -> c+ifs :: (Monad m, Monoid x, Branching c m x ()) => Splitter m x -> c -> c -> c ifs = Combinators.ifs sequentialBinder -wherever :: Monad m => Transducer m x x -> Splitter m x b -> Transducer m x x+wherever :: (Monad m, Monoid x) => Transducer m x x -> Splitter m x -> Transducer m x x wherever = Combinators.wherever sequentialBinder -unless :: Monad m => Transducer m x x -> Splitter m x b -> Transducer m x x+unless :: (Monad m, Monoid x) => Transducer m x x -> Splitter m x -> Transducer m x x unless = Combinators.unless sequentialBinder --- | Converts a boundary-marking splitter into a parser.-parseEachNestedRegion :: Monad m => Splitter m x (Boundary b) -> Transducer m x y -> Transducer m x (Markup b y)-parseEachNestedRegion = Combinators.parseEachNestedRegion sequentialBinder- -- | 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 :: Monad m => Transducer m x x -> Splitter m x b -> Transducer m x x+while :: (Monad m, MonoidNull x) => Transducer m x x -> Splitter m x -> Transducer m x x while t s = Combinators.while sequentialBinder t s (while t s) -- | The recursive combinator 'nestedIn' combines two splitters into a mutually recursive loop acting as a single@@ -135,7 +135,7 @@ -- 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 :: Monad m => Splitter m x b -> Splitter m x b -> Splitter m x b+nestedIn :: (Monad m, MonoidNull x) => Splitter m x -> Splitter m x -> Splitter m x nestedIn s1 s2 = Combinators.nestedIn sequentialBinder s1 s2 (nestedIn s1 s2) -- | The 'foreach' combinator is similar to the combinator 'ifs' in that it combines a splitter and two transducers into@@ -143,7 +143,7 @@ -- input as the splitter chunks it up. Each contiguous portion of the input that the splitter sends to one of its two -- sinks gets transducered through the appropriate argument transducer as that transducer's whole input. As soon as the -- contiguous portion is finished, the transducer gets terminated.-foreach :: (Monad m, Branching c m x ()) => Splitter m x b -> c -> c -> c+foreach :: (Monad m, MonoidNull x, Branching c m x ()) => Splitter m x -> c -> c -> c foreach = Combinators.foreach sequentialBinder -- | The 'having' combinator combines two pure splitters into a pure splitter. One splitter is used to chunk the input@@ -151,24 +151,24 @@ -- 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 :: (Monad m, Coercible x y) => Splitter m x b1 -> Splitter m y b2 -> Splitter m x b1+having :: (Monad m, MonoidNull x, MonoidNull y, Coercible x y) => Splitter m x -> Splitter m y -> Splitter m x having = Combinators.having sequentialBinder -- | 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 :: (Monad m, Coercible x y) => Splitter m x b1 -> Splitter m y b2 -> Splitter m x b1+havingOnly :: (Monad m, MonoidNull x, MonoidNull y, Coercible x y) => Splitter m x -> Splitter m y -> Splitter m x havingOnly = Combinators.havingOnly sequentialBinder -- | 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 :: Monad m => Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)+followedBy :: (Monad m, FactorialMonoid x) => Splitter m x -> Splitter m x -> Splitter m x followedBy = Combinators.followedBy sequentialBinder -- | 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.-(...) :: Monad m => Splitter m x b1 -> Splitter m x b2 -> Splitter m x b1+(...) :: (Monad m, FactorialMonoid x) => Splitter m x -> Splitter m x -> Splitter m x (...) = Combinators.between sequentialBinder
Control/Concurrent/SCC/Configurable.hs view
@@ -1,5 +1,5 @@ {- - Copyright 2008-2010 Mario Blazevic+ Copyright 2008-2013 Mario Blazevic This file is part of the Streaming Component Combinators (SCC) project. @@ -18,14 +18,14 @@ MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, FunctionalDependencies, TypeFamilies #-} {-# OPTIONS_HADDOCK prune #-} --- | The "Components" module defines thin wrappers around the 'Transducer' and 'Splitter' primitives and combinators,--- relying on the "Control.Concurrent.SCC.ComponentTypes" module.+-- | This module exports the entire SCC library except for low-level modules "Control.Concurrent.SCC.Streams" and+-- "Control.Concurrent.SCC.Types". The exported combinators can be configured to run their components sequentially or in+-- parallel depending on the available resources. module Control.Concurrent.SCC.Configurable (- module Control.Concurrent.SCC.Streams,- module Control.Concurrent.SCC.Types, module Control.Concurrent.SCC.Configurable,+ module Control.Concurrent.Configuration, XML.XMLToken(..), XML.expandXMLEntity ) where@@ -33,10 +33,14 @@ import Prelude hiding (appendFile, even, id, last, sequence, (||), (&&)) import qualified Control.Category import Data.Text (Text)+import Data.Monoid (Monoid, Sum) import System.IO (Handle) import Control.Monad.Coroutine import Control.Monad.Parallel (MonadParallel(..))+import Data.Monoid.Null (MonoidNull)+import Data.Monoid.Factorial (FactorialMonoid)+import Data.Monoid.Cancellative (LeftCancellativeMonoid) import Control.Concurrent.SCC.Streams import Control.Concurrent.SCC.Types@@ -47,7 +51,7 @@ import qualified Control.Concurrent.SCC.XML as XML import Control.Concurrent.SCC.Primitives (OccurenceTag) import Control.Concurrent.SCC.XML (XMLToken)-import Control.Concurrent.Configuration (Component, atomic, lift, liftSequentialPair)+import Control.Concurrent.Configuration (Component, atomic) import qualified Control.Concurrent.Configuration as Configuration -- * Configurable component types@@ -70,7 +74,7 @@ -- 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 c x' arguments of a splitter are the same, the splitter must act as an identity -- transform.-type SplitterComponent m x b = Component (Splitter m x b)+type SplitterComponent m x = Component (Splitter m x) -- | The constant cost of each I/O-performing component. ioCost :: Int@@ -83,191 +87,192 @@ coerce = atomic "coerce" 1 Coercion.coerce -- | Adjusts the argument consumer to consume the stream of a data type coercible to the type it was meant to consume.-adaptConsumer :: (Monad m, Coercible x y) => ConsumerComponent m y r -> ConsumerComponent m x r-adaptConsumer = lift 1 "adaptConsumer" Coercion.adaptConsumer+adaptConsumer :: (Monad m, Monoid x, Monoid y, Coercible x y) => ConsumerComponent m y r -> ConsumerComponent m x r+adaptConsumer = Configuration.lift 1 "adaptConsumer" Coercion.adaptConsumer -- | Adjusts the argument producer to produce the stream of a data type coercible from the type it was meant to produce.-adaptProducer :: (Monad m, Coercible x y) => ProducerComponent m x r -> ProducerComponent m y r-adaptProducer = lift 1 "adaptProducer" Coercion.adaptProducer+adaptProducer :: (Monad m, Monoid x, Monoid y, Coercible x y) => ProducerComponent m x r -> ProducerComponent m y r+adaptProducer = Configuration.lift 1 "adaptProducer" Coercion.adaptProducer -- * Splitter isomorphism -- | Adjusts the argument splitter to split the stream of a data type isomorphic to the type it was meant to split.-adaptSplitter :: (Monad m, Coercible x y, Coercible y x) => SplitterComponent m x b -> SplitterComponent m y b-adaptSplitter = lift 1 "adaptSplitter" Coercion.adaptSplitter+adaptSplitter :: (Monad m, Monoid x, Monoid y, Coercible x y, Coercible y x) => + SplitterComponent m x -> SplitterComponent m y+adaptSplitter = Configuration.lift 1 "adaptSplitter" Coercion.adaptSplitter -- * I/O components -- ** I/O producers -- | ProducerComponent 'fromStdIn' feeds the given sink from the standard input.-fromStdIn :: ProducerComponent IO Char ()+fromStdIn :: ProducerComponent IO Text () fromStdIn = atomic "fromStdIn" ioCost Primitive.fromStdIn -- | ProducerComponent 'fromFile' opens the named file and feeds the given sink from its contents.-fromFile :: String -> ProducerComponent IO Char ()+fromFile :: String -> ProducerComponent IO Text () fromFile path = atomic "fromFile" ioCost (Primitive.fromFile path) -- | ProducerComponent 'fromHandle' feeds the given sink from the open file /handle/.-fromHandle :: Handle -> ProducerComponent IO Char ()+fromHandle :: Handle -> ProducerComponent IO Text () fromHandle handle = atomic "fromHandle" ioCost (Primitive.fromHandle handle) -- ** I/O consumers -- | ConsumerComponent 'toStdOut' copies the given source into the standard output.-toStdOut :: ConsumerComponent IO Char ()+toStdOut :: ConsumerComponent IO Text () toStdOut = atomic "toStdOut" ioCost Primitive.toStdOut -- | ConsumerComponent 'toFile' opens the named file and copies the given source into it.-toFile :: String -> ConsumerComponent IO Char ()+toFile :: String -> ConsumerComponent IO Text () toFile path = atomic "toFile" ioCost (Primitive.toFile path) -- | ConsumerComponent 'appendFile' opens the name file and appends the given source to it.-appendFile :: String -> ConsumerComponent IO Char ()+appendFile :: String -> ConsumerComponent IO Text () appendFile path = atomic "appendFile" ioCost (Primitive.appendFile path) -- | ConsumerComponent 'toHandle' copies the given source into the open file /handle/.-toHandle :: Handle -> ConsumerComponent IO Char ()+toHandle :: Handle -> ConsumerComponent IO Text () toHandle handle = atomic "toHandle" ioCost (Primitive.toHandle handle) -- * Generic components --- | 'fromList' produces the contents of the given list argument.-fromList :: Monad m => [x] -> ProducerComponent m x ()-fromList l = atomic "fromList" 1 (Primitive.fromList l)+-- | 'produceFrom' produces the contents of the given argument.+produceFrom :: (Monad m, MonoidNull x) => x -> ProducerComponent m x ()+produceFrom l = atomic "produceFrom" 1 (Primitive.produceFrom l) -- ** Generic consumers --- | ConsumerComponent 'toList' copies the given source into a list.-toList :: Monad m => ConsumerComponent m x [x]-toList = atomic "toList" 1 Primitive.toList+-- | ConsumerComponent 'consumeInto' collects the given source into the return value.+consumeInto :: (Monad m, Monoid x) => ConsumerComponent m x x+consumeInto = atomic "consumeInto" 1 Primitive.consumeInto -- | The 'suppress' consumer suppresses all input it receives. It is equivalent to 'substitute' [] suppress :: Monad m => ConsumerComponent m x () suppress = atomic "suppress" 1 Primitive.suppress -- | The 'erroneous' consumer reports an error if any input reaches it.-erroneous :: Monad m => String -> ConsumerComponent m x ()+erroneous :: (Monad m, MonoidNull x) => String -> ConsumerComponent m x () erroneous message = atomic "erroneous" 0 (Primitive.erroneous message) -- ** Generic transducers -- | TransducerComponent 'id' passes its input through unmodified.-id :: Monad m => TransducerComponent m x x-id = atomic "id" 1 Control.Category.id+id :: (Monad m, Monoid x) => TransducerComponent m x x+id = atomic "id" 1 $ Transducer pour_ -- | TransducerComponent 'unparse' removes all markup from its input and passes the content through.-unparse :: Monad m => TransducerComponent m (Markup b x) x+unparse :: (Monad m, Monoid x) => TransducerComponent m [Markup b x] x unparse = atomic "unparse" 1 Primitive.unparse -- | TransducerComponent 'parse' prepares input content for subsequent parsing.-parse :: Monad m => TransducerComponent m x (Markup y x)+parse :: (Monad m, Monoid x) => ParserComponent m x y parse = atomic "parse" 1 Primitive.parse -- | The 'lowercase' transforms all uppercase letters in the input to lowercase, leaving the rest unchanged.-lowercase :: Monad m => TransducerComponent m Char Char+lowercase :: Monad m => TransducerComponent m String String lowercase = atomic "lowercase" 1 Primitive.lowercase -- | The 'uppercase' transforms all lowercase letters in the input to uppercase, leaving the rest unchanged.-uppercase :: Monad m => TransducerComponent m Char Char+uppercase :: Monad m => TransducerComponent m String String uppercase = atomic "uppercase" 1 Primitive.uppercase -- | The 'count' transducer counts all its input values and outputs the final tally.-count :: Monad m => TransducerComponent m x Integer+count :: (Monad m, FactorialMonoid x) => TransducerComponent m x [Integer] count = atomic "count" 1 Primitive.count -- | Converts each input value @x@ to @show x@.-toString :: (Monad m, Show x) => TransducerComponent m x String+toString :: (Monad m, Show x) => TransducerComponent m [x] [String] toString = atomic "toString" 1 Primitive.toString -- | 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 :: (Monad m, Eq x) => [x] -> ParserComponent m x OccurenceTag+parseSubstring :: (Monad m, Eq x, LeftCancellativeMonoid x, FactorialMonoid x) => x -> ParserComponent m x OccurenceTag parseSubstring list = atomic "parseSubstring" 1 (Primitive.parseSubstring list) -- *** List stream transducers --- | TransducerComponent 'group' collects all its input values into a single list.-group :: Monad m => TransducerComponent m x [x]+-- | TransducerComponent 'group' collects all its input into a single list item.+group :: (Monad m, Monoid x) => TransducerComponent m x [x] group = atomic "group" 1 Primitive.group -- | TransducerComponent 'concatenate' flattens the input stream of lists of values into the output stream of values.-concatenate :: Monad m => TransducerComponent m [x] x+concatenate :: (Monad m, Monoid x) => TransducerComponent m [x] x concatenate = atomic "concatenate" 1 Primitive.concatenate -- | Same as 'concatenate' except it inserts the given separator list between every two input lists.-concatSeparate :: Monad m => [x] -> TransducerComponent m [x] x+concatSeparate :: (Monad m, MonoidNull x) => x -> TransducerComponent m [x] x concatSeparate separator = atomic "concatSeparate" 1 (Primitive.concatSeparate separator) -- ** Generic splitters -- | SplitterComponent 'everything' feeds its entire input into its /true/ sink.-everything :: Monad m => SplitterComponent m x ()+everything :: Monad m => SplitterComponent m x everything = atomic "everything" 1 Primitive.everything -- | SplitterComponent 'nothing' feeds its entire input into its /false/ sink.-nothing :: Monad m => SplitterComponent m x ()+nothing :: (Monad m, Monoid x) => SplitterComponent m x nothing = atomic "nothing" 1 Primitive.nothing -- | SplitterComponent 'marked' passes all marked-up input sections to its /true/ sink, and all unmarked input to its -- /false/ sink.-marked :: (Monad m, Eq y) => SplitterComponent m (Markup y x) ()+marked :: (Monad m, Eq y) => SplitterComponent m [Markup y x] marked = atomic "marked" 1 Primitive.marked -- | SplitterComponent '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 :: (Monad m, Eq y) => SplitterComponent m (Markup y x) ()+markedContent :: (Monad m, Eq y) => SplitterComponent m [Markup y x] markedContent = atomic "markedContent" 1 Primitive.markedContent -- | SplitterComponent '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 :: (Monad m, Eq y) => (y -> Bool) -> SplitterComponent m (Markup y x) ()+markedWith :: (Monad m, Eq y) => (y -> Bool) -> SplitterComponent m [Markup y x] markedWith selector = atomic "markedWith" 1 (Primitive.markedWith selector) -- | SplitterComponent '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 :: (Monad m, Eq y) => (y -> Bool) -> SplitterComponent m (Markup y x) ()+contentMarkedWith :: (Monad m, Eq y) => (y -> Bool) -> SplitterComponent m [Markup y x] contentMarkedWith selector = atomic "contentMarkedWith" 1 (Primitive.contentMarkedWith selector) -- | SplitterComponent 'one' feeds all input values to its /true/ sink, treating every value as a separate section.-one :: Monad m => SplitterComponent m x ()+one :: (Monad m, FactorialMonoid x) => SplitterComponent m x one = atomic "one" 1 Primitive.one -- | SplitterComponent '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 :: (Monad m, Eq x) => [x] -> SplitterComponent m x ()+-- by an empty chunk on /false/.+substring :: (Monad m, Eq x, LeftCancellativeMonoid x, FactorialMonoid x) => x -> SplitterComponent m x substring list = atomic "substring" 1 (Primitive.substring list) -- * Character stream components -- | SplitterComponent 'whitespace' feeds all white-space characters into its /true/ sink, all others into /false/.-whitespace :: Monad m => SplitterComponent m Char ()+whitespace :: Monad m => SplitterComponent m String whitespace = atomic "whitespace" 1 Primitive.whitespace -- | SplitterComponent 'letters' feeds all alphabetical characters into its /true/ sink, all other characters into -- | /false/.-letters :: Monad m => SplitterComponent m Char ()+letters :: Monad m => SplitterComponent m String letters = atomic "letters" 1 Primitive.letters -- | SplitterComponent 'digits' feeds all digits into its /true/ sink, all other characters into /false/.-digits :: Monad m => SplitterComponent m Char ()+digits :: Monad m => SplitterComponent m String digits = atomic "digits" 1 Primitive.digits -- | SplitterComponent 'nonEmptyLine' feeds line-ends into its /false/ sink, and all other characters into /true/.-nonEmptyLine :: Monad m => SplitterComponent m Char ()+nonEmptyLine :: Monad m => SplitterComponent m String nonEmptyLine = atomic "nonEmptyLine" 1 Primitive.nonEmptyLine -- | 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 :: Monad m => SplitterComponent m Char ()+line :: Monad m => SplitterComponent m String line = atomic "line" 1 Primitive.line -- * Consumer, producer, and transducer combinators -- | Converts a 'ConsumerComponent' into a 'TransducerComponent' with no output. consumeBy :: (Monad m) => ConsumerComponent m x r -> TransducerComponent m x y-consumeBy = lift 1 "consumeBy" Combinator.consumeBy+consumeBy = Configuration.lift 1 "consumeBy" Combinator.consumeBy -- | Class 'PipeableComponentPair' applies to any two components that can be combined into a third component with the -- following properties:@@ -278,9 +283,9 @@ -- -- * The result output, if any, is the output of the second component. -(>->) :: (MonadParallel m, Combinator.PipeableComponentPair m w c1 c2 c3) => +(>->) :: (MonadParallel m, PipeableComponentPair m w c1 c2 c3) => Component c1 -> Component c2 -> Component c3-(>->) = liftParallelPair ">->" Combinator.compose+(>->) = liftParallelPair ">->" compose class CompatibleSignature c cons (m :: * -> *) input output | c -> cons m @@ -315,79 +320,79 @@ -- | The 'sequence' combinator makes sure its first argument has completed before using the second one. sequence :: Combinator.JoinableComponentPair t1 t2 t3 m x y c1 c2 c3 => Component c1 -> Component c2 -> Component c3-sequence = liftSequentialPair "sequence" Combinator.sequence+sequence = Configuration.liftSequentialPair "sequence" Combinator.sequence -- | 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 :: (Monad m) => ProducerComponent m x r -> TransducerComponent m x x-prepend = lift 1 "prepend" Combinator.prepend+prepend = Configuration.lift 1 "prepend" Combinator.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 :: (Monad m) => ProducerComponent m x r -> TransducerComponent m x x-append = lift 1 "append" Combinator.append+append = Configuration.lift 1 "append" Combinator.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 :: (Monad m) => ProducerComponent m y r -> TransducerComponent m x y-substitute = lift 1 "substitute" Combinator.substitute+substitute :: (Monad m, Monoid x) => ProducerComponent m y r -> TransducerComponent m x y+substitute = Configuration.lift 1 "substitute" Combinator.substitute -- * Splitter combinators -- | 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 :: Monad m => SplitterComponent m x b -> SplitterComponent m x b-snot = lift 1 "not" Combinator.sNot+snot :: (Monad m, Monoid x) => SplitterComponent m x -> SplitterComponent m x+snot = Configuration.lift 1 "not" Combinator.sNot -- ** Pseudo-logic flow combinators -- | 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.-(>&) :: MonadParallel m => SplitterComponent m x b1 -> SplitterComponent m x b2 -> SplitterComponent m x (b1, b2)+(>&) :: (MonadParallel m, Monoid x) => SplitterComponent m x -> SplitterComponent m x -> SplitterComponent m x (>&) = liftParallelPair ">&" Combinator.sAnd -- | A '>|' combinator's input value can reach its /false/ sink only by going through both argument splitters' /false/ -- sinks.-(>|) :: MonadParallel m => SplitterComponent m x b1 -> SplitterComponent m x b2 -> SplitterComponent m x (Either b1 b2)+(>|) :: (MonadParallel m, Monoid x) => SplitterComponent m x -> SplitterComponent m x -> SplitterComponent m x (>|) = liftParallelPair ">&" Combinator.sOr -- ** Zipping logic combinators -- | Combinator '&&' is a pairwise logical conjunction of two splitters run in parallel on the same input.-(&&) :: MonadParallel m => SplitterComponent m x b1 -> SplitterComponent m x b2 -> SplitterComponent m x (b1, b2)+(&&) :: (MonadParallel m, FactorialMonoid x) => SplitterComponent m x -> SplitterComponent m x -> SplitterComponent m x (&&) = liftParallelPair "&&" Combinator.pAnd -- | Combinator '||' is a pairwise logical disjunction of two splitters run in parallel on the same input.-(||) :: MonadParallel m => SplitterComponent m x b1 -> SplitterComponent m x b2 -> SplitterComponent m x (Either b1 b2)+(||) :: (MonadParallel m, FactorialMonoid x) => SplitterComponent m x -> SplitterComponent m x -> SplitterComponent m x (||) = liftParallelPair "||" Combinator.pOr -- * Flow-control combinators -ifs :: (MonadParallel m, Branching c m x ()) =>- SplitterComponent m x b -> Component c -> Component c -> Component c+ifs :: (MonadParallel m, Branching c m x ()) => SplitterComponent m x -> Component c -> Component c -> Component c ifs = parallelRouterAndBranches "ifs" Combinator.ifs -wherever :: MonadParallel m =>- TransducerComponent m x x -> SplitterComponent m x b -> TransducerComponent m x x+wherever :: (MonadParallel m, Monoid x) =>+ TransducerComponent m x x -> SplitterComponent m x -> TransducerComponent m x x wherever = liftParallelPair "wherever" Combinator.wherever -unless :: MonadParallel m =>- TransducerComponent m x x -> SplitterComponent m x b -> TransducerComponent m x x+unless :: (MonadParallel m, Monoid x) =>+ TransducerComponent m x x -> SplitterComponent m x -> TransducerComponent m x x unless = liftParallelPair "unless" Combinator.unless -select :: Monad m => SplitterComponent m x b -> TransducerComponent m x x-select = lift 1 "select" Combinator.select+select :: (Monad m, Monoid x) => SplitterComponent m x -> TransducerComponent m x x+select = Configuration.lift 1 "select" Combinator.select -- ** Recursive -- | 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 :: MonadParallel m =>- TransducerComponent m x x -> SplitterComponent m x b -> TransducerComponent m x x-while t s = recursiveComponentTree "while" (uncurry . Combinator.while) $ liftSequentialPair "pair" (,) t s+while :: (MonadParallel m, MonoidNull x) =>+ TransducerComponent m x x -> SplitterComponent m x -> TransducerComponent m x x+while t s = recursiveComponentTree "while" (uncurry . Combinator.while) + $ Configuration.liftSequentialPair "pair" (,) t s -- | 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@@ -395,9 +400,9 @@ -- 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 :: MonadParallel m =>- SplitterComponent m x b -> SplitterComponent m x b -> SplitterComponent m x b-nestedIn s1 s2 = recursiveComponentTree "nestedIn" (uncurry . Combinator.nestedIn) $ liftSequentialPair "pair" (,) s1 s2+nestedIn :: (MonadParallel m, MonoidNull x) => SplitterComponent m x -> SplitterComponent m x -> SplitterComponent m x+nestedIn s1 s2 = recursiveComponentTree "nestedIn" (uncurry . Combinator.nestedIn) + $ Configuration.liftSequentialPair "pair" (,) s1 s2 -- * Section-based combinators @@ -406,8 +411,8 @@ -- 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 :: (MonadParallel m, Branching c m x ()) =>- SplitterComponent m x b -> Component c -> Component c -> Component c+foreach :: (MonadParallel m, MonoidNull x, Branching c m x ()) =>+ SplitterComponent m x -> Component c -> Component c -> Component c foreach = parallelRouterAndBranches "foreach" Combinator.foreach -- | The 'having' combinator combines two pure splitters into a pure splitter. One splitter is used to chunk the input@@ -415,48 +420,49 @@ -- 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 :: (MonadParallel m, Coercible x y) => - SplitterComponent m x b1 -> SplitterComponent m y b2 -> SplitterComponent m x b1+having :: (MonadParallel m, MonoidNull x, MonoidNull y, Coercible x y) =>+ SplitterComponent m x -> SplitterComponent m y -> SplitterComponent m x having = liftParallelPair "having" Combinator.having -- | The 'havingOnly' combinator is analogous to the 'having' combinator, but it succeeds and passes each chunk of the -- input to its /true/ sink only if the second splitter sends no part of it to its /false/ sink.-havingOnly :: (MonadParallel m, Coercible x y) => - SplitterComponent m x b1 -> SplitterComponent m y b2 -> SplitterComponent m x b1+havingOnly :: (MonadParallel m, MonoidNull x, MonoidNull y, Coercible x y) =>+ SplitterComponent m x -> SplitterComponent m y -> SplitterComponent m x havingOnly = liftParallelPair "havingOnly" Combinator.havingOnly -- | Combinator 'followedBy' treats its argument 'SplitterComponent's as patterns components and returns a -- 'SplitterComponent' that matches their concatenation. A section of input is considered /true/ by the result iff its -- prefix is considered /true/ by argument /s1/ and the rest of the section is considered /true/ by /s2/. The splitter -- /s2/ is started anew after every section split to /true/ sink by /s1/.-followedBy :: MonadParallel m => SplitterComponent m x b1 -> SplitterComponent m x b2 -> SplitterComponent m x (b1, b2)+followedBy :: (MonadParallel m, FactorialMonoid x) =>+ SplitterComponent m x -> SplitterComponent m x -> SplitterComponent m x followedBy = liftParallelPair "followedBy" Combinator.followedBy -- | 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 :: Monad m => SplitterComponent m x b -> SplitterComponent m x b-even = lift 2 "even" Combinator.even+even :: (Monad m, MonoidNull x) => SplitterComponent m x -> SplitterComponent m x+even = Configuration.lift 2 "even" Combinator.even -- ** first and its variants -- | 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 :: Monad m => SplitterComponent m x b -> SplitterComponent m x b-first = lift 2 "first" Combinator.first+first :: (Monad m, MonoidNull x) => SplitterComponent m x -> SplitterComponent m x+first = Configuration.lift 2 "first" Combinator.first -- | 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 :: Monad m => SplitterComponent m x b -> SplitterComponent m x b-uptoFirst = lift 2 "uptoFirst" Combinator.uptoFirst+uptoFirst :: (Monad m, MonoidNull x) => SplitterComponent m x -> SplitterComponent m x+uptoFirst = Configuration.lift 2 "uptoFirst" Combinator.uptoFirst -- | 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 :: Monad m => SplitterComponent m x b -> SplitterComponent m x b-prefix = lift 2 "prefix" Combinator.prefix+prefix :: (Monad m, MonoidNull x) => SplitterComponent m x -> SplitterComponent m x+prefix = Configuration.lift 2 "prefix" Combinator.prefix -- ** last and its variants @@ -465,93 +471,88 @@ -- 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 :: Monad m => SplitterComponent m x b -> SplitterComponent m x b-last = lift 2 "last" Combinator.last+last :: (Monad m, MonoidNull x) => SplitterComponent m x -> SplitterComponent m x+last = Configuration.lift 2 "last" Combinator.last -- | 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 :: Monad m => SplitterComponent m x b -> SplitterComponent m x b-lastAndAfter = lift 2 "lastAndAfter" Combinator.lastAndAfter+lastAndAfter :: (Monad m, MonoidNull x) => SplitterComponent m x -> SplitterComponent m x+lastAndAfter = Configuration.lift 2 "lastAndAfter" Combinator.lastAndAfter -- | 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 :: Monad m => SplitterComponent m x b -> SplitterComponent m x b-suffix = lift 2 "suffix" Combinator.suffix+suffix :: (Monad m, MonoidNull x) => SplitterComponent m x -> SplitterComponent m x+suffix = Configuration.lift 2 "suffix" Combinator.suffix -- ** positional splitters -- | SplitterComponent '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 :: Monad m => SplitterComponent m x b -> SplitterComponent m x (Maybe b)-startOf = lift 2 "startOf" Combinator.startOf+startOf :: (Monad m, MonoidNull x) => SplitterComponent m x -> SplitterComponent m x+startOf = Configuration.lift 2 "startOf" Combinator.startOf -- | SplitterComponent 'endOf' issues an empty /true/ section at the end of every section considered /true/ by its -- argument splitter, otherwise the entire input goes into its /false/ sink.-endOf :: MonadParallel m => SplitterComponent m x b -> SplitterComponent m x (Maybe b)-endOf = lift 2 "endOf" Combinator.endOf+endOf :: (Monad m, MonoidNull x) => SplitterComponent m x -> SplitterComponent m x+endOf = Configuration.lift 2 "endOf" Combinator.endOf -- | 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.-(...) :: MonadParallel m => SplitterComponent m x b1 -> SplitterComponent m x b2 -> SplitterComponent m x b1+(...) :: (MonadParallel m, FactorialMonoid x) => SplitterComponent m x -> SplitterComponent m x -> SplitterComponent m x (...) = liftParallelPair "..." Combinator.between -- * Parser support -- | Converts a splitter into a parser.-parseRegions :: Monad m => SplitterComponent m x b -> ParserComponent m x b-parseRegions = lift 1 "parseRegions" Combinator.parseRegions---- | Converts a boundary-marking splitter into a parser.-parseNestedRegions :: MonadParallel m =>- SplitterComponent m x (Boundary b) -> ParserComponent m x b-parseNestedRegions = lift 1 "parseNestedRegions" Combinator.parseNestedRegions+parseRegions :: (Monad m, MonoidNull x) => SplitterComponent m x -> ParserComponent m x ()+parseRegions = Configuration.lift 1 "parseRegions" Combinator.parseRegions -- * Parsing XML -- | This splitter splits XML markup from data content. It is used by 'parseXMLTokens'.-xmlTokens :: Monad m => SplitterComponent m Char (Boundary XMLToken)+xmlTokens :: Monad m => SplitterComponent m Text xmlTokens = atomic "XML.tokens" 1 XML.xmlTokens -- | The XML token parser. This parser converts plain text to parsed text, which is a precondition for using the -- remaining XML components.-xmlParseTokens :: MonadParallel m => TransducerComponent m Char (Markup XMLToken Text)+xmlParseTokens :: MonadParallel m => TransducerComponent m Text [Markup XMLToken Text] xmlParseTokens = atomic "XML.parseTokens" 1 XML.parseXMLTokens -- * XML splitters -- | Splits all top-level elements with all their content to /true/, all other input to /false/.-xmlElement :: Monad m => SplitterComponent m (Markup XMLToken Text) ()+xmlElement :: Monad m => SplitterComponent m [Markup XMLToken Text] xmlElement = atomic "XML.element" 1 XML.xmlElement -- | Splits the content of all top-level elements to /true/, their tags and intervening input to /false/.-xmlElementContent :: Monad m => SplitterComponent m (Markup XMLToken Text) ()+xmlElementContent :: Monad m => SplitterComponent m [Markup XMLToken Text] xmlElementContent = atomic "XML.elementContent" 1 XML.xmlElementContent -- | 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. xmlElementHavingTagWith :: MonadParallel m =>- SplitterComponent m (Markup XMLToken Text) b -> SplitterComponent m (Markup XMLToken Text) b-xmlElementHavingTagWith = lift 2 "XML.elementHavingTag" XML.xmlElementHavingTagWith+ SplitterComponent m [Markup XMLToken Text] -> SplitterComponent m [Markup XMLToken Text]+xmlElementHavingTagWith = Configuration.lift 2 "XML.elementHavingTag" XML.xmlElementHavingTagWith -- | Splits every attribute specification to /true/, everything else to /false/.-xmlAttribute :: Monad m => SplitterComponent m (Markup XMLToken Text) ()+xmlAttribute :: Monad m => SplitterComponent m [Markup XMLToken Text] xmlAttribute = atomic "XML.attribute" 1 XML.xmlAttribute -- | Splits every element name, including the names of nested elements and names in end tags, to /true/, all the rest of -- input to /false/.-xmlElementName :: Monad m => SplitterComponent m (Markup XMLToken Text) ()+xmlElementName :: Monad m => SplitterComponent m [Markup XMLToken Text] xmlElementName = atomic "XML.elementName" 1 XML.xmlElementName -- | Splits every attribute name to /true/, all the rest of input to /false/.-xmlAttributeName :: Monad m => SplitterComponent m (Markup XMLToken Text) ()+xmlAttributeName :: Monad m => SplitterComponent m [Markup XMLToken Text] xmlAttributeName = atomic "XML.attributeName" 1 XML.xmlAttributeName -- | Splits every attribute value, excluding the quote delimiters, to /true/, all the rest of input to /false/.-xmlAttributeValue :: Monad m => SplitterComponent m (Markup XMLToken Text) ()+xmlAttributeValue :: Monad m => SplitterComponent m [Markup XMLToken Text] xmlAttributeValue = atomic "XML.attributeValue" 1 XML.xmlAttributeValue liftParallelPair :: MonadParallel m =>
Control/Concurrent/SCC/Parallel.hs view
@@ -1,5 +1,5 @@ {- - Copyright 2008-2010 Mario Blazevic+ Copyright 2008-2013 Mario Blazevic This file is part of the Streaming Component Combinators (SCC) project. @@ -14,11 +14,10 @@ <http://www.gnu.org/licenses/>. -} --- | This module exports all of the SCC libraries. The exported combinators run their components in parallel.+-- | This module exports the entire SCC library except for low-level modules "Control.Concurrent.SCC.Streams" and+-- "Control.Concurrent.SCC.Types". The exported combinators run their components in parallel. module Control.Concurrent.SCC.Parallel (- module Control.Concurrent.SCC.Streams,- module Control.Concurrent.SCC.Types, module Control.Concurrent.SCC.Coercions, module Control.Concurrent.SCC.Primitives, module Control.Concurrent.SCC.Combinators.Parallel,@@ -26,8 +25,6 @@ ) where -import Control.Concurrent.SCC.Streams-import Control.Concurrent.SCC.Types import Control.Concurrent.SCC.Coercions import Control.Concurrent.SCC.Primitives import Control.Concurrent.SCC.Combinators.Parallel
Control/Concurrent/SCC/Primitives.hs view
@@ -1,5 +1,5 @@ {- - Copyright 2008-2011 Mario Blazevic+ Copyright 2008-2013 Mario Blazevic This file is part of the Streaming Component Combinators (SCC) project. @@ -27,9 +27,9 @@ -- ** I/O consumers appendFile, toFile, toHandle, toStdOut, toBinaryHandle, -- * Generic components- fromList, + produceFrom, -- ** Generic consumers- suppress, erroneous, toList,+ suppress, erroneous, consumeInto, -- ** Generic transducers parse, unparse, parseSubstring, OccurenceTag, count, toString, -- *** List stream transducers@@ -46,7 +46,7 @@ ) where -import Prelude hiding (appendFile, head, tail)+import Prelude hiding (appendFile, getLine, length, null, putStr, tail) import Control.Applicative (Alternative ((<|>))) import Control.Exception (assert)@@ -54,12 +54,17 @@ import Control.Monad.Trans.Class (lift) import Data.ByteString (ByteString) import Data.Char (isAlpha, isDigit, isSpace, toLower, toUpper)-import Data.List (delete, stripPrefix)+import Data.List (delete)+import Data.Monoid (Monoid(mappend, mempty), Sum(Sum)) import qualified Data.ByteString as ByteString import qualified Data.Foldable as Foldable-import System.IO (Handle, IOMode (ReadMode, WriteMode, AppendMode), - openFile, hClose, hGetLine, hPutStr, hIsEOF, hClose, isEOF)+import System.IO (Handle, IOMode (ReadMode, WriteMode, AppendMode), openFile, hClose, hIsEOF, hClose, isEOF)+import Data.Text (Text, singleton)+import Data.Text.IO (getLine, hGetLine, hPutStr, putStr) +import Data.Monoid.Null (MonoidNull(null))+import Data.Monoid.Cancellative (LeftReductiveMonoid (stripPrefix))+import Data.Monoid.Factorial (FactorialMonoid(splitPrimePrefix), length) import Text.ParserCombinators.Incremental (string, takeWhile, (<<|>)) import Control.Concurrent.SCC.Streams@@ -67,161 +72,167 @@ import Debug.Trace (trace) --- | Collects the entire input source into a list.-toList :: forall m x. Monad m => Consumer m x [x]-toList = Consumer getList+-- | Collects the entire input source into the return value.+consumeInto :: forall m x. (Monad m, Monoid x) => Consumer m x x+consumeInto = Consumer getAll --- | Produces the contents of the given list argument.-fromList :: forall m x. Monad m => [x] -> Producer m x ()-fromList l = Producer ((>> return ()) . putList l)+-- | Produces the contents of the given argument.+produceFrom :: forall m x. (Monad m, MonoidNull x) => x -> Producer m x ()+produceFrom l = Producer ((>> return ()) . putAll l) -- | Consumer 'toStdOut' copies the given source into the standard output.-toStdOut :: Consumer IO Char ()+toStdOut :: Consumer IO Text () toStdOut = Consumer (mapMStreamChunks_ (lift . putStr)) -- | Producer 'fromStdIn' feeds the given sink from the standard input.-fromStdIn :: Producer IO Char ()-fromStdIn = Producer (unmapMStreamChunks_ (lift $ isEOF >>= cond (return []) (fmap (++ "\n") getLine)))+fromStdIn :: Producer IO Text ()+fromStdIn = Producer (unmapMStreamChunks_ (lift $+ isEOF >>= cond (return mempty) (fmap (`mappend` singleton '\n') getLine))) -- | Reads the named file and feeds the given sink from its contents.-fromFile :: String -> Producer IO Char ()+fromFile :: String -> Producer IO Text () fromFile path = Producer $ \sink-> do handle <- lift (openFile path ReadMode) produce (fromHandle handle) sink lift (hClose handle) -- | Feeds the given sink from the open text file /handle/.-fromHandle :: Handle -> Producer IO Char ()+fromHandle :: Handle -> Producer IO Text () fromHandle handle = Producer (unmapMStreamChunks_- (lift $ hIsEOF handle >>= cond (return []) (fmap (++ "\n") $ hGetLine handle)))+ (lift $+ hIsEOF handle+ >>= cond (return mempty) (fmap (`mappend` singleton '\n') $ hGetLine handle))) -- | Feeds the given sink from the open binary file /handle/. The argument /chunkSize/ determines the size of the chunks -- read from the handle. fromBinaryHandle :: Handle -> Int -> Producer IO ByteString () fromBinaryHandle handle chunkSize = Producer p where p sink = lift (ByteString.hGet handle chunkSize) - >>= \chunk-> unless (ByteString.null chunk) (tryPut sink chunk >>= flip when (p sink))+ >>= \chunk-> unless (ByteString.null chunk) + (putChunk sink chunk + >>= \c-> when (ByteString.null c) (p sink)) -- | Creates the named text file and writes the entire given source to it.-toFile :: String -> Consumer IO Char ()+toFile :: String -> Consumer IO Text () toFile path = Consumer $ \source-> do handle <- lift (openFile path WriteMode) consume (toHandle handle) source lift (hClose handle) -- | Appends the given source to the named text file.-appendFile :: String -> Consumer IO Char ()+appendFile :: String -> Consumer IO Text () appendFile path = Consumer $ \source-> do handle <- lift (openFile path AppendMode) consume (toHandle handle) source lift (hClose handle) -- | Copies the given source into the open text file /handle/.-toHandle :: Handle -> Consumer IO Char ()+toHandle :: Handle -> Consumer IO Text () toHandle handle = Consumer (mapMStreamChunks_ (lift . hPutStr handle)) -- | Copies the given source into the open binary file /handle/. toBinaryHandle :: Handle -> Consumer IO ByteString ()-toBinaryHandle handle = Consumer (mapMStream_ (lift . ByteString.hPut handle))+toBinaryHandle handle = Consumer (mapMStreamChunks_ (lift . ByteString.hPut handle)) -- | Transducer 'unparse' removes all markup from its input and passes the content through.-unparse :: forall m x b. Monad m => Transducer m (Markup b x) x+unparse :: forall m x b. (Monad m, Monoid x) => Transducer m [Markup b x] x unparse = statelessTransducer removeTag- where removeTag (Content x) = [x]- removeTag _ = []+ where removeTag (Content x) = x+ removeTag _ = mempty -- | Transducer 'parse' prepares input content for subsequent parsing.-parse :: forall m x y. Monad m => Transducer m x (Markup y x)-parse = oneToOneTransducer Content+parse :: forall m x y. (Monad m, Monoid x) => Parser m x y+parse = statelessChunkTransducer ((: []) . Content) -- | The 'suppress' consumer suppresses all input it receives. It is equivalent to 'substitute' [] suppress :: forall m x. Monad m => Consumer m x ()-suppress = Consumer (\(src :: Source m a x)-> pour src (nullSink :: Sink m a x))+suppress = Consumer (\(src :: Source m a x)-> pour_ src (nullSink :: Sink m a x)) -- | The 'erroneous' consumer reports an error if any input reaches it.-erroneous :: forall m x. Monad m => String -> Consumer m x ()-erroneous message = Consumer (getWith (const (error message)))+erroneous :: forall m x. (Monad m, MonoidNull x) => String -> Consumer m x ()+erroneous message = Consumer (mapMStreamChunks_ (\x-> unless (null x) (error message))) -- | The 'lowercase' transforms all uppercase letters in the input to lowercase, leaving the rest unchanged.-lowercase :: forall m. Monad m => Transducer m Char Char-lowercase = oneToOneTransducer toLower+lowercase :: forall m. Monad m => Transducer m String String+lowercase = statelessChunkTransducer (map toLower) -- | The 'uppercase' transforms all lowercase letters in the input to uppercase, leaving the rest unchanged.-uppercase :: forall m. Monad m => Transducer m Char Char-uppercase = oneToOneTransducer toUpper+uppercase :: forall m. Monad m => Transducer m String String+uppercase = statelessChunkTransducer (map toUpper) -- | The 'count' transducer counts all its input values and outputs the final tally.-count :: forall m x. Monad m => Transducer m x Integer+count :: forall m x. (Monad m, FactorialMonoid x) => Transducer m x [Integer] count = Transducer (\source sink-> foldStream (\n _-> succ n) 0 source >>= put sink) -- | Converts each input value @x@ to @show x@.-toString :: forall m x. (Monad m, Show x) => Transducer m x String-toString = oneToOneTransducer show+toString :: forall m x. (Monad m, Show x) => Transducer m [x] [String]+toString = oneToOneTransducer (map show) --- | Transducer 'group' collects all its input values into a single list.-group :: forall m x. Monad m => Transducer m x [x]-group = Transducer (\source sink-> getList source >>= put sink)+-- | Transducer 'group' collects all its input into a single list item.+group :: forall m x. (Monad m, Monoid x) => Transducer m x [x]+group = Transducer (\source sink-> getAll source >>= put sink) -- | Transducer 'concatenate' flattens the input stream of lists of values into the output stream of values.-concatenate :: forall m x. Monad m => Transducer m [x] x+concatenate :: forall m x. (Monad m, Monoid x) => Transducer m [x] x concatenate = statelessTransducer id -- | Same as 'concatenate' except it inserts the given separator list between every two input lists.-concatSeparate :: forall m x. Monad m => [x] -> Transducer m [x] x-concatSeparate separator = statefulTransducer (\seen list-> (True, if seen then separator ++ list else list))+concatSeparate :: forall m x. (Monad m, MonoidNull x) => x -> Transducer m [x] x+concatSeparate separator = statefulTransducer (\seen chunk-> (True, if seen then mappend separator chunk else chunk)) False -- | Splitter 'whitespace' feeds all white-space characters into its /true/ sink, all others into /false/.-whitespace :: forall m. Monad m => Splitter m Char ()+whitespace :: forall m. Monad m => Splitter m String whitespace = statelessSplitter isSpace -- | Splitter 'letters' feeds all alphabetical characters into its /true/ sink, all other characters into -- | /false/.-letters :: forall m. Monad m => Splitter m Char ()+letters :: forall m. Monad m => Splitter m String letters = statelessSplitter isAlpha -- | Splitter 'digits' feeds all digits into its /true/ sink, all other characters into /false/.-digits :: forall m. Monad m => Splitter m Char ()+digits :: forall m. Monad m => Splitter m String digits = statelessSplitter isDigit -- | Splitter 'nonEmptyLine' feeds line-ends into its /false/ sink, and all other characters into /true/.-nonEmptyLine :: forall m. Monad m => Splitter m Char ()+nonEmptyLine :: forall m. Monad m => Splitter m String nonEmptyLine = statelessSplitter (\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. Monad m => Splitter m Char ()-line = Splitter $ \source true false boundaries->+line :: forall m. Monad m => Splitter m String+line = Splitter $ \source true false-> let loop = peek source >>= maybe (return ()) (( >> loop) . splitLine) lineChar c = c /= '\r' && c /= '\n' lineEndParser = string "\r\n" <<|> string "\n\r" <<|> string "\r" <<|> string "\n"- splitLine c = put boundaries ()- >> when (lineChar c) (pourWhile lineChar source true)- >> pourTicked lineEndParser source false+ splitLine c = if lineChar c then pourWhile (lineChar . head) source true else putChunk true mempty+ >> pourParsed lineEndParser source false in loop -- | Splitter 'everything' feeds its entire input into its /true/ sink.-everything :: forall m x. Monad m => Splitter m x ()-everything = Splitter (\source true _false edge-> put edge () >> pour source true)+everything :: forall m x. Monad m => Splitter m x+everything = Splitter (\source true _false-> pour source true >>= flip unless (putChunk true mempty >> return ())) -- | Splitter 'nothing' feeds its entire input into its /false/ sink.-nothing :: forall m x. Monad m => Splitter m x ()-nothing = Splitter (\source _true false _edge-> pour source false)+nothing :: forall m x. (Monad m, Monoid x) => Splitter m x+nothing = Splitter (\source _true false-> pour_ source false) -- | Splitter 'one' feeds all input values to its /true/ sink, treating every value as a separate section.-one :: forall m x. Monad m => Splitter m x ()-one = Splitter (\source true _false edge-> mapMStream_ (\x-> put edge () >> put true x) source)+one :: forall m x. (Monad m, FactorialMonoid x) => Splitter m x+one = Splitter (\source true false-> getWith source $+ \x-> putChunk true x+ >> mapMStream_ (\x-> putChunk false mempty >> putChunk true x) source) -- | 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. (Monad m, Eq y) => Splitter m (Markup y x) ()+marked :: forall m x y. (Monad m, Eq y) => Splitter m [Markup y x] marked = markedWith (const True) -- | Splitter 'markedContent' passes the content of all marked-up input sections to its /true/ sink, takeWhile the -- outermost tags and all unmarked input go to its /false/ sink.-markedContent :: forall m x y. (Monad m, Eq y) => Splitter m (Markup y x) ()+markedContent :: forall m x y. (Monad m, Eq y) => Splitter m [Markup y x] markedContent = contentMarkedWith (const True) -- | 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. (Monad m, Eq y) => (y -> Bool) -> Splitter m (Markup y x) ()+markedWith :: forall m x y. (Monad m, Eq y) => (y -> Bool) -> Splitter m [Markup y x] markedWith select = statefulSplitter transition ([], False) where transition s@([], _) Content{} = (s, False) transition s@(_, truth) Content{} = (s, truth)@@ -234,7 +245,7 @@ -- | 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. (Monad m, Eq y) => (y -> Bool) -> Splitter m (Markup y x) ()+contentMarkedWith :: forall m x y. (Monad m, Eq y) => (y -> Bool) -> Splitter m [Markup y x] contentMarkedWith select = statefulSplitter transition ([], False) where transition s@(_, truth) Content{} = (s, truth) transition s@(_, truth) (Markup Point{}) = (s, truth)@@ -255,71 +266,79 @@ -- | 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. (Monad m, Eq x) => [x] -> Parser m x OccurenceTag-parseSubstring [] = Transducer $ - \ source sink -> put sink marker >> concatMapStream (\x-> [Content x, marker]) source sink- where marker = Markup (Point (toEnum 1))-parseSubstring list@(first:rest)- = Transducer $- \ source sink ->- let findFirst = pourWhile (/= first) source (mapSink Content sink)- >> test- test = getTicked (string list) source- >>= \s-> case s- of [] -> get source >>= maybe (return ()) (\x-> put sink (Content x) >> findFirst)- _ -> put sink (Markup (Start (toEnum 0)))- >> putList prefixContent sink- >> if null shared then put sink (Markup (End (toEnum 0))) >> findFirst- else testOverlap 0- testOverlap n = getTicked (string postfix) source- >>= \s-> case s- of [] -> forM_ [n - maxOverlaps + 1 .. n]- (\i-> putList sharedContent sink- >> put sink (Markup (End (toEnum i))))- >> findFirst- _ -> let n' = succ n- in put sink (Markup (Start (toEnum n')))- >> putList prefixContent sink- >> when (n' >= maxOverlaps) - (put sink (Markup (End (toEnum (n' - maxOverlaps)))))- >> testOverlap n'- (prefix, shared, postfix) = overlap list list- maxOverlaps = (length list - 1) `div` length prefix- prefixContent = map Content prefix- sharedContent = map Content shared- in findFirst+parseSubstring :: forall m x. (Monad m, Eq x, LeftReductiveMonoid x, FactorialMonoid x) => x -> Parser m x OccurenceTag+parseSubstring s = + case splitPrimePrefix s+ of Nothing -> Transducer $ + \ source sink -> put sink marker >> mapStream (\x-> [Content x, marker]) source sink+ where marker = Markup (Point (toEnum 1))+ Just (first, rest)->+ isolateTransducer $ \ source sink ->+ pipe (\sink'->+ let findFirst = pourWhile (/= first) source sink'+ >> test+ test = getParsed (string s) source+ >>= \t-> if null t+ then getWith source (\x-> put sink (Content x) >> findFirst)+ else put sink (Markup (Start (toEnum 0)))+ >> put sink prefixContent+ >> if null shared then put sink (Markup (End (toEnum 0))) >> findFirst+ else testOverlap 0+ testOverlap n = getParsed (string postfix) source+ >>= \t-> if null t+ then forM_ [n - maxOverlaps + 1 .. n]+ (\i-> put sink sharedContent+ >> put sink (Markup (End (toEnum i))))+ >> findFirst+ else let n' = succ n+ in put sink (Markup (Start (toEnum n')))+ >> put sink prefixContent+ >> when (n' >= maxOverlaps)+ (put sink (Markup (End (toEnum (n' - maxOverlaps)))))+ >> testOverlap n'+ (prefix, shared, postfix) = overlap s s+ maxOverlaps = (length s - 1) `div` length prefix+ prefixContent = Content prefix+ sharedContent = Content shared+ in findFirst)+ (\src-> mapStreamChunks ((: []) . Content) src sink)+ >> return () -- | 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. (Monad m, Eq x) => [x] -> Splitter m x ()-substring [] = Splitter $ \ source true false edge -> split one source false true edge >> put edge ()-substring list@(first:rest)- = Splitter $- \ source true false edge ->- let findFirst = pourWhile (/= first) source false- >> test- test = getTicked (string list) source- >>= \s-> case s- of [] -> get source >>= maybe (return ()) (\x-> put false x >> findFirst)- _ -> put edge ()- >> putList prefix true- >> if null shared then findFirst else testOverlap- testOverlap = getTicked (string postfix) source- >>= \s-> case s- of [] -> putList shared true >> findFirst- _ -> put edge ()- >> putList prefix true - >> testOverlap- (prefix, shared, postfix) = overlap list list- in findFirst+-- by an empty chunk on /false/.+substring :: forall m x. (Monad m, Eq x, LeftReductiveMonoid x, FactorialMonoid x) => x -> Splitter m x+substring s = + Splitter $ \ source true false ->+ case splitPrimePrefix s+ of Nothing -> putChunk true mempty+ >> mapMStream_ (\x-> putChunk false x >> putChunk true mempty) source+ Just (first, rest) ->+ let findFirst = pourWhile (/= first) source false+ >> test+ test = getParsed (string s) source+ >>= \t-> if null t+ then getWith source (\x-> putChunk false x >> findFirst)+ else putChunk false mempty+ >> putAll prefix true+ >> if null shared then findFirst else testOverlap+ testOverlap = getParsed (string postfix) source+ >>= \t-> if null t+ then putAll shared true >> findFirst+ else putChunk false mempty+ >> putAll prefix true+ >> testOverlap+ (prefix, shared, postfix) = overlap s s+ in findFirst -overlap :: Eq x => [x] -> [x] -> ([x], [x], [x])-overlap [] s = ([], [], s)-overlap (head:tail) s2 = case stripPrefix tail s2- of Just rest -> ([head], tail, rest)- Nothing -> let (o1, o2, o3) = overlap tail s2- in (head:o1, o2, o3)+overlap :: (LeftReductiveMonoid x, FactorialMonoid x) => x -> x -> (x, x, x)+overlap e s | null e = (e, e, s)+overlap s1 s2 = case splitPrimePrefix s1+ of Nothing -> (s1, s1, s2)+ Just (head, tail) -> case stripPrefix tail s2+ of Just rest -> (head, tail, rest)+ Nothing -> let (o1, o2, o3) = overlap tail s2+ in (mappend head o1, o2, o3) -- | A utility function wrapping if-then-else, useful for handling monadic truth values cond :: a -> a -> Bool -> a
Control/Concurrent/SCC/Sequential.hs view
@@ -1,5 +1,5 @@ {- - Copyright 2008-2010 Mario Blazevic+ Copyright 2008-2013 Mario Blazevic This file is part of the Streaming Component Combinators (SCC) project. @@ -14,12 +14,10 @@ <http://www.gnu.org/licenses/>. -} --- | This module exports all of the SCC libraries. The exported combinators run their components by sequentially--- interleaving them.+-- | This module exports the entire SCC library except for low-level modules "Control.Concurrent.SCC.Streams" and+-- "Control.Concurrent.SCC.Types". The exported combinators run their components by sequentially interleaving them. module Control.Concurrent.SCC.Sequential (- module Control.Concurrent.SCC.Streams,- module Control.Concurrent.SCC.Types, module Control.Concurrent.SCC.Coercions, module Control.Concurrent.SCC.Primitives, module Control.Concurrent.SCC.Combinators.Sequential,@@ -27,8 +25,6 @@ ) where -import Control.Concurrent.SCC.Streams-import Control.Concurrent.SCC.Types import Control.Concurrent.SCC.Coercions import Control.Concurrent.SCC.Primitives import Control.Concurrent.SCC.Combinators.Sequential
Control/Concurrent/SCC/Streams.hs view
@@ -1,5 +1,5 @@-{- - Copyright 2010-2011 Mario Blazevic+{-+ Copyright 2010-2013 Mario Blazevic This file is part of the Streaming Component Combinators (SCC) project. @@ -15,57 +15,59 @@ -} -- | This module defines 'Source' and 'Sink' types and 'pipe' functions that create them. The method 'get' on 'Source'--- abstracts away 'Control.Concurrent.Coroutine.SuspensionFunctors.await', and the method 'put' on 'Sink' is a--- higher-level abstraction of 'Control.Concurrent.Coroutine.SuspensionFunctors.yield'. With this arrangement, a single--- coroutine can yield values to multiple sinks and await values from multiple sources with no need to change the--- 'Control.Concurrent.Coroutine.Coroutine' functor; the only requirement is for each funtor of the sources and sinks--- the coroutine uses to be an 'Control.Concurrent.Coroutine.AncestorFunctor' of the coroutine's functor. For example,--- coroutine /zip/ that takes two sources and one sink would be declared like this:+-- abstracts away 'Control.Monad.Coroutine.SuspensionFunctors.await', and the method 'put' on 'Sink' is a higher-level+-- abstraction of 'Control.Monad.Coroutine.SuspensionFunctors.yield'. With this arrangement, a single coroutine can+-- yield values to multiple sinks and await values from multiple sources with no need to change the+-- 'Control.Monad.Coroutine.Coroutine' functor. The only requirement is that each functor of the sources and sinks the+-- coroutine uses must be an 'Control.Monad.Coroutine.Nested.AncestorFunctor' of the coroutine's own functor. For+-- example, a coroutine that takes two sources and one sink might be declared like this: -- -- @ -- zip :: forall m a1 a2 a3 d x y. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d)--- => Source m a1 x -> Source m a2 y -> Sink m a3 (x, y) -> Coroutine d m ()+-- => Source m a1 [x] -> Source m a2 [y] -> Sink m a3 [(x, y)] -> Coroutine d m () -- @ -- -- Sources, sinks, and coroutines communicating through them are all created using the 'pipe' function or one of its -- variants. They effectively split the current coroutine into a producer-consumer coroutine pair. The producer gets a--- new 'Sink' to write to and the consumer a new 'Source' to read from, in addition to all the streams that are visible--- in the original coroutine. The following function, for example, uses the /zip/ coroutine above to add together the--- values from two Integer sources:+-- new 'Sink' to write to and the consumer a new 'Source' to read from, in addition to all the streams they inherit from+-- the current coroutine. The following function, for example, uses the /zip/ coroutine declard above to add together+-- the pairs of values from two Integer sources: -- -- @ -- add :: forall m a1 a2 a3 d. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d)--- => Source m a1 Integer -> Source m a2 Integer -> Sink m a3 Integer -> Coroutine d m ()+-- => Source m a1 [Integer] -> Source m a2 [Integer] -> Sink m a3 [Integer] -> Coroutine d m () -- add source1 source2 sink = do pipe--- (\pairSink-> zip source1 source2 pairSink) -- producer coroutine--- (\pairSource-> mapStream (uncurry (+)) pairSource sink) -- consumer coroutine+-- (\pairSink-> zip source1 source2 pairSink) -- producer+-- (\pairSource-> mapStream (List.map $ uncurry (+)) pairSource sink) -- consumer -- return () -- @ {-# LANGUAGE ScopedTypeVariables, Rank2Types, TypeFamilies, KindSignatures #-}-{-# OPTIONS_HADDOCK hide #-} module Control.Concurrent.SCC.Streams ( -- * Sink and Source types Sink, Source, SinkFunctor, SourceFunctor, AncestorFunctor, -- * Sink and Source constructors- pipe, pipeP, pipeG, nullSink, nullSource,+ pipe, pipeP, pipeG, nullSink, -- * Operations on sinks and sources -- ** Singleton operations- get, getWith, peek, put, tryPut,+ get, getWith, getPrime, peek, put, tryPut, -- ** Lifting functions liftSink, liftSource, -- ** Bulk operations -- *** Fetching and moving data- pour, tee, teeSink,- getList, putList, putQueue,- getTicked, getWhile, getUntil, - pourTicked, pourParsed, pourWhile, pourUntil,+ pour, pour_, tee, teeSink,+ getAll, putAll, putChunk,+ getParsed, getRead,+ getWhile, getUntil, + pourRead, pourParsed, pourWhile, pourUntil,+ Reader, Reading(..), ReadingResult(..), -- *** Stream transformations+ markDown, markUpWith, mapSink, mapStream, mapMaybeStream, concatMapStream,- mapStreamChunks, foldStream, mapAccumStream, concatMapAccumStream, partitionStream,+ mapStreamChunks, mapAccumStreamChunks, foldStream, mapAccumStream, concatMapAccumStream, partitionStream, -- *** Monadic stream transformations mapMStream, mapMStream_, mapMStreamChunks_, filterMStream, foldMStream, foldMStream_, unfoldMStream, unmapMStream_, unmapMStreamChunks_,@@ -73,191 +75,280 @@ ) where -import Prelude hiding (takeWhile)- +import Prelude hiding (foldl, foldr, map, mapM, mapM_, null, span, takeWhile)+ import qualified Control.Monad import Control.Monad (liftM, when, unless, foldM)-import Data.Foldable (toList)-import Data.Monoid (Monoid, mempty, First(First, getFirst))-import Data.Monoid.Null (MonoidNull)+import Data.Functor.Identity (Identity(..))+import Data.Monoid (Monoid(mappend, mconcat, mempty), First(First, getFirst))+import Data.Monoid.Factorial (FactorialMonoid, foldl, map, mapM, mapM_, span, primePrefix, splitPrimePrefix)+import Data.Monoid.Null (MonoidNull(null)) import Data.Maybe (mapMaybe) import Data.List (mapAccumL)-import Data.Sequence (Seq, viewl)-import Text.ParserCombinators.Incremental+import qualified Data.List as List (map, span)+import Text.ParserCombinators.Incremental (Parser, feed, feedEof, inspect, completeResults) import Control.Monad.Parallel (MonadParallel(..)) import Control.Monad.Coroutine-import Control.Monad.Coroutine.SuspensionFunctors (EitherFunctor(..), Request, request, ParseRequest, requestParse,- nestedLazyParserRequestResolver)-import Control.Monad.Coroutine.Nested (AncestorFunctor(..), liftAncestor, seesawNested)+import Control.Monad.Coroutine.SuspensionFunctors (Request, request,+ ReadRequest, requestRead,+ Reader, Reading(..), ReadingResult(..),+ weaveNestedReadWriteRequests)+import Control.Monad.Coroutine.Nested (EitherFunctor(..), AncestorFunctor(..), liftAncestor) -type SourceFunctor a x = EitherFunctor a (ParseRequest x)-type SinkFunctor a x = EitherFunctor a (Request [x] [x])+type SourceFunctor a x = EitherFunctor a (ReadRequest x)+type SinkFunctor a x = EitherFunctor a (Request x x) --- | A 'Sink' can be used to yield values from any nested `Coroutine` computation whose functor provably descends from+-- | A 'Sink' can be used to yield output from any nested `Coroutine` computation whose functor provably descends from -- the functor /a/. It's the write-only end of a communication channel created by 'pipe'. newtype Sink (m :: * -> *) a x = Sink {- -- | This method puts a list of values into the `Sink`. The intervening 'Coroutine' computations suspend up to the- -- 'pipe' invocation that has created the argument sink. The method returns all values that could not make it into- -- the sink because of the sibling coroutine's death.- putChunk :: forall d. AncestorFunctor a d => [x] -> Coroutine d m [x]+ -- | This method puts a portion of the producer's output into the `Sink`. The intervening 'Coroutine' computations+ -- suspend up to the 'pipe' invocation that has created the argument sink. The method returns the suffix of the+ -- argument that could not make it into the sink because of the sibling coroutine's death.+ putChunk :: forall d. AncestorFunctor a d => x -> Coroutine d m x } --- | A 'Source' can be used to read values into any nested `Coroutine` computation whose functor provably descends from+-- | A 'Source' can be used to read input into any nested `Coroutine` computation whose functor provably descends from -- the functor /a/. It's the read-only end of a communication channel created by 'pipe'. newtype Source (m :: * -> *) a x = Source {- -- | This method gets a list of values from the 'Source', as well as an indication of the next value if any. The- -- first argument is a function that determines how many values should be consumed from the source. The function will- -- keep being called until it returns @False@ or the current chunk gets completely consumed. If the current chunk is- -- empty on call, a new one is obtained from the source. The intervening 'Coroutine' computations suspend all the way- -- to the 'pipe' function invocation that created the source.- foldChunk :: forall d p y. (AncestorFunctor a d, MonoidNull y) => - Parser p [x] y -> Coroutine d m (y, Maybe (Parser p [x] y))+ -- | This method consumes a portion of input from the 'Source' using the 'Reader' argument and returns the+ -- 'ReadingResult'. Depending on the reader, the producer coroutine may not need to be resumed at all, or it may need+ -- to be resumed many times. The intervening 'Coroutine' computations suspend all the way to the 'pipe' function+ -- invocation that created the source.+ readChunk :: forall d py y. AncestorFunctor a d => Reader x py y -> Coroutine d m (ReadingResult x py y) } --- | A disconnected sink that ignores all values 'put' into it.-nullSink :: forall m a x. Monad m => Sink m a x-nullSink = Sink{putChunk= const (return [])}+readAll :: Reader x x x+readAll s = Advance readAll s s --- | An empty source whose 'get' always returns Nothing.-nullSource :: forall m a x. Monad m => Source m a x-nullSource = Source{foldChunk= \p-> return (mempty, Just p)}+-- | A disconnected sink that consumes and ignores all data 'put' into it.+nullSink :: forall m a x. (Monad m, Monoid x) => Sink m a x+nullSink = Sink{putChunk= const (return mempty)} +-- | A disconnected sink that consumes and ignores all data 'put' into it.+emptySource :: forall m a x. (Monad m, Monoid x) => Source m a x+emptySource = Source{readChunk= return . finalize . ($ mempty)}+ where finalize (Final _ x) = FinalResult x+ finalize (Advance _ x _) = FinalResult x+ finalize (Deferred _ x) = FinalResult x+ -- | Converts a 'Sink' on the ancestor functor /a/ into a sink on the descendant functor /d/. liftSink :: forall m a d x. (Monad m, AncestorFunctor a d) => Sink m a x -> Sink m d x-liftSink s = Sink {putChunk= liftAncestor . (putChunk s :: [x] -> Coroutine d m [x])}+liftSink s = Sink {putChunk= liftAncestor . (putChunk s :: x -> Coroutine d m x)}+{-# INLINE liftSink #-} -- | Converts a 'Source' on the ancestor functor /a/ into a source on the descendant functor /d/. liftSource :: forall m a d x. (Monad m, AncestorFunctor a d) => Source m a x -> Source m d x-liftSource s = Source {foldChunk= liftAncestor . (foldChunk s - :: forall p y. MonoidNull y => - Parser p [x] y -> Coroutine d m (y, Maybe (Parser p [x] y)))}+liftSource s = Source {readChunk= liftAncestor . (readChunk s :: Reader x py y -> Coroutine d m (ReadingResult x py y))}+{-# INLINE liftSource #-} +-- | A sink mark-up transformation: every chunk going into the sink is accompanied by the given value.+markUpWith :: forall m a x mark. (Monad m, Monoid x) => mark -> Sink m a [(x, mark)] -> Sink m a x+markUpWith mark sink = Sink putMarkedChunk+ where putMarkedChunk :: forall d. AncestorFunctor a d => x -> Coroutine d m x+ putMarkedChunk x = do rest <- putChunk sink [(x, mark)]+ case rest of [] -> return mempty+ [(y, _)]-> return y++-- | A sink mark-down transformation: the marks get removed off each chunk.+markDown :: forall m a x mark. (Monad m, MonoidNull x) => Sink m a x -> Sink m a [(x, mark)]+markDown sink = Sink putUnmarkedChunk+ where putUnmarkedChunk :: forall d. AncestorFunctor a d => [(x, mark)] -> Coroutine d m [(x, mark)]+ putUnmarkedChunk [] = return mempty+ putUnmarkedChunk ((x, mark):tail) = do rest <- putChunk sink x+ if null rest + then putUnmarkedChunk tail+ else return ((rest, mark):tail)+ -- | The 'pipe' function splits the computation into two concurrent parts, /producer/ and /consumer/. The /producer/ is -- given a 'Sink' to put values into, and /consumer/ a 'Source' to get those values from. Once producer and consumer -- both complete, 'pipe' returns their paired results.-pipe :: forall m a a1 a2 x r1 r2. (Monad m, Functor a, a1 ~ SinkFunctor a x, a2 ~ SourceFunctor a x) =>+pipe :: forall m a a1 a2 x r1 r2. (Monad m, Monoid x, Functor a, a1 ~ SinkFunctor a x, a2 ~ SourceFunctor a x) => (Sink m a1 x -> Coroutine a1 m r1) -> (Source m a2 x -> Coroutine a2 m r2) -> Coroutine a m (r1, r2) pipe = pipeG sequentialBinder -- | The 'pipeP' function is equivalent to 'pipe', except it runs the /producer/ and the /consumer/ in parallel. pipeP :: forall m a a1 a2 x r1 r2. - (MonadParallel m, Functor a, a1 ~ SinkFunctor a x, a2 ~ SourceFunctor a x) =>+ (MonadParallel m, Monoid x, Functor a, a1 ~ SinkFunctor a x, a2 ~ SourceFunctor a x) => (Sink m a1 x -> Coroutine a1 m r1) -> (Source m a2 x -> Coroutine a2 m r2) -> Coroutine a m (r1, r2) pipeP = pipeG bindM2 -- | A generic version of 'pipe'. The first argument is used to combine two computation steps.-pipeG :: forall m a a1 a2 x r1 r2. (Monad m, Functor a, a1 ~ SinkFunctor a x, a2 ~ SourceFunctor a x) =>+pipeG :: forall m a a1 a2 x r1 r2. (Monad m, Monoid x, Functor a, a1 ~ SinkFunctor a x, a2 ~ SourceFunctor a x) => PairBinder m -> (Sink m a1 x -> Coroutine a1 m r1) -> (Source m a2 x -> Coroutine a2 m r2) -> Coroutine a m (r1, r2) pipeG run2 producer consumer =- liftM (uncurry (flip (,))) $ - seesawNested run2 (nestedLazyParserRequestResolver) (consumer source) (producer sink)- where sink = Sink {putChunk= \xs-> if null xs then return []- else (liftAncestor (mapSuspension RightF (request xs) :: Coroutine a1 m [x]))}- source = Source {foldChunk= fc}- fc :: forall d p y. (AncestorFunctor a2 d, MonoidNull y) => - Parser p [x] y -> Coroutine d m (y, Maybe (Parser p [x] y))- fc t = liftAncestor (mapSuspension RightF (requestParse t) :: Coroutine a2 m (y, Maybe (Parser p [x] y)))+ liftM (uncurry (flip (,))) $+ weave run2 weaveNestedReadWriteRequests (consumer source) (producer sink)+ where sink = Sink {putChunk= \xs-> liftAncestor (mapSuspension RightF (request xs) :: Coroutine a1 m x)}+ source = Source {readChunk= fc}+ fc :: forall d py y. AncestorFunctor a2 d => Reader x py y -> Coroutine d m (ReadingResult x py y)+ fc t = liftAncestor (mapSuspension RightF (requestRead t) :: Coroutine a2 m (ReadingResult x py y)) --- | Function 'get' tries to get a value from the given 'Source' argument. The intervening 'Coroutine' computations--- suspend all the way to the 'pipe' function invocation that created the source. The function returns 'Nothing' if--- the argument source is empty.-get :: forall m a d x. (Monad m, AncestorFunctor a d) => Source m a x -> Coroutine d m (Maybe x)-get source = foldChunk source anyToken- >>= \(r, _) -> return $ case r of [] -> Nothing- ~[x] -> Just x+fromParser :: forall p x y. Monoid x => y -> Parser p x y -> Reader x (y -> y) y+fromParser failure p s = case inspect (feed s p)+ of ([], Nothing) -> Final s failure+ ([], Just (Nothing, p')) -> Deferred (fromParser failure p') r'+ where (r', s') = case completeResults (feedEof p')+ of [] -> (failure, s)+ hd:_ -> hd+ ([], Just (Just prefix, p')) -> Advance (fromParser failure p') (prefix r') prefix+ where (r', s'):_ = completeResults (feedEof p')+ ([(r, s')], Nothing) -> Final s' r +-- | Function 'get' tries to get a single value from the given 'Source' argument. The intervening 'Coroutine'+-- computations suspend all the way to the 'pipe' function invocation that created the source. The function returns+-- 'Nothing' if the argument source is empty.+get :: forall m a d x. (Monad m, AncestorFunctor a d) => Source m a [x] -> Coroutine d m (Maybe x)+get source = readChunk source readOne+ >>= \(FinalResult x) -> return x+ where readOne [] = Deferred readOne Nothing+ readOne (x:rest) = Final rest (Just x)++-- | Tries to get a minimal, /i.e./, prime, prefix from the given 'Source' argument. The intervening 'Coroutine'+-- computations suspend all the way to the 'pipe' function invocation that created the source. The function returns+-- 'mempty' if the argument source is empty.+getPrime :: forall m a d x. (Monad m, FactorialMonoid x, AncestorFunctor a d) => Source m a x -> Coroutine d m x+getPrime source = readChunk source primeReader+ >>= \(FinalResult x) -> return x+ where primeReader x = maybe (Deferred primeReader x) + (\(prefix, rest)-> Final rest prefix) + (splitPrimePrefix x)++-- | Invokes its first argument with the value it gets from the source, if there is any to get.+getWith :: forall m a d x. (Monad m, FactorialMonoid x, AncestorFunctor a d) =>+ Source m a x -> (x -> Coroutine d m ()) -> Coroutine d m ()+getWith source consumer = readChunk source primeReader+ >>= \(FinalResult x) -> x+ where primeReader x = maybe (Deferred primeReader (return ()))+ (\(prefix, rest)-> Final rest (consumer prefix) )+ (splitPrimePrefix x)+ -- | Function 'peek' acts the same way as 'get', but doesn't actually consume the value from the source; sequential -- calls to 'peek' will always return the same value.-peek :: forall m a d x. (Monad m, AncestorFunctor a d) => Source m a x -> Coroutine d m (Maybe x)-peek source = foldChunk source (lookAhead anyToken)- >>= \(r, _) -> return $ case r of [] -> Nothing- ~[x] -> Just x+peek :: forall m a d x. (Monad m, AncestorFunctor a d) => Source m a [x] -> Coroutine d m (Maybe x)+peek source = readChunk source readOneAhead+ >>= \(FinalResult x) -> return x+ where readOneAhead [] = Deferred readOneAhead Nothing+ readOneAhead s@(x:_) = Final s (Just x) --- | 'getList' returns the list of all values generated by the source.-getList :: forall m a d x. (Monad m, AncestorFunctor a d) => Source m a x -> Coroutine d m [x]-getList = getTicked acceptAll+-- | 'getAll' consumes and returns all data generated by the source.+getAll :: forall m a d x. (Monad m, Monoid x, AncestorFunctor a d) => Source m a x -> Coroutine d m x+getAll source = readChunk source (readAll id)+ >>= \(FinalResult all)-> return all+ where readAll :: (x -> x) -> Reader x () x+ readAll prefix s = Deferred (readAll (prefix . mappend s)) (prefix s) --- | Invokes its first argument with the value it gets from the source, if there is any to get.-getWith :: forall m a d x. (Monad m, AncestorFunctor a d) => (x -> Coroutine d m ()) -> Source m a x -> Coroutine d m ()-getWith consumer source = get source >>= maybe (return ()) consumer+-- | Consumes inputs from the /source/ as long as the /parser/ accepts it.+getParsed :: forall m a d p x y. (Monad m, Monoid x, Monoid y, AncestorFunctor a d) => + Parser p x y -> Source m a x -> Coroutine d m y+getParsed parser = getRead (fromParser mempty parser) --- | Consumes values from the /source/ as long as the /parser/ accepts them.-getTicked :: forall m p a d x. (Monad m, AncestorFunctor a d) => Parser p [x] [x] -> Source m a x -> Coroutine d m [x]-getTicked parser source = loop return parser- where loop cont p = foldChunk source p >>= proceed cont- proceed cont (chunk, Nothing) = cont chunk- proceed cont (chunk, Just p') = loop (cont . (chunk ++)) p'+-- | Consumes input from the /source/ as long as the /reader/ accepts it.+getRead :: forall m a d x y. (Monad m, Monoid x, AncestorFunctor a d) => + Reader x (y -> y) y -> Source m a x -> Coroutine d m y+getRead reader source = loop return reader+ where loop cont r = readChunk source r >>= proceed cont+ proceed cont (FinalResult chunk) = cont chunk+ proceed cont (ResultPart d p') = loop (cont . d) p' -- | Consumes values from the /source/ as long as each satisfies the predicate, then returns their list.-getWhile :: forall m a d x. (Monad m, AncestorFunctor a d) => (x -> Bool) -> Source m a x -> Coroutine d m [x]-getWhile predicate = getTicked (takeWhile (predicate . head))+getWhile :: forall m a d x. (Monad m, FactorialMonoid x, AncestorFunctor a d) =>+ (x -> Bool) -> Source m a x -> Coroutine d m x+getWhile predicate source = readChunk source (readWhile predicate id)+ >>= \(FinalResult x)-> return x+ where readWhile :: (x -> Bool) -> (x -> x) -> Reader x () x+ readWhile predicate prefix1 s = if null suffix+ then Deferred (readWhile predicate (prefix1 . mappend s)) (prefix1 s)+ else Final suffix (prefix1 prefix2)+ where (prefix2, suffix) = span predicate s -- | Consumes values from the /source/ until one of them satisfies the predicate or the source is emptied, then returns -- the pair of the list of preceding values and maybe the one value that satisfied the predicate. The latter is not -- consumed.-getUntil :: forall m a d x. (Monad m, AncestorFunctor a d) => - (x -> Bool) -> Source m a x -> Coroutine d m ([x], Maybe x)-getUntil f source = loop id- where loop cont = foldChunk source (takeWhile (not . f . head)- `andThen` lookAhead (fmap (First . Just . head) anyToken - <<|> return (First Nothing)))- >>= extract cont- extract cont ((chunk, First mx), Nothing) = return (cont chunk, mx)- extract cont ((chunk, First Nothing), Just{}) = loop (cont . (chunk ++))+getUntil :: forall m a d x. (Monad m, FactorialMonoid x, AncestorFunctor a d) =>+ (x -> Bool) -> Source m a x -> Coroutine d m (x, Maybe x)+getUntil predicate source = readChunk source (readUntil (not . predicate) id)+ >>= \(FinalResult r)-> return r+ where readUntil :: (x -> Bool) -> (x -> x) -> Reader x () (x, Maybe x)+ readUntil predicate prefix1 s = if null suffix+ then Deferred (readUntil predicate (prefix1 . mappend s)) (prefix1 s, Nothing)+ else Final suffix (prefix1 prefix2, Just $ primePrefix suffix)+ where (prefix2, suffix) = span predicate s --- | Copies all data from the /source/ argument into the /sink/ argument.-pour :: forall m a1 a2 d x . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)+-- | Copies all data from the /source/ argument into the /sink/ argument. The result indicates if there was any chunk to+-- copy.+pour :: forall m a1 a2 d x . (Monad m, Monoid x, AncestorFunctor a1 d, AncestorFunctor a2 d)+ => Source m a1 x -> Sink m a2 x -> Coroutine d m Bool+pour source sink = loop False+ where loop another = readChunk source readAll >>= extract another+ extract another (FinalResult _chunk) = return another -- the last chunk must be empty+ extract _ (ResultPart chunk _) = putChunk sink chunk >> loop True++-- | Copies all data from the /source/ argument into the /sink/ argument, like 'pour' but ignoring the result.+pour_ :: forall m a1 a2 d x . (Monad m, Monoid x, AncestorFunctor a1 d, AncestorFunctor a2 d) => Source m a1 x -> Sink m a2 x -> Coroutine d m ()-pour source sink = loop- where loop = getChunk source >>= nullOrElse (return ()) ((>> loop) . putChunk sink)+pour_ source sink = pour source sink >> return () -- | Like 'pour', copies data from the /source/ to the /sink/, but only as long as it satisfies the predicate.-pourTicked :: forall m p a1 a2 d x . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)- => Parser p [x] [x] -> Source m a1 x -> Sink m a2 x -> Coroutine d m ()-pourTicked parser source sink = loop parser- where loop p = foldChunk source p- >>= \(chunk, p')-> unless (null chunk) (putChunk sink chunk >> maybe (return ()) loop p')+pourRead :: forall m a1 a2 d x y. (Monad m, MonoidNull x, MonoidNull y, AncestorFunctor a1 d, AncestorFunctor a2 d)+ => Reader x y y -> Source m a1 x -> Sink m a2 y -> Coroutine d m ()+pourRead reader source sink = loop reader+ where loop p = readChunk source p >>= extract+ extract (FinalResult r) = unless (null r) (putChunk sink r >> return ())+ extract (ResultPart chunk p') = putChunk sink chunk >> loop p' -- | Parses the input data using the given parser and copies the results to output.-pourParsed :: forall m p a1 a2 d x y. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)- => Parser p [x] [y] -> Source m a1 x -> Sink m a2 y -> Coroutine d m ()-pourParsed parser source sink = loop parser- where loop p = foldChunk source p- >>= \(chunk, p')-> unless (null chunk) (putChunk sink chunk >> maybe (return ()) loop p')+pourParsed :: forall m p a1 a2 d x y. (Monad m, MonoidNull x, MonoidNull y, AncestorFunctor a1 d, AncestorFunctor a2 d)+ => Parser p x y -> Source m a1 x -> Sink m a2 y -> Coroutine d m ()+pourParsed parser source sink = loop (fromParser mempty parser)+ where loop p = readChunk source p >>= extract+ extract (FinalResult r) = unless (null r) (putChunk sink r >> return ())+ extract (ResultPart d p') = putChunk sink (d mempty) >> loop p' -- | Like 'pour', copies data from the /source/ to the /sink/, but only as long as it satisfies the predicate.-pourWhile :: forall m a1 a2 d x . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)+pourWhile :: forall m a1 a2 d x . (Monad m, FactorialMonoid x, AncestorFunctor a1 d, AncestorFunctor a2 d) => (x -> Bool) -> Source m a1 x -> Sink m a2 x -> Coroutine d m ()-pourWhile f = pourTicked (takeWhile (f . head))+pourWhile = pourRead . readWhile+ where readWhile :: FactorialMonoid x => (x -> Bool) -> Reader x x x+ readWhile p = while+ where while s = if null suffix+ then Advance while prefix prefix+ else Final suffix prefix+ where (prefix, suffix) = span p s -- | Like 'pour', copies data from the /source/ to the /sink/, but only until one value satisfies the predicate. That -- value is returned rather than copied.-pourUntil :: forall m a1 a2 d x . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)+pourUntil :: forall m a1 a2 d x . (Monad m, FactorialMonoid x, AncestorFunctor a1 d, AncestorFunctor a2 d) => (x -> Bool) -> Source m a1 x -> Sink m a2 x -> Coroutine d m (Maybe x)-pourUntil f source sink = loop- where loop = foldChunk source (takeWhile (not . f . head)- `andThen` lookAhead (fmap (First . Just . head) anyToken - <<|> return (First Nothing)))- >>= extract- extract ((chunk, First mx), Nothing) = putList chunk sink >> return mx- extract ((chunk, First Nothing), Just{}) = putChunk sink chunk >> loop+pourUntil predicate source sink = loop $ readUntil (not . predicate)+ where readUntil :: FactorialMonoid x => (x -> Bool) -> Reader x x (x, Maybe x)+ readUntil p = until+ where until s = if null suffix+ then Advance until (prefix, Nothing) prefix+ else Final suffix (prefix, Just $ primePrefix suffix)+ where (prefix, suffix) = span p s+ loop rd = readChunk source rd >>= extract+ extract (FinalResult (chunk, mx)) = putChunk sink chunk >> return mx+ extract (ResultPart chunk rd') = putChunk sink chunk >> loop rd' -- | 'mapStream' is like 'pour' that applies the function /f/ to each argument before passing it into the /sink/.-mapStream :: forall m a1 a2 d x y . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)+mapStream :: forall m a1 a2 d x y . (Monad m, FactorialMonoid x, Monoid y, AncestorFunctor a1 d, AncestorFunctor a2 d) => (x -> y) -> Source m a1 x -> Sink m a2 y -> Coroutine d m () mapStream f source sink = loop- where loop = getChunk source >>= nullOrElse (return ()) ((>> loop) . putChunk sink . map f)+ where loop = readChunk source readAll+ >>= \r-> case r+ of ResultPart chunk _ -> putChunk sink (map f chunk) >> loop+ FinalResult _ -> return () -- the last chunk must be empty -- | An equivalent of 'Data.List.map' that works on a 'Sink' instead of a list. The argument function is applied to -- every value vefore it's written to the sink argument.-mapSink :: forall m a x y. Monad m => (x -> y) -> Sink m a y -> Sink m a x-mapSink f sink = Sink{putChunk= \xs-> putChunk sink (map f xs) +mapSink :: forall m a x y. Monad m => (x -> y) -> Sink m a [y] -> Sink m a [x]+mapSink f sink = Sink{putChunk= \xs-> putChunk sink (List.map f xs) >>= \rest-> return (dropExcept (length rest) xs)} where dropExcept :: forall z. Int -> [z] -> [z] dropExcept 0 _ = []@@ -269,26 +360,25 @@ -- | 'mapMaybeStream' is to 'mapStream' like 'Data.Maybe.mapMaybe' is to 'Data.List.map'. mapMaybeStream :: forall m a1 a2 d x y . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)- => (x -> Maybe y) -> Source m a1 x -> Sink m a2 y -> Coroutine d m ()+ => (x -> Maybe y) -> Source m a1 [x] -> Sink m a2 [y] -> Coroutine d m () mapMaybeStream f source sink = mapMStreamChunks_ ((>> return ()) . putChunk sink . mapMaybe f) source -- | 'concatMapStream' is to 'mapStream' like 'Data.List.concatMap' is to 'Data.List.map'.-concatMapStream :: forall m a1 a2 d x y . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)- => (x -> [y]) -> Source m a1 x -> Sink m a2 y -> Coroutine d m ()-concatMapStream f source sink = loop- where loop = getChunk source >>= nullOrElse (return ()) ((>> loop) . putChunk sink . concatMap f)+concatMapStream :: forall m a1 a2 d x y . (Monad m, Monoid y, AncestorFunctor a1 d, AncestorFunctor a2 d)+ => (x -> y) -> Source m a1 [x] -> Sink m a2 y -> Coroutine d m ()+concatMapStream f = mapStream (mconcat . List.map f) -- | 'mapAccumStream' is similar to 'mapAccumL' except it reads the values from a 'Source' instead of a list -- and writes the mapped values into a 'Sink' instead of returning another list. mapAccumStream :: forall m a1 a2 d x y acc . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)- => (acc -> x -> (acc, y)) -> acc -> Source m a1 x -> Sink m a2 y -> Coroutine d m acc+ => (acc -> x -> (acc, y)) -> acc -> Source m a1 [x] -> Sink m a2 [y] -> Coroutine d m acc mapAccumStream f acc source sink = foldMStreamChunks (\a xs-> dispatch $ mapAccumL f a xs) acc source where dispatch (a, ys) = putChunk sink ys >> return a -- | 'concatMapAccumStream' is a love child of 'concatMapStream' and 'mapAccumStream': it threads the accumulator like -- the latter, but its argument function returns not a single value, but a list of values to write into the sink. concatMapAccumStream :: forall m a1 a2 d x y acc . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)- => (acc -> x -> (acc, [y])) -> acc -> Source m a1 x -> Sink m a2 y -> Coroutine d m acc+ => (acc -> x -> (acc, [y])) -> acc -> Source m a1 [x] -> Sink m a2 [y] -> Coroutine d m acc concatMapAccumStream f acc source sink = foldMStreamChunks (\a xs-> dispatch $ concatMapAccumL a xs) acc source where dispatch (a, ys) = putChunk sink ys >> return a concatMapAccumL s [] = (s, [])@@ -297,92 +387,120 @@ (s'', ys) = concatMapAccumL s' xs -- | Like 'mapStream' except it runs the argument function on whole chunks read from the input.-mapStreamChunks :: forall m a1 a2 d x y . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)- => ([x] -> [y]) -> Source m a1 x -> Sink m a2 y -> Coroutine d m ()+mapStreamChunks :: forall m a1 a2 d x y . (Monad m, Monoid x, AncestorFunctor a1 d, AncestorFunctor a2 d)+ => (x -> y) -> Source m a1 x -> Sink m a2 y -> Coroutine d m () mapStreamChunks f source sink = loop- where loop = getChunk source >>= nullOrElse (return ()) ((>> loop) . flip putList sink . f)+ where loop = readChunk source readAll+ >>= \r-> case r+ of ResultPart chunk _ -> putChunk sink (f chunk) >> loop+ FinalResult _ -> return () -- the last chunk must be empty +-- | Like 'mapAccumStream' except it runs the argument function on whole chunks read from the input.+mapAccumStreamChunks :: forall m a1 a2 d x y acc. (Monad m, Monoid x, AncestorFunctor a1 d, AncestorFunctor a2 d)+ => (acc -> x -> (acc, y)) -> acc -> Source m a1 x -> Sink m a2 y -> Coroutine d m acc+mapAccumStreamChunks f acc source sink = loop acc+ where loop acc = readChunk source readAll+ >>= \r-> case r+ of ResultPart chunk _ -> let (acc', chunk') = f acc chunk + in putChunk sink chunk' >> loop acc'+ FinalResult _ -> return acc -- the last chunk must be empty+ -- | 'mapMStream' is similar to 'Control.Monad.mapM'. It draws the values from a 'Source' instead of a list, writes the -- mapped values to a 'Sink', and returns a 'Coroutine'.-mapMStream :: forall m a1 a2 d x y . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)+mapMStream :: forall m a1 a2 d x y . (Monad m, FactorialMonoid x, Monoid y, AncestorFunctor a1 d, AncestorFunctor a2 d) => (x -> Coroutine d m y) -> Source m a1 x -> Sink m a2 y -> Coroutine d m () mapMStream f source sink = loop- where loop = getChunk source >>= nullOrElse (return ()) ((>> loop) . (putChunk sink =<<) . mapM f)+ where loop = readChunk source readAll+ >>= \r-> case r+ of ResultPart chunk _ -> mapM f chunk >>= putChunk sink >> loop+ FinalResult _ -> return () -- the last chunk must be empty -- | 'mapMStream_' is similar to 'Control.Monad.mapM_' except it draws the values from a 'Source' instead of a list and -- works with 'Coroutine' instead of an arbitrary monad.-mapMStream_ :: forall m a d x . (Monad m, AncestorFunctor a d)- => (x -> Coroutine d m ()) -> Source m a x -> Coroutine d m ()-mapMStream_ f = mapMStreamChunks_ (Control.Monad.mapM_ f)+mapMStream_ :: forall m a d x r. (Monad m, FactorialMonoid x, AncestorFunctor a d)+ => (x -> Coroutine d m r) -> Source m a x -> Coroutine d m ()+mapMStream_ f = mapMStreamChunks_ (mapM_ f) -- | Like 'mapMStream_' except it runs the argument function on whole chunks read from the input.-mapMStreamChunks_ :: forall m a d x . (Monad m, AncestorFunctor a d)- => ([x] -> Coroutine d m ()) -> Source m a x -> Coroutine d m ()+mapMStreamChunks_ :: forall m a d x r. (Monad m, Monoid x, AncestorFunctor a d)+ => (x -> Coroutine d m r) -> Source m a x -> Coroutine d m () mapMStreamChunks_ f source = loop- where loop = getChunk source >>= nullOrElse (return ()) ((>> loop) . f)+ where loop = readChunk source readAll+ >>= \r-> case r+ of ResultPart chunk _ -> f chunk >> loop+ FinalResult _ -> return () -- the last chunk must be empty -- | An equivalent of 'Control.Monad.filterM'. Draws the values from a 'Source' instead of a list, writes the filtered -- values to a 'Sink', and returns a 'Coroutine'.-filterMStream :: forall m a1 a2 d x . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)+filterMStream :: forall m a1 a2 d x . (Monad m, FactorialMonoid x, AncestorFunctor a1 d, AncestorFunctor a2 d) => (x -> Coroutine d m Bool) -> Source m a1 x -> Sink m a2 x -> Coroutine d m ()-filterMStream f source sink = mapMStream_ (\x-> f x >>= flip when (put sink x)) source+filterMStream f = mapMStream (\x-> f x >>= \p-> return $ if p then x else mempty) -- | Similar to 'Data.List.foldl', but reads the values from a 'Source' instead of a list.-foldStream :: forall m a d x acc . (Monad m, AncestorFunctor a d)+foldStream :: forall m a d x acc . (Monad m, FactorialMonoid x, AncestorFunctor a d) => (acc -> x -> acc) -> acc -> Source m a x -> Coroutine d m acc foldStream f acc source = loop acc- where loop s = getChunk source >>= nullOrElse (return s) (loop . foldl f s)+ where loop a = readChunk source readAll+ >>= \r-> case r+ of ResultPart chunk _ -> loop (foldl f a chunk)+ FinalResult{} -> return a -- the last chunk must be empty -- | 'foldMStream' is similar to 'Control.Monad.foldM' except it draws the values from a 'Source' instead of a list and -- works with 'Coroutine' instead of an arbitrary monad. foldMStream :: forall m a d x acc . (Monad m, AncestorFunctor a d)- => (acc -> x -> Coroutine d m acc) -> acc -> Source m a x -> Coroutine d m acc+ => (acc -> x -> Coroutine d m acc) -> acc -> Source m a [x] -> Coroutine d m acc foldMStream f acc source = loop acc- where loop a = getChunk source >>= nullOrElse (return a) ((loop =<<) . foldM f a)+ where loop a = readChunk source readAll+ >>= \r-> case r+ of ResultPart chunk _ -> foldM f a chunk >>= loop+ FinalResult [] -> return a -- the last chunk must be empty -- | A variant of 'foldMStream' that discards the final result value. foldMStream_ :: forall m a d x acc . (Monad m, AncestorFunctor a d)- => (acc -> x -> Coroutine d m acc) -> acc -> Source m a x -> Coroutine d m ()+ => (acc -> x -> Coroutine d m acc) -> acc -> Source m a [x] -> Coroutine d m () foldMStream_ f acc source = foldMStream f acc source >> return () -- | Like 'foldMStream' but working on whole chunks from the argument source.-foldMStreamChunks :: forall m a d x acc . (Monad m, AncestorFunctor a d)- => (acc -> [x] -> Coroutine d m acc) -> acc -> Source m a x -> Coroutine d m acc+foldMStreamChunks :: forall m a d x acc . (Monad m, Monoid x, AncestorFunctor a d)+ => (acc -> x -> Coroutine d m acc) -> acc -> Source m a x -> Coroutine d m acc foldMStreamChunks f acc source = loop acc- where loop a = getChunk source >>= nullOrElse (return a) ((loop =<<) . f a)+ where loop a = readChunk source readAll+ >>= \r-> case r+ of ResultPart chunk _ -> f a chunk >>= loop+ FinalResult _ -> return a -- the last chunk must be empty -- | 'unfoldMStream' is a version of 'Data.List.unfoldr' that writes the generated values into a 'Sink' instead of -- returning a list. unfoldMStream :: forall m a d x acc . (Monad m, AncestorFunctor a d)- => (acc -> Coroutine d m (Maybe (x, acc))) -> acc -> Sink m a x -> Coroutine d m acc+ => (acc -> Coroutine d m (Maybe (x, acc))) -> acc -> Sink m a [x] -> Coroutine d m acc unfoldMStream f acc sink = loop acc where loop a = f a >>= maybe (return a) (\(x, acc')-> put sink x >> loop acc') -- | 'unmapMStream_' is opposite of 'mapMStream_'; it takes a 'Sink' instead of a 'Source' argument and writes the -- generated values into it. unmapMStream_ :: forall m a d x . (Monad m, AncestorFunctor a d)- => Coroutine d m (Maybe x) -> Sink m a x -> Coroutine d m ()+ => Coroutine d m (Maybe x) -> Sink m a [x] -> Coroutine d m () unmapMStream_ f sink = loop where loop = f >>= maybe (return ()) (\x-> put sink x >> loop) -- | Like 'unmapMStream_' but writing whole chunks of generated data into the argument sink.-unmapMStreamChunks_ :: forall m a d x . (Monad m, AncestorFunctor a d)- => Coroutine d m [x] -> Sink m a x -> Coroutine d m ()+unmapMStreamChunks_ :: forall m a d x . (Monad m, MonoidNull x, AncestorFunctor a d)+ => Coroutine d m x -> Sink m a x -> Coroutine d m () unmapMStreamChunks_ f sink = loop >> return ()- where loop = f >>= nullOrElse (return []) ((>>= nullOrElse loop return) . putChunk sink)+ where loop = f >>= nullOrElse (return mempty) ((>>= nullOrElse loop return) . putChunk sink) -- | Equivalent to 'Data.List.partition'. Takes a 'Source' instead of a list argument and partitions its contents into -- the two 'Sink' arguments. partitionStream :: forall m a1 a2 a3 d x . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d)- => (x -> Bool) -> Source m a1 x -> Sink m a2 x -> Sink m a3 x -> Coroutine d m ()+ => (x -> Bool) -> Source m a1 [x] -> Sink m a2 [x] -> Sink m a3 [x] -> Coroutine d m () partitionStream f source true false = mapMStreamChunks_ partitionChunk source where partitionChunk (x:rest) = partitionTo (f x) x rest- partitionChunk [] = error "Chunks cannot be empty!"+ partitionChunk [] = return () partitionTo False x chunk = let (falses, rest) = break f chunk in putChunk false (x:falses) >> case rest of y:ys -> partitionTo True y ys [] -> return ()- partitionTo True x chunk = let (trues, rest) = span f chunk+ partitionTo True x chunk = let (trues, rest) = List.span f chunk in putChunk true (x:trues) >> case rest of y:ys -> partitionTo False y ys [] -> return ()@@ -390,7 +508,8 @@ -- | 'zipWithMStream' is similar to 'Control.Monad.zipWithM' except it draws the values from two 'Source' arguments -- instead of two lists, sends the results into a 'Sink', and works with 'Coroutine' instead of an arbitrary monad. zipWithMStream :: forall m a1 a2 a3 d x y z. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d)- => (x -> y -> Coroutine d m z) -> Source m a1 x -> Source m a2 y -> Sink m a3 z -> Coroutine d m ()+ => (x -> y -> Coroutine d m z) -> Source m a1 [x] -> Source m a2 [y] -> Sink m a3 [z]+ -> Coroutine d m () zipWithMStream f source1 source2 sink = loop where loop = do mx <- get source1 my <- get source2@@ -400,7 +519,8 @@ -- | 'parZipWithMStream' is equivalent to 'zipWithMStream', but it consumes the two sources in parallel. parZipWithMStream :: forall m a1 a2 a3 d x y z. (MonadParallel m, AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d)- => (x -> y -> Coroutine d m z) -> Source m a1 x -> Source m a2 y -> Sink m a3 z -> Coroutine d m ()+ => (x -> y -> Coroutine d m z) -> Source m a1 [x] -> Source m a2 [y] -> Sink m a3 [z]+ -> Coroutine d m () parZipWithMStream f source1 source2 sink = loop where loop = bindM2 zipMaybe (get source1) (get source2) zipMaybe (Just x) (Just y) = f x y >>= put sink >> loop@@ -408,11 +528,13 @@ -- | 'tee' is similar to 'pour' except it distributes every input value from its source argument into its both sink -- arguments.-tee :: forall m a1 a2 a3 d x . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d)+tee :: forall m a1 a2 a3 d x . (Monad m, Monoid x, AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d) => Source m a1 x -> Sink m a2 x -> Sink m a3 x -> Coroutine d m () tee source sink1 sink2 = distribute- where distribute = getChunk source- >>= nullOrElse (return ()) (\x-> putChunk sink1 x >> putChunk sink2 x >> distribute)+ where distribute = readChunk source readAll+ >>= \r-> case r+ of ResultPart chunk _ -> putChunk sink1 chunk >> putChunk sink2 chunk >> distribute+ FinalResult _ -> return () -- the last chunk must be empty -- | Every value 'put' into a 'teeSink' result sink goes into its both argument sinks: @put (teeSink s1 s2) x@ is -- equivalent to @put s1 x >> put s2 x@. The 'putChunk' method returns the list of values that couldn't fit into the@@ -420,7 +542,7 @@ teeSink :: forall m a1 a2 a3 x . (Monad m, AncestorFunctor a1 a3, AncestorFunctor a2 a3) => Sink m a1 x -> Sink m a2 x -> Sink m a3 x teeSink s1 s2 = Sink{putChunk= teeChunk}- where teeChunk :: forall d. AncestorFunctor a3 d => [x] -> Coroutine d m [x]+ where teeChunk :: forall d. AncestorFunctor a3 d => x -> Coroutine d m x teeChunk x = putChunk s1' x >> putChunk s2' x s1' :: Sink m a3 x s1' = liftSink s1@@ -429,25 +551,18 @@ -- | This function puts a value into the given `Sink`. The intervening 'Coroutine' computations suspend up -- to the 'pipe' invocation that has created the argument sink.-put :: forall m a d x. (Monad m, AncestorFunctor a d) => Sink m a x -> x -> Coroutine d m ()+put :: forall m a d x. (Monad m, AncestorFunctor a d) => Sink m a [x] -> x -> Coroutine d m () put sink x = putChunk sink [x] >> return () -- | Like 'put', but returns a Bool that determines if the sink is still active.-tryPut :: forall m a d x. (Monad m, AncestorFunctor a d) => Sink m a x -> x -> Coroutine d m Bool+tryPut :: forall m a d x. (Monad m, AncestorFunctor a d) => Sink m a [x] -> x -> Coroutine d m Bool tryPut sink x = liftM null $ putChunk sink [x] --- | 'putList' puts an entire list into its /sink/ argument. If the coroutine fed by the /sink/ dies, the remainder of+-- | 'putAll' puts an entire list into its /sink/ argument. If the coroutine fed by the /sink/ dies, the remainder of -- the argument list is returned.-putList :: forall m a d x. (Monad m, AncestorFunctor a d) => [x] -> Sink m a x -> Coroutine d m [x]-putList l sink = if null l then return [] else putChunk sink l--getChunk :: forall m a d x. (Monad m, AncestorFunctor a d) => Source m a x -> Coroutine d m [x]-getChunk source = liftM fst $ foldChunk source acceptAll---- | Like 'putList', except it puts the contents of the given 'Data.Sequence.Seq' into the sink.-putQueue :: forall m a d x. (Monad m, AncestorFunctor a d) => Seq x -> Sink m a x -> Coroutine d m [x]-putQueue q sink = putList (toList (viewl q)) sink+putAll :: forall m a d x. (Monad m, MonoidNull x, AncestorFunctor a d) => x -> Sink m a x -> Coroutine d m x+putAll l sink = if null l then return l else putChunk sink l -nullOrElse :: a -> ([x] -> a) -> [x] -> a-nullOrElse nullCase _ [] = nullCase-nullOrElse _ f list = f list+nullOrElse :: MonoidNull x => a -> (x -> a) -> x -> a+nullOrElse nullCase f x | null x = nullCase+ | otherwise = f x
Control/Concurrent/SCC/Types.hs view
@@ -1,5 +1,5 @@ {- - Copyright 2009-2010 Mario Blazevic+ Copyright 2009-2013 Mario Blazevic This file is part of the Streaming Component Combinators (SCC) project. @@ -18,13 +18,13 @@ -- 'Control.Concurrent.SCC.Streams.Sink' and 'Control.Concurrent.SCC.Streams.Source' values. The simplest of the bunch -- are 'Consumer' and 'Producer' types, which respectively operate on a single source or sink. A 'Transducer' has access -- both to a 'Control.Concurrent.SCC.Streams.Source' to read from and a 'Control.Concurrent.SCC.Streams.Sink' to write--- into. Finally, a 'Splitter' reads from a single source and writes all input into two sinks of the same type,--- signalling interesting input boundaries by writing into the third sink.+-- into. Finally, a 'Splitter' reads from a single source and writes all of the input, without any modifications, into+-- two sinks of the same type. -- {-# LANGUAGE ScopedTypeVariables, KindSignatures, RankNTypes,- MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, FunctionalDependencies, TypeFamilies #-}-{-# OPTIONS_HADDOCK hide #-}+ MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, OverlappingInstances,+ FunctionalDependencies, TypeFamilies #-} module Control.Concurrent.SCC.Types ( -- * Component types@@ -32,28 +32,32 @@ OpenConsumer, Consumer(..), OpenProducer, Producer(..), OpenTransducer, Transducer(..), OpenSplitter, Splitter(..), Boundary(..), Markup(..), Parser,- Branching (combineBranches),+ PipeableComponentPair (compose), Branching (combineBranches), -- * Component constructors isolateConsumer, isolateProducer, isolateTransducer, isolateSplitter,- oneToOneTransducer, statelessTransducer, statefulTransducer,+ oneToOneTransducer, statelessTransducer, statelessChunkTransducer, statefulTransducer, statelessSplitter, statefulSplitter, ) where -import Control.Category (Category(..))+import Control.Category (Category(id), (>>>)) import qualified Control.Category as Category+import Control.Monad (liftM)+import Data.Monoid (Monoid(..)) import Control.Monad.Coroutine+import Data.Monoid.Null (MonoidNull)+import Data.Monoid.Factorial (FactorialMonoid) import Control.Concurrent.SCC.Streams -type OpenConsumer m a d x r = AncestorFunctor a d => Source m a x -> Coroutine d m r-type OpenProducer m a d x r = AncestorFunctor a d => Sink m a x -> Coroutine d m r+type OpenConsumer m a d x r = (AncestorFunctor a d, Monoid x) => Source m a x -> Coroutine d m r+type OpenProducer m a d x r = (AncestorFunctor a d, Monoid x) => Sink m a x -> Coroutine d m r type OpenTransducer m a1 a2 d x y r = - (AncestorFunctor a1 d, AncestorFunctor a2 d) => Source m a1 x -> Sink m a2 y -> Coroutine d m r-type OpenSplitter m a1 a2 a3 a4 d x b r =- (AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d, AncestorFunctor a4 d) =>- Source m a1 x -> Sink m a2 x -> Sink m a3 x -> Sink m a4 b -> Coroutine d m r+ (AncestorFunctor a1 d, AncestorFunctor a2 d, Monoid x, Monoid y) => Source m a1 x -> Sink m a2 y -> Coroutine d m r+type OpenSplitter m a1 a2 a3 d x r =+ (AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d, Monoid x) =>+ Source m a1 x -> Sink m a2 x -> Sink m a3 x -> Coroutine d m r -- | A coroutine that has no inputs nor outputs - and therefore may not suspend at all, which means it's not really a -- /co/routine.@@ -72,15 +76,14 @@ -- | The 'Splitter' type represents coroutines that distribute the input stream acording to some criteria. A splitter -- should distribute only the original input data, and feed it into the sinks in the same order it has been read from--- the source. Furthermore, the input source should be entirely consumed and fed into the first two sinks. The third--- sink can be used to supply extra information at arbitrary points in the input.+-- the source. Furthermore, the input source should be entirely consumed and fed into the two sinks. -- -- A splitter can be used in two ways: as a predicate to determine which portions of its input stream satisfy a certain -- property, or as a chunker to divide the input stream into chunks. In the former case, the predicate is considered -- true for exactly those parts of the input that are written to its /true/ sink. In the latter case, a chunk is a--- contiguous section of the input stream that is written exclusively to one sink, either true or false. Anything--- written to the third sink also terminates the chunk.-newtype Splitter m x b = Splitter {split :: forall a1 a2 a3 a4 d. OpenSplitter m a1 a2 a3 a4 d x b ()}+-- contiguous section of the input stream that is written exclusively to one sink, either true or false. A 'mempty'+-- value written to either of the two sinks can also terminate the chunk written to the other sink.+newtype Splitter m x = Splitter {split :: forall a1 a2 a3 d. OpenSplitter m a1 a2 a3 d x ()} -- | A 'Boundary' 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'.@@ -90,7 +93,7 @@ data Markup y x = Content x | Markup (Boundary y) deriving (Eq) -- | A parser is a transducer that marks up its input.-type Parser m x b = Transducer m x (Markup b x)+type Parser m x b = Transducer m x [Markup b x] instance Functor Boundary where fmap f (Start b) = Start (f b)@@ -105,14 +108,15 @@ showsPrec _ (Content x) s = shows x s showsPrec _ (Markup b) s = '[' : shows b (']' : s) -instance Monad m => Category (Transducer m) where- id = Transducer pour- t1 . t2 = isolateTransducer $ \source sink-> - pipe (transduce t2 source) (\source'-> transduce t1 source' sink)- >> return ()+-- instance Monad m => Category (Transducer m) where+-- id = Transducer pour+-- t1 . t2 = isolateTransducer $ \source sink-> +-- pipe (transduce t2 source) (\source'-> transduce t1 source' sink)+-- >> return () -- | Creates a proper 'Consumer' from a function that is, but can't be proven to be, an 'OpenConsumer'.-isolateConsumer :: forall m x r. Monad m => (forall d. Functor d => Source m d x -> Coroutine d m r) -> Consumer m x r+isolateConsumer :: forall m x r. (Monad m, Monoid x) =>+ (forall d. Functor d => Source m d x -> Coroutine d m r) -> Consumer m x r isolateConsumer c = Consumer consume' where consume' :: forall a d. OpenConsumer m a d x r consume' source = let source' :: Source m d x@@ -120,7 +124,8 @@ in c source' -- | Creates a proper 'Producer' from a function that is, but can't be proven to be, an 'OpenProducer'.-isolateProducer :: forall m x r. Monad m => (forall d. Functor d => Sink m d x -> Coroutine d m r) -> Producer m x r+isolateProducer :: forall m x r. (Monad m, Monoid x) =>+ (forall d. Functor d => Sink m d x -> Coroutine d m r) -> Producer m x r isolateProducer p = Producer produce' where produce' :: forall a d. OpenProducer m a d x r produce' sink = let sink' :: Sink m d x@@ -128,7 +133,7 @@ in p sink' -- | Creates a proper 'Transducer' from a function that is, but can't be proven to be, an 'OpenTransducer'.-isolateTransducer :: forall m x y. Monad m => +isolateTransducer :: forall m x y. (Monad m, Monoid x) => (forall d. Functor d => Source m d x -> Sink m d y -> Coroutine d m ()) -> Transducer m x y isolateTransducer t = Transducer transduce' where transduce' :: forall a1 a2 d. OpenTransducer m a1 a2 d x y ()@@ -139,22 +144,73 @@ in t source' sink' -- | Creates a proper 'Splitter' from a function that is, but can't be proven to be, an 'OpenSplitter'.-isolateSplitter :: forall m x b. Monad m => - (forall d. Functor d => - Source m d x -> Sink m d x -> Sink m d x -> Sink m d b -> Coroutine d m ()) - -> Splitter m x b+isolateSplitter :: forall m x b. (Monad m, Monoid x) =>+ (forall d. Functor d => Source m d x -> Sink m d x -> Sink m d x -> Coroutine d m ())+ -> Splitter m x isolateSplitter s = Splitter split'- where split' :: forall a1 a2 a3 a4 d. OpenSplitter m a1 a2 a3 a4 d x b ()- split' source true false edge = let source' :: Source m d x- source' = liftSource source- true' :: Sink m d x- true' = liftSink true- false' :: Sink m d x- false' = liftSink false- edge' :: Sink m d b- edge' = liftSink edge- in s source' true' false' edge'+ where split' :: forall a1 a2 a3 d. OpenSplitter m a1 a2 a3 d x ()+ split' source true false = let source' :: Source m d x+ source' = liftSource source+ true' :: Sink m d x+ true' = liftSink true+ false' :: Sink m d x+ false' = liftSink false+ in s source' true' false' ++-- | Class 'PipeableComponentPair' applies to any two components that can be combined into a third component with the+-- following properties:+--+-- * The input of the result, if any, becomes the input of the first component.+--+-- * The output produced by the first child component is consumed by the second child component.+--+-- * The result output, if any, is the output of the second component.+class PipeableComponentPair (m :: * -> *) w c1 c2 c3 | c1 c2 -> c3, c1 c3 -> c2, c2 c3 -> c2,+ c1 -> m w, c2 -> m w, c3 -> m+ where compose :: PairBinder m -> c1 -> c2 -> c3++instance forall m x. (Monad m, Monoid x) => + PipeableComponentPair m x (Producer m x ()) (Consumer m x ()) (Performer m ())+ where compose binder p c = let performPipe :: Coroutine Naught m ((), ())+ performPipe = pipeG binder (produce p) (consume c)+ in Performer (runCoroutine performPipe >> return ())++instance forall m x r. (Monad m, Monoid x) => + PipeableComponentPair m x (Producer m x ()) (Consumer m x r) (Performer m r)+ where compose binder p c = let performPipe :: Coroutine Naught m ((), r)+ performPipe = pipeG binder (produce p) (consume c)+ in Performer (liftM snd $ runCoroutine performPipe)++instance forall m x r. (Monad m, Monoid x) => + PipeableComponentPair m x (Producer m x r) (Consumer m x ()) (Performer m r)+ where compose binder p c = let performPipe :: Coroutine Naught m (r, ())+ performPipe = pipeG binder (produce p) (consume c)+ in Performer (liftM fst $ runCoroutine performPipe)++instance (Monad m, Monoid x, Monoid y) => + PipeableComponentPair m y (Transducer m x y) (Consumer m y r) (Consumer m x r)+ where compose binder t c = isolateConsumer $ \source-> + liftM snd $+ pipeG binder+ (transduce t source)+ (consume c)++instance (Monad m, Monoid x, Monoid y) => + PipeableComponentPair m x (Producer m x r) (Transducer m x y) (Producer m y r)+ where compose binder p t = isolateProducer $ \sink-> + liftM fst $+ pipeG binder+ (produce p)+ (\source-> transduce t source sink)++instance (Monad m, Monoid x, Monoid y, Monoid z) => + PipeableComponentPair m y (Transducer m x y) (Transducer m y z) (Transducer m x z)+ where compose binder t1 t2 = + isolateTransducer $ \source sink-> + pipeG binder (transduce t1 source) (\source'-> transduce t2 source' sink)+ >> return ()+ -- | 'Branching' is a type class representing all types that can act as consumers, namely 'Consumer', -- 'Transducer', and 'Splitter'. class Branching c (m :: * -> *) x r | c -> m x where@@ -180,47 +236,50 @@ sink' = liftSink sink in Transducer transduce' -instance forall m x b. Monad m => Branching (Splitter m x b) m x () where+instance forall m x b. Monad m => Branching (Splitter m x) m x () where combineBranches combinator binder s1 s2- = let split' :: forall a1 a2 a3 a4 d. OpenSplitter m a1 a2 a3 a4 d x b ()- split' source true false edge = combinator binder- (\source'-> split s1 source' true' false' edge')- (\source'-> split s2 source' true' false' edge')- source+ = let split' :: forall a1 a2 a3 d. OpenSplitter m a1 a2 a3 d x ()+ split' source true false = combinator binder+ (\source'-> split s1 source' true' false')+ (\source'-> split s2 source' true' false')+ source where true' :: Sink m d x true' = liftSink true false' :: Sink m d x false' = liftSink false- edge' :: Sink m d b- edge' = liftSink edge in Splitter split' -- | Function 'oneToOneTransducer' takes a function that maps one input value to one output value each, and lifts it -- into a 'Transducer'.-oneToOneTransducer :: Monad m => (x -> y) -> Transducer m x y+oneToOneTransducer :: (Monad m, FactorialMonoid x, Monoid y) => (x -> y) -> Transducer m x y oneToOneTransducer f = Transducer (mapStream f) -- | Function 'statelessTransducer' takes a function that maps one input value into a list of output values, and -- lifts it into a 'Transducer'.-statelessTransducer :: Monad m => (x -> [y]) -> Transducer m x y-statelessTransducer f = Transducer (concatMapStream f)+statelessTransducer :: Monad m => (x -> y) -> Transducer m [x] y+statelessTransducer f = Transducer (mapStream (mconcat . map f)) +-- | Function 'statelessTransducer' takes a function that maps one input value into a list of output values, and+-- lifts it into a 'Transducer'.+statelessChunkTransducer :: Monad m => (x -> y) -> Transducer m x y+statelessChunkTransducer f = Transducer (mapStreamChunks f)+ -- | Function 'statefulTransducer' constructs a 'Transducer' from a state-transition function and the initial -- state. The transition function may produce arbitrary output at any transition step.-statefulTransducer :: Monad m => (state -> x -> (state, [y])) -> state -> Transducer m x y+statefulTransducer :: (Monad m, MonoidNull y) => (state -> x -> (state, y)) -> state -> Transducer m [x] y statefulTransducer f s0 = - Transducer (\source sink-> foldMStream_ (\ s x -> let (s', ys) = f s x in putList ys sink >> return s') s0 source)+ Transducer (\source sink-> foldMStream_ (\ s x -> let (s', ys) = f s x in putAll ys sink >> return s') s0 source) -- | Function 'statelessSplitter' takes a function that assigns a Boolean value to each input item and lifts it into -- a 'Splitter'.-statelessSplitter :: Monad m => (x -> Bool) -> Splitter m x b-statelessSplitter f = Splitter (\source true false _edge-> partitionStream f source true false)+statelessSplitter :: Monad m => (x -> Bool) -> Splitter m [x]+statelessSplitter f = Splitter (\source true false-> partitionStream f source true false) -- | Function 'statefulSplitter' takes a state-converting function that also assigns a Boolean value to each input -- item and lifts it into a 'Splitter'.-statefulSplitter :: Monad m => (state -> x -> (state, Bool)) -> state -> Splitter m x ()+statefulSplitter :: Monad m => (state -> x -> (state, Bool)) -> state -> Splitter m [x] statefulSplitter f s0 = - Splitter (\source true false _edge-> + Splitter (\source true false-> foldMStream_ (\ s x -> let (s', truth) = f s x in (if truth then put true x else put false x) >> return s') s0 source)
Control/Concurrent/SCC/XML.hs view
@@ -1,5 +1,5 @@ {-- Copyright 2009-2011 Mario Blazevic+ Copyright 2009-2012 Mario Blazevic This file is part of the Streaming Component Combinators (SCC) project. @@ -16,7 +16,8 @@ -- | Module "XML" defines primitives and combinators for parsing and manipulating XML. -{-# LANGUAGE PatternGuards, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables, Rank2Types #-}+{-# LANGUAGE PatternGuards, FlexibleContexts, MultiParamTypeClasses, OverloadedStrings,+ ScopedTypeVariables, Rank2Types #-} {-# OPTIONS_HADDOCK hide #-} module Control.Concurrent.SCC.XML (@@ -37,13 +38,13 @@ import Data.Maybe (mapMaybe) import Data.Monoid (Monoid(..)) import Data.List (find)+import Data.String (IsString(fromString)) import Data.Text (Text, pack, unpack, singleton) import qualified Data.Text as Text import Numeric (readDec, readHex) -import Data.Functor.Contravariant.Ticker (andThen, tickOne, tickWhile)-import Text.ParserCombinators.Incremental (Parser, more, feed, anyToken, satisfy, concatMany, takeWhile, takeWhile1, string,- moptional, skip, lookAhead, notFollowedBy, mapIncremental, (><))+import Text.ParserCombinators.Incremental (Parser, more, feed, anyToken, satisfy, concatMany, takeWhile, takeWhile1, + string, moptional, skip, lookAhead, notFollowedBy, mapIncremental, (><)) import qualified Text.ParserCombinators.Incremental.LeftBiasedLocal as LeftBiasedLocal (Parser) import Text.ParserCombinators.Incremental.LeftBiasedLocal (leftmost) import Control.Monad.Coroutine (Coroutine, sequentialBinder)@@ -85,7 +86,7 @@ _ -> XMLStream (l ++ r) XMLStream l `mappend` XMLStream r = XMLStream (l ++ r) -xmlParser :: LeftBiasedLocal.Parser String XMLStream+xmlParser :: LeftBiasedLocal.Parser Text XMLStream xmlParser = concatMany (xmlContent <|> xmlMarkup) where xmlContent = mapContent $ takeWhile1 (\x-> x /= "<" && x /= "&") xmlMarkup = (string "<" >> ((startTag <|> endTag <|> processingInstruction <|> declaration)@@ -103,12 +104,12 @@ >< (string ">" >> return (XMLStream [Content (singleton '>'), Markup (End StartTag)]) <|> return (XMLStream [Markup $ Point unterminatedStartTag, Markup $ End StartTag])) entityReference s = string s- >> (return (XMLStream [Markup (Start EntityReference), Content (pack s),+ >> (return (XMLStream [Markup (Start EntityReference), Content s, Markup (Start EntityName)]) >< name >< (string ";" >> return (XMLStream [Markup (End EntityName), Content (singleton ';'), Markup (End EntityReference)]))- <|> return (XMLStream [Markup $ Point $ errorBadEntityReference, Content (pack s)]))+ <|> return (XMLStream [Markup $ Point $ errorBadEntityReference, Content s])) attributes = concatMany (attribute >< whiteSpace) attribute = return (XMLStream [Markup (Start AttributeName)]) >< name@@ -117,46 +118,45 @@ <|> (fmap (\x-> XMLStream [Markup $ Point $ errorBadAttribute x]) anyToken >< whiteSpace >< moptional (mapContent $ string "="))) >< ((string "\"" <|> string "\'")- >>= \quote-> return (XMLStream [Content $ pack quote, Markup (Start AttributeValue)])+ >>= \quote-> return (XMLStream [Content quote, Markup (Start AttributeValue)]) >< mapContent (takeWhile (/= quote))- >< return (XMLStream [Markup (End AttributeValue), Content $ pack quote])+ >< return (XMLStream [Markup (End AttributeValue), Content quote]) >< skip (string quote) <|> (anyToken >>= \q-> return (XMLStream [Markup $ Point $ errorBadQuoteCharacter q,- Content $ pack quote])))- endTag = (string "/" >> return (XMLStream [Markup (Start EndTag), Content (pack "</"),- Markup (Start ElementName)]))+ Content quote])))+ endTag = (string "/" >> return (XMLStream [Markup (Start EndTag), Content "</", Markup (Start ElementName)])) >< name >< return (XMLStream [Markup (End ElementName)]) >< whiteSpace >< (string ">" >> return (XMLStream [Content (singleton '>'), Markup (End EndTag)]) <|> return (XMLStream [Markup $ Point unterminatedEndTag, Markup (End EndTag)])) processingInstruction = (string "?"- >> return (XMLStream [Markup (Start ProcessingInstruction), Content (pack "<?"),+ >> return (XMLStream [Markup (Start ProcessingInstruction), Content "<?", Markup (Start ProcessingInstructionText)])) >< upto "?>" >< (string "?>"- >> return (XMLStream [Markup (End ProcessingInstructionText), Content (pack "?>"),+ >> return (XMLStream [Markup (End ProcessingInstructionText), Content "?>", Markup (End ProcessingInstruction)]) <|> return (XMLStream [Markup $ Point unterminatedProcessingInstruction]))- declaration = string "!" + declaration = string "!" >> ((comment <|> cdataMarkedSection <|> doctypeDeclaration)- <|> return (XMLStream [Markup $ Point $ errorBadDeclarationType, Content (pack "<")]))- comment = (string "--" >> return (XMLStream [Markup (Start Comment), Content (pack "<!--"),+ <|> return (XMLStream [Markup $ Point $ errorBadDeclarationType, Content "<"]))+ comment = (string "--" >> return (XMLStream [Markup (Start Comment), Content "<!--", Markup (Start CommentText)])) >< upto "-->"- >< (string "-->" >> return (XMLStream [Markup (End CommentText), Content (pack "-->"),+ >< (string "-->" >> return (XMLStream [Markup (End CommentText), Content "-->", Markup (End Comment)]) <|> return (XMLStream [Markup $ Point unterminatedComment])) cdataMarkedSection = (string "[CDATA["- >> return (XMLStream [Markup (Start StartMarkedSectionCDATA), Content (pack "<![CDATA["),+ >> return (XMLStream [Markup (Start StartMarkedSectionCDATA), Content "<![CDATA[", Markup (End StartMarkedSectionCDATA)])) >< upto "]]>" >< (string "]]>"- >> return (XMLStream [Markup (Start EndMarkedSection), Content (pack "]]>"),+ >> return (XMLStream [Markup (Start EndMarkedSection), Content "]]>", Markup (End EndMarkedSection)]) <|> return (XMLStream [Markup $ Point unterminatedMarkedSection])) doctypeDeclaration = (string "DOCTYPE" >> return (XMLStream [Markup (Start DoctypeDeclaration),- Content (pack "<!DOCTYPE")]))+ Content "<!DOCTYPE"])) >< whiteSpace >< (name >< whiteSpace@@ -172,18 +172,19 @@ <|> return (XMLStream [Markup (Point errorMalformedDoctypeDeclaration)])) >< return (XMLStream [Markup (End DoctypeDeclaration)]) literal = (string "\"" <|> string "\'")- >>= \quote-> return (XMLStream [Content $ pack quote])+ >>= \quote-> return (XMLStream [Content quote]) >< mapContent (takeWhile (/= quote))- >< return (XMLStream [Content $ pack quote])+ >< return (XMLStream [Content quote]) >< skip (string quote) markupDeclaration= mapContent (string "<!") >< (concatMany (mapContent (takeWhile1 (\x-> x /= ">" && x /= "\"" && x /= "\'")) <|> literal) >< mapContent (string ">") <|> return (XMLStream [Markup $ Point unterminatedMarkupDeclaration]))- name = mapContent (takeWhile1 (isNameChar . head))- mapContent = mapIncremental (XMLStream . (:[]) . Content . pack)- whiteSpace = mapContent (takeWhile (isSpace . head))- upto end@(lead:_) = mapContent (concatMany (takeWhile1 (/= [lead]) <|> notFollowedBy (string end) >< anyToken))+ name = mapContent (takeWhile1 (isNameChar . Text.head))+ mapContent = mapIncremental (XMLStream . (:[]) . Content)+ whiteSpace = mapContent (takeWhile (isSpace . Text.head))+ upto end@(lead:_) = mapContent (concatMany (takeWhile1 ((lead /=) . Text.head)+ <|> notFollowedBy (string $ fromString end) >< anyToken)) errorBadQuoteCharacter q = ErrorToken ("Invalid quote character " ++ show q) errorBadAttribute x = ErrorToken ("Invalid character " ++ show x ++ " following attribute name")@@ -203,19 +204,16 @@ isNameChar x = isAlphaNum x || x == '_' || x == '-' || x == ':' -- | XML markup splitter wrapping 'parseXMLTokens'.-xmlTokens :: Monad m => Splitter m Char (Boundary XMLToken)-xmlTokens = parserToSplitter (parseXMLTokens >>> statelessTransducer unpackContent)- where unpackContent :: Markup XMLToken Text -> [Markup XMLToken Char]- unpackContent (Markup b) = [Markup b]- unpackContent (Content c) = map Content (unpack c)+xmlTokens :: Monad m => Splitter m Text+xmlTokens = parserToSplitter parseXMLTokens -- | The XML token parser. This parser converts plain text to parsed text, which is a precondition for using the -- remaining XML components.-parseXMLTokens :: Monad m => Transducer m Char (Markup XMLToken Text)+parseXMLTokens :: Monad m => Transducer m Text [Markup XMLToken Text] parseXMLTokens = Transducer (pourParsed (mapIncremental chunk xmlParser)) dispatchOnString :: forall m a d r. (Monad m, AncestorFunctor a d) =>- Source m a Char -> (String -> Coroutine d m r) -> [(String, String -> Coroutine d m r)]+ Source m a [Char] -> (String -> Coroutine d m r) -> [(String, String -> Coroutine d m r)] -> Coroutine d m r dispatchOnString source failure fullCases = dispatch fullCases id where dispatch cases consumed@@ -231,7 +229,7 @@ | otherwise = Nothing getElementName :: forall m a d. (Monad m, AncestorFunctor a d) =>- Source m a (Markup XMLToken Text) -> ([Markup XMLToken Text] -> [Markup XMLToken Text])+ Source m a [Markup XMLToken Text] -> ([Markup XMLToken Text] -> [Markup XMLToken Text]) -> Coroutine d m ([Markup XMLToken Text], Maybe Text) getElementName source f = get source >>= maybe@@ -244,7 +242,7 @@ _ -> error ("Expected an ElementName, received " ++ show x)) getRestOfRegion :: forall m a d. (Monad m, AncestorFunctor a d) =>- XMLToken -> Source m a (Markup XMLToken Text)+ XMLToken -> Source m a [Markup XMLToken Text] -> ([Markup XMLToken Text] -> [Markup XMLToken Text]) -> (Text -> Text) -> Coroutine d m ([Markup XMLToken Text], Maybe Text) getRestOfRegion token source f g = getWhile isContent source@@ -256,8 +254,8 @@ _ -> error ("Expected rest of " ++ show token ++ ", received " ++ show x) pourRestOfRegion :: forall m a1 a2 a3 d. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d) =>- XMLToken -> Source m a1 (Markup XMLToken Text)- -> Sink m a2 (Markup XMLToken Text) -> Sink m a3 (Markup XMLToken Text)+ XMLToken -> Source m a1 [Markup XMLToken Text]+ -> Sink m a2 [Markup XMLToken Text] -> Sink m a3 [Markup XMLToken Text] -> Coroutine d m Bool pourRestOfRegion token source sink endSink = pourWhile isContent source sink >> get source@@ -270,7 +268,7 @@ ++ ", received " ++ show x)) getRestOfStartTag :: forall m a d. (Monad m, AncestorFunctor a d) =>- Source m a (Markup XMLToken Text) -> Coroutine d m ([Markup XMLToken Text], Bool)+ Source m a [Markup XMLToken Text] -> Coroutine d m ([Markup XMLToken Text], Bool) getRestOfStartTag source = do rest <- getWhile notEndTag source end <- get source case end of Nothing -> return (rest, False)@@ -279,65 +277,65 @@ getRestOfStartTag source >>= \(rest', _)-> return (rest ++ (e: rest'), False) _ -> error "getWhile returned early!"- where notEndTag (Markup (End StartTag)) = False- notEndTag (Markup (Point EmptyTag)) = False+ where notEndTag [Markup (End StartTag)] = False+ notEndTag [Markup (Point EmptyTag)] = False notEndTag _ = True getRestOfEndTag :: forall m a d. (Monad m, AncestorFunctor a d) =>- Source m a (Markup XMLToken Text) -> Coroutine d m [Markup XMLToken Text]-getRestOfEndTag source = getWhile (/= Markup (End EndTag)) source+ Source m a [Markup XMLToken Text] -> Coroutine d m [Markup XMLToken Text]+getRestOfEndTag source = getWhile (/= [Markup (End EndTag)]) source >>= \tokens-> get source >>= maybe (error "No end to the end tag!") (return . (tokens ++) . (:[])) findEndTag :: forall m a1 a2 a3 d. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d) =>- Source m a1 (Markup XMLToken Text) -> Sink m a2 (Markup XMLToken Text) -> Sink m a3 (Markup XMLToken Text)+ Source m a1 [Markup XMLToken Text] -> Sink m a2 [Markup XMLToken Text] -> Sink m a3 [Markup XMLToken Text] -> Text -> Coroutine d m () findEndTag source sink endSink name = findTag where findTag = pourWhile noTagStart source sink >> get source >>= maybe (return ()) consumeOne- noTagStart (Markup (Start StartTag)) = False- noTagStart (Markup (Start EndTag)) = False+ noTagStart [Markup (Start StartTag)] = False+ noTagStart [Markup (Start EndTag)] = False noTagStart _ = True consumeOne x@(Markup (Start EndTag)) = do (tokens, mn) <- getElementName source (x :) maybe (return ()) (\name'-> getRestOfEndTag source >>= \rest-> if name == name'- then putList (tokens ++ rest) endSink+ then putAll (tokens ++ rest) endSink >> return ()- else putList (tokens ++ rest) sink+ else putAll (tokens ++ rest) sink >> findTag) mn consumeOne x@(Markup (Start StartTag)) = do (tokens, mn) <- getElementName source (x :) maybe (return ()) (\name'-> do (rest, hasContent) <- getRestOfStartTag source- _ <- putList (tokens ++ rest) sink+ _ <- putAll (tokens ++ rest) sink when hasContent (findEndTag source sink sink name') findTag) mn consumeOne _ = error "pourWhile returned early!" findStartTag :: forall m a1 a2 d. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d) =>- Source m a1 (Markup XMLToken Text) -> Sink m a2 (Markup XMLToken Text)+ Source m a1 [Markup XMLToken Text] -> Sink m a2 [Markup XMLToken Text] -> Coroutine d m (Maybe (Markup XMLToken Text))-findStartTag source sink = pourWhile (/= Markup (Start StartTag)) source sink >> get source+findStartTag source sink = pourWhile (/= [Markup (Start StartTag)]) source sink >> get source -- | Splits all top-level elements with all their content to /true/, all other input to /false/.-xmlElement :: Monad m => Splitter m (Markup XMLToken Text) ()+xmlElement :: Monad m => Splitter m [Markup XMLToken Text] xmlElement = Splitter $- \source true false edge->+ \source true false-> let split0 = findStartTag source false >>= maybe (return [])- (\x-> do put edge ()+ (\x-> do putChunk false mempty put true x (tokens, mn) <- getElementName source id maybe- (putList tokens true)+ (putAll tokens true) (\name-> do (rest, hasContent) <- getRestOfStartTag source- _ <- putList (tokens ++ rest) true+ _ <- putAll (tokens ++ rest) true if hasContent then split1 name else split0)@@ -347,19 +345,19 @@ in split0 >> return () -- | Splits the content of all top-level elements to /true/, their tags and intervening input to /false/.-xmlElementContent :: Monad m => Splitter m (Markup XMLToken Text) ()+xmlElementContent :: Monad m => Splitter m [Markup XMLToken Text] xmlElementContent = Splitter $- \source true false edge->+ \source true false-> let split0 = findStartTag source false >>= maybe (return []) (\x-> do put false x (tokens, mn) <- getElementName source id maybe- (putList tokens false)+ (putAll tokens false) (\name-> do (rest, hasContent) <- getRestOfStartTag source- _ <- putList (tokens ++ rest) false+ _ <- putAll (tokens ++ rest) false if hasContent- then put edge () >> split1 name+ then split1 name else split0) mn) split1 name = findEndTag source true false name@@ -368,10 +366,9 @@ -- | 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.-xmlElementHavingTagWith :: forall m b. Monad m =>- Splitter m (Markup XMLToken Text) b -> Splitter m (Markup XMLToken Text) b+xmlElementHavingTagWith :: forall m b. Monad m => Splitter m [Markup XMLToken Text] -> Splitter m [Markup XMLToken Text] xmlElementHavingTagWith test =- isolateSplitter $ \ source true false edge ->+ isolateSplitter $ \ source true false -> let split0 = findStartTag source false >>= maybe (return ()) (\x-> do (tokens, mn) <- getElementName source (x :)@@ -379,64 +376,62 @@ (return ()) (\name-> do (rest, hasContent) <- getRestOfStartTag source let tag = tokens ++ rest- (_, found) <- pipe (putList tag) (findsTrueIn test)- case found of Just mb -> maybe (return ()) (put edge) mb- >> putList tag true- >> split1 hasContent true name- Nothing -> putList tag false- >> split1 hasContent false name)+ (_, found) <- pipe (putAll tag) (findsTrueIn test)+ if found then putChunk false mempty+ >> putAll tag true+ >> split1 hasContent true name+ else putAll tag false+ >> split1 hasContent false name) mn) split1 hasContent sink name = when hasContent (findEndTag source sink sink name) >> split0 in split0 -- | Splits every attribute specification to /true/, everything else to /false/.-xmlAttribute :: Monad m => Splitter m (Markup XMLToken Text) ()+xmlAttribute :: Monad m => Splitter m [Markup XMLToken Text] xmlAttribute = Splitter $- \source true false edge->- let split0 = getWith+ \source true false->+ let split0 = getWith source (\x-> case x- of Markup (Start AttributeName) ->- do put edge ()- put true x+ of [Markup (Start AttributeName)] ->+ do putChunk false mempty+ putChunk true x pourRestOfRegion AttributeName source true true >>= flip when split1- _ -> put false x >> split0)- source- split1 = getWith+ _ -> putChunk false x >> split0)+ split1 = getWith source (\x-> case x- of Markup (Start AttributeValue)- -> put true x+ of [Markup (Start AttributeValue)]+ -> putChunk true x >> pourRestOfRegion AttributeValue source true true >>= flip when split0- _ -> put true x >> split1)- source+ _ -> putChunk true x >> split1) 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/.-xmlElementName :: Monad m => Splitter m (Markup XMLToken Text) ()+xmlElementName :: Monad m => Splitter m [Markup XMLToken Text] xmlElementName = Splitter (splitSimpleRegions ElementName) -- | Splits every attribute name to /true/, all the rest of input to /false/.-xmlAttributeName :: Monad m => Splitter m (Markup XMLToken Text) ()+xmlAttributeName :: Monad m => Splitter m [Markup XMLToken Text] xmlAttributeName = Splitter (splitSimpleRegions AttributeName) -- | Splits every attribute value, excluding the quote delimiters, to /true/, all the rest of input to /false/.-xmlAttributeValue :: Monad m => Splitter m (Markup XMLToken Text) ()+xmlAttributeValue :: Monad m => Splitter m [Markup XMLToken Text] xmlAttributeValue = Splitter (splitSimpleRegions AttributeValue) -splitSimpleRegions :: Monad m => XMLToken -> OpenSplitter m a1 a2 a3 a4 d (Markup XMLToken Text) () ()-splitSimpleRegions token source true false edge = split0- where split0 = getWith consumeOne source- consumeOne x@(Markup (Start token')) | token == token' = put false x- >> put edge ()+splitSimpleRegions :: Monad m => XMLToken -> OpenSplitter m a1 a2 a3 d [Markup XMLToken Text] ()+splitSimpleRegions token source true false = split0+ where split0 = getWith source consumeOne+ consumeOne x@[Markup (Start token')] | token == token' = putChunk false x+ >> putChunk true mempty >> pourRestOfRegion token source true false >>= flip when split0- consumeOne x = put false x >> split0+ consumeOne x = putChunk false x >> split0 -isContent :: Markup b x -> Bool-isContent Content{} = True+isContent :: [Markup b x] -> Bool+isContent [Content{}] = True isContent _ = False fromContent :: Markup b x -> x
Makefile view
@@ -1,11 +1,11 @@ Executables=${TestExecutables} shsh shsh-prof-TestExecutables=$(addprefix test/, scc parallel benchmark-coroutine incremental-parser \- enumerator iteratee enumerator-scc)-IterativeParserFiles=Text/ParserCombinators/Incremental.hs \- Control/Applicative/Monoid.hs \- $(addprefix Data/Monoid/, Cancellative.hs Factorial.hs Null.hs)-CoroutineLibraryFiles=$(IterativeParserFiles) Data/Functor/Contravariant/Ticker.hs \- $(addprefix Control/Monad/, \+TestExecutables=$(addprefix test/, scc parallel benchmark-coroutine incremental-parser monoid-subclasses \+ enumerator iteratee)+IncrementalParserFiles=Text/ParserCombinators/Incremental.hs Control/Applicative/Monoid.hs $(MonoidSubclassFiles)+MonoidSubclassFiles=$(addprefix Data/Monoid/, Cancellative.hs Factorial.hs Null.hs Textual.hs \+ Instances/ByteString/UTF8.hs)+CoroutineLibraryFiles=$(IncrementalParserFiles) \+ $(addprefix Control/Monad/, \ Parallel.hs Coroutine.hs Coroutine/SuspensionFunctors.hs Coroutine/Nested.hs) SCCCommonFiles=$(CoroutineLibraryFiles) \ Control/Concurrent/Configuration.hs \@@ -31,20 +31,18 @@ test/benchmark-coroutine: Test/BenchmarkCoroutine.hs $(CoroutineLibraryFiles) | obj test ghc --make $< -o $@ $(OptimizingOptions) -eventlog -test/incremental-parser: Test/TestIncrementalParser.hs Text/ParserCombinators/Incremental.hs | obj test+test/incremental-parser: Test/TestIncrementalParser.hs $(IncrementalParserFiles) | obj test ghc --make $< -o $@ $(OptimizingOptions) -eventlog +test/monoid-subclasses: Test/TestMonoidSubclasses.hs $(MonoidSubclassFiles) | obj test+ ghc --make $< -o $@ $(OptimizingOptions) -eventlog -hide-package checkers -package quickcheck-instances+ test/enumerator: Test/TestEnumerator.hs $(CoroutineLibraryFiles) Control/Monad/Coroutine/Enumerator.hs | obj test ghc --make $< -o $@ $(OptimizingOptions) -eventlog test/iteratee: Test/TestIteratee.hs $(CoroutineLibraryFiles) Control/Monad/Coroutine/Iteratee.hs | obj test ghc --make $< -o $@ $(OptimizingOptions) -eventlog -test/enumerator-scc: Test/TestEnumeratorSCC.hs $(SCCCommonFiles) \- Control/Monad/Coroutine/Enumerator.hs \- Control/Concurrent/SCC/Combinators/Sequential.hs Control/Concurrent/SCC/Sequential.hs | obj test- ghc --make $< -o $@ $(OptimizingOptions) -eventlog- test/parallel: Test/TestParallel.hs Control/Monad/Parallel.hs | obj test ghc --make $< -o $@ $(OptimizingOptions) -eventlog @@ -52,6 +50,9 @@ ghc --make $< -o $@ $(OptimizingOptions) shsh-prof: Shell.hs $(AllLibraryFiles) | prof+ ghc --make $< -o $@ $(ProfilingOptions)++test/scc-prof: Test/TestSCC.hs $(AllLibraryFiles) | prof test ghc --make $< -o $@ $(ProfilingOptions) doc/index.html: $(DocumentationFiles) | doc
Shell.hs view
@@ -1,5 +1,5 @@ {- - Copyright 2008-2010 Mario Blazevic+ Copyright 2008-2013 Mario Blazevic This file is part of the Streaming Component Combinators (SCC) project. @@ -18,10 +18,11 @@ module Main where -import Prelude hiding (appendFile, interact, id, last, sequence)+import Prelude hiding (appendFile, interact, id, last, null, sequence) import Data.List (intersperse, partition) import Data.Char (isAlphaNum) import Data.Maybe (fromJust)+import Data.Monoid (Monoid) import Data.Text (Text) import Control.Concurrent (forkIO) import Control.Exception (evaluate)@@ -34,7 +35,7 @@ import Text.Parsec.Language (emptyDef) import Text.Parsec.Token import System.Console.GetOpt-import System.Console.Readline+import System.Console.Haskeline import System.Environment (getArgs) import System.IO (BufferMode (NoBuffering), hFlush, hIsWritable, hPutStrLn, hReady, hSetBuffering, stderr, stdout) import qualified System.Process as Process@@ -44,14 +45,17 @@ import System.IO (Handle, IOMode (ReadMode, WriteMode, AppendMode), openFile, hClose, hGetChar, hGetContents, hPutChar, hFlush, hIsEOF, hClose, putChar, isEOF, stdout) -import Control.Concurrent.Configuration (Component, atomic, showComponentTree, usingThreads, with) import Control.Monad.Parallel (MonadParallel) import Control.Monad.Coroutine+import Data.Monoid.Null (MonoidNull(null))+import Data.Monoid.Factorial (FactorialMonoid)++import Control.Concurrent.Configuration (Component, atomic, showComponentTree, usingThreads, with) import Control.Concurrent.SCC.Streams import Control.Concurrent.SCC.Types import qualified Control.Concurrent.SCC.Coercions as Coercions import Control.Concurrent.SCC.Configurable hiding ((&&), (||))-import Control.Concurrent.SCC.Combinators (JoinableComponentPair, compose)+import Control.Concurrent.SCC.Combinators (JoinableComponentPair) import qualified Control.Concurrent.SCC.Configurable as Combinators ((&&), (||)) data Expression where@@ -68,7 +72,7 @@ -- Void expressions, i.e. commands Exit :: Expression -- ProducerComponent constructs- FromList :: String -> Expression+ ProduceFrom :: String -> Expression FileProducer :: String -> Expression StdInProducer :: Expression -- ConsumerComponent constructs@@ -136,7 +140,7 @@ (" else " ++ showsPrec 0 f (" end foreach" ++ rest))) showsPrec _ Exit rest = "Exit" ++ rest showsPrec _ (FileProducer f) rest = "FileProducer \"" ++ f ++ "\"" ++ rest- showsPrec _ (FromList str) rest = "echo \"" ++ str ++ "\"" ++ rest+ showsPrec _ (ProduceFrom str) rest = "echo \"" ++ str ++ "\"" ++ rest showsPrec 0 (Sequence p1 p2) rest = showsPrec 2 p1 (";\n" ++ showsPrec 0 p2 rest) showsPrec 1 (Sequence p1 p2) rest = showsPrec 2 p1 ("; " ++ showsPrec 1 p2 rest) showsPrec p e@Sequence{} rest = "(" ++ showsPrec 1 e (')' : rest)@@ -214,10 +218,10 @@ -- Streaming component type tags ComponentTag :: TypeTag x -> TypeTag (Component x) CommandTag :: TypeTag (Performer IO ())- ConsumerTag :: TypeTag x -> TypeTag (Consumer IO x ())- ProducerTag :: TypeTag x -> TypeTag (Producer IO x ())- SplitterTag :: TypeTag x -> TypeTag b -> TypeTag (Splitter IO x b)- TransducerTag :: TypeTag x -> TypeTag y -> TypeTag (Transducer IO x y)+ ConsumerTag :: Monoid x => TypeTag x -> TypeTag (Consumer IO x ())+ ProducerTag :: Monoid x => TypeTag x -> TypeTag (Producer IO x ())+ SplitterTag :: Monoid x => TypeTag x -> TypeTag (Splitter IO x)+ TransducerTag :: (Monoid x, Monoid y) => TypeTag x -> TypeTag y -> TypeTag (Transducer IO x y) GenericInputTag :: (TypeTag x -> TypeTag y) -> TypeTag y instance Show (TypeTag x) where@@ -236,7 +240,7 @@ show CommandTag = "Command" show (ConsumerTag x) = "Consumer " ++ show x show (ProducerTag x) = "Producer " ++ show x- show (SplitterTag x b) = "Splitter " ++ shows x (" " ++ show b)+ show (SplitterTag x) = "Splitter " ++ show x show (TransducerTag x y) = "Transducer " ++ shows x (" -> " ++ show y) show GenericInputTag{} = "Generic" @@ -271,10 +275,10 @@ (CoercibleRelation{}, IdentityRelation{}) -> Just (fmap (coerce >->) x) (IdentityRelation{}, CoercibleRelation{}) -> Just (fmap (>-> coerce) x) _ -> Nothing-typecoerce (ComponentTag (SplitterTag tag1 b1)) (ComponentTag (SplitterTag tag2 b2)) x = - case (relateTags tag1 tag2, relateTags tag2 tag1, relateTags b1 b2)- of (IdentityRelation{}, IdentityRelation{}, IdentityRelation{}) -> Just x- (CoercibleRelation{}, CoercibleRelation{}, IdentityRelation{}) -> Just (fmap adaptSplitter x)+typecoerce (ComponentTag (SplitterTag tag1)) (ComponentTag (SplitterTag tag2)) x = + case (relateTags tag1 tag2, relateTags tag2 tag1)+ of (IdentityRelation{}, IdentityRelation{}) -> Just x+ (CoercibleRelation{}, CoercibleRelation{}) -> Just (fmap adaptSplitter x) _ -> Nothing typecoerce (ComponentTag a) (ComponentTag b) x = fmap (\(CComponent y)-> y) (typecoerce a b (CComponent x)) typecoerce (ProducerTag tag1) (ProducerTag tag2) x = @@ -299,8 +303,12 @@ NoRelation :: TypeTagRelation x y data TypeTagClass x where- ShowClass :: Show x => TypeTag x -> TypeTagClass x EqClass :: Eq x => TypeTag x -> TypeTagClass x+ ListClass :: x ~ [y] => TypeTag x -> TypeTagClass x+ MonoidClass :: Monoid x => TypeTag x -> TypeTagClass x+ MonoidNullClass :: MonoidNull x => TypeTag x -> TypeTagClass x+ FactorialMonoidClass :: FactorialMonoid x => TypeTag x -> TypeTagClass x+ ShowClass :: Show x => TypeTag x -> TypeTagClass x NoClass :: TypeTagClass x relateTags :: forall a b. TypeTag a -> TypeTag b -> TypeTagRelation a b@@ -310,6 +318,20 @@ relateTags IntTag IntTag = IdentityRelation IntTag relateTags UnitTag UnitTag = IdentityRelation UnitTag relateTags XMLTokenTag XMLTokenTag = IdentityRelation XMLTokenTag+relateTags (ListTag CharTag) (ListTag TextTag) = CoercibleRelation (ListTag CharTag) (ListTag TextTag)+relateTags (ListTag CharTag) TextTag = CoercibleRelation (ListTag CharTag) TextTag+relateTags (ListTag TextTag) (ListTag CharTag) = CoercibleRelation (ListTag TextTag) (ListTag CharTag)+relateTags TextTag (ListTag CharTag) = CoercibleRelation TextTag (ListTag CharTag)+relateTags (ListTag tag1@MarkupTag{}) (ListTag tag2@MarkupTag{}) = + case relateTags tag1 tag2+ of IdentityRelation tag' -> IdentityRelation (ListTag tag')+ _ -> NoRelation+relateTags (ListTag (MarkupTag tag1b tag1)) (ListTag tag2) = + case relateTags (ListTag tag1) (ListTag tag2)+ of IdentityRelation (ListTag tag') -> CoercibleRelation (ListTag (MarkupTag tag1b tag')) (ListTag tag')+ CoercibleRelation (ListTag tag1') (ListTag tag2') -> + CoercibleRelation (ListTag (MarkupTag tag1b tag1')) (ListTag tag2')+ NoRelation -> NoRelation relateTags (ListTag tag1) (ListTag tag2) = case relateTags tag1 tag2 of IdentityRelation tag' -> IdentityRelation (ListTag tag')@@ -337,19 +359,10 @@ relateTags (TransducerTag tag1a tag1b) (TransducerTag tag2a tag2b) | IdentityRelation tag'a <- relateTags tag1a tag2a, IdentityRelation tag'b <- relateTags tag1b tag2b = IdentityRelation (TransducerTag tag'a tag'b)-relateTags (SplitterTag tag1 tag1b) (SplitterTag tag2 tag2b) - | IdentityRelation tag'b <- relateTags tag1b tag2b,- IdentityRelation tag' <- relateTags tag1 tag2 = IdentityRelation (SplitterTag tag' tag'b)+relateTags (SplitterTag tag1) (SplitterTag tag2) + | IdentityRelation tag' <- relateTags tag1 tag2 = IdentityRelation (SplitterTag tag') relateTags (ComponentTag tag1) (ComponentTag tag2) | IdentityRelation tag' <- relateTags tag1 tag2 = IdentityRelation (ComponentTag tag')--relateTags CharTag TextTag = CoercibleRelation CharTag TextTag-relateTags TextTag CharTag = CoercibleRelation TextTag CharTag-relateTags (MarkupTag tag1b tag1) tag2 = - case relateTags tag1 tag2- of IdentityRelation tag' -> CoercibleRelation (MarkupTag tag1b tag') tag'- CoercibleRelation tag1' tag2' -> CoercibleRelation (MarkupTag tag1b tag1') tag2'- NoRelation -> NoRelation relateTags _ _ = NoRelation constrainEq :: TypeTag x -> TypeTagClass x@@ -368,6 +381,10 @@ | EqClass tag1' <- constrainEq tag1, EqClass tag2' <- constrainEq tag2 = EqClass (MarkupTag tag1' tag2') constrainEq _ = NoClass +constrainList :: TypeTag x -> TypeTagClass x+constrainList tag@ListTag{} = ListClass tag+constrainList _ = NoClass+ constrainShow :: TypeTag x -> TypeTagClass x constrainShow CharTag = ShowClass CharTag constrainShow TextTag = ShowClass TextTag@@ -384,6 +401,23 @@ | ShowClass tag1' <- constrainShow tag1, ShowClass tag2' <- constrainShow tag2 = ShowClass (MarkupTag tag1' tag2') constrainShow _ = NoClass +constrainMonoid :: TypeTag x -> TypeTagClass x+constrainMonoid TextTag = MonoidClass TextTag+constrainMonoid UnitTag = MonoidClass UnitTag+constrainMonoid tag@ListTag{} = MonoidClass tag+constrainMonoid _ = NoClass++constrainMonoidNull :: TypeTag x -> TypeTagClass x+constrainMonoidNull TextTag = MonoidNullClass TextTag+constrainMonoidNull UnitTag = MonoidNullClass UnitTag+constrainMonoidNull tag@ListTag{} = MonoidNullClass tag+constrainMonoidNull _ = NoClass++constrainFactorialMonoid :: TypeTag x -> TypeTagClass x+constrainFactorialMonoid TextTag = FactorialMonoidClass TextTag+constrainFactorialMonoid tag@ListTag{} = FactorialMonoidClass tag+constrainFactorialMonoid _ = NoClass+ data Flag = Command | Help | Interactive | PrettyPrint | ScriptFile String | StandardInput | Threads String deriving Eq @@ -426,10 +460,10 @@ then showHelp else case inputSourceFlag options of CommandLineSource -> interpret options (concat (intersperse " " arguments)) >> return ()- InteractiveSource -> interact options+ InteractiveSource -> runInputT defaultSettings $ interact options ScriptFileSource name -> readFile name >>= interpret options >> return () StandardInputSource -> getContents >>= interpret options >> return ()- UnspecifiedSource -> interact options+ UnspecifiedSource -> runInputT defaultSettings $ interact options prettyprint options expression = print expression >> case compile UnitTag expression@@ -440,9 +474,8 @@ showHelp = putStrLn (usageInfo usageSyntax flagList) -interact options = do Just command <- readline "> "- addHistory command- finish <- interpret options command+interact options = do Just command <- getInputLine "> "+ finish <- lift $ interpret options command when (not finish) (interact options) interpret options command = case parseExpression command@@ -461,12 +494,12 @@ execute :: Flags -> Expression -> IO () execute options (Compiled CommandTag command) = perform $ with $ adjust options command execute options e@(Compiled t@ProducerTag{} p) =- case typecoerce t (ProducerTag CharTag) p+ case typecoerce t (ProducerTag $ TextTag) p of Just producer-> runCoroutine (pipe (produce $ with $ adjust options producer) (consume $ with toStdOut)) >> hFlush stdout- Nothing -> print (TypeError t (ProducerTag CharTag) e)+ Nothing -> print (TypeError t (ProducerTag $ ListTag CharTag) e) execute options (Compiled tag _) = hPutStrLn stderr ("Expecting a command or a Producer Char, received a " ++ show tag) adjust Flags{threadCount= Just threads} component = usingThreads component threads@@ -495,27 +528,30 @@ Compiled tag _ -> TypeError tag (TransducerTag tag2 AnyTag) right Compiled tag _ -> TypeError tag (ProducerTag AnyTag) left e@TypeError{} -> e-compile _ (FileProducer path) = Compiled (ProducerTag CharTag) (fromFile path)-compile _ StdInProducer = Compiled (ProducerTag CharTag) fromStdIn-compile _ (FromList string) = Compiled (ProducerTag CharTag) (atomic "putList" 1 $ Producer $- \sink-> putList string sink >> return ())-compile _ (FileConsumer path) = Compiled (ConsumerTag CharTag) (toFile path)-compile _ (FileAppend path) = Compiled (ConsumerTag CharTag) (appendFile path)-compile inputTag Suppress = Compiled (ConsumerTag inputTag) suppress-compile inputTag (ErrorConsumer message) = Compiled (ConsumerTag inputTag) (erroneous message)+compile _ (FileProducer path) = Compiled (ProducerTag TextTag) (fromFile path)+compile _ StdInProducer = Compiled (ProducerTag TextTag) fromStdIn+compile _ (ProduceFrom string) = Compiled (ProducerTag $ ListTag CharTag) (atomic "putAll" 1 $ Producer $+ \sink-> putAll string sink >> return ())+compile _ (FileConsumer path) = Compiled (ConsumerTag TextTag) (toFile path)+compile _ (FileAppend path) = Compiled (ConsumerTag TextTag) (appendFile path)+compile inputTag Suppress | MonoidClass{} <- constrainMonoid inputTag = Compiled (ConsumerTag inputTag) suppress+compile inputTag (ErrorConsumer message) | MonoidNullClass{} <- constrainMonoidNull inputTag =+ Compiled (ConsumerTag inputTag) (erroneous message) compile inputTag (Sequence e1 e2) = compileJoin sequence inputTag e1 e2 compile inputTag (Join e1 e2) = compileJoin join inputTag e1 e2 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 (If splitter true false) | MonoidClass{} <- constrainMonoid inputTag =+ combineSplitterAndBranches ifs inputTag splitter true false compile UnitTag (NativeCommand command)- = Compiled (ProducerTag CharTag) $+ = Compiled (ProducerTag TextTag) $ atomic command ioCost $ Producer $ \sink-> do (Nothing, Just stdout, Nothing, pid) <- lift (Process.createProcess (Process.shell command){Process.std_out= Process.CreatePipe}) produce (with $ fromHandle stdout) sink lift (hClose stdout)-compile _ (NativeCommand command) = Compiled (TransducerTag CharTag CharTag) (atomic command ioCost $ Transducer f)- where f :: forall a1 a2 d. OpenTransducer IO a1 a2 d Char Char ()+compile _ (NativeCommand command) = + Compiled (TransducerTag (ListTag CharTag) (ListTag CharTag)) (atomic command ioCost $ Transducer f)+ where f :: forall a1 a2 d. OpenTransducer IO a1 a2 d String String () f source sink = do (Just stdin, Just stdout, Nothing, pid) <- lift (Process.createProcess (Process.shell command){Process.std_in= Process.CreatePipe,@@ -524,7 +560,7 @@ >> hSetBuffering stdout NoBuffering) interleave source stdin pid stdout sink interleave :: forall a1 a2 d. (AncestorFunctor a1 d, AncestorFunctor a2 d) =>- Source IO a1 Char -> Handle -> Process.ProcessHandle -> Handle -> Sink IO a2 Char+ Source IO a1 [Char] -> Handle -> Process.ProcessHandle -> Handle -> Sink IO a2 [Char] -> Coroutine d IO () interleave source stdin pid stdout sink = interleave1 where interleave1 = get source@@ -544,77 +580,93 @@ else lift (hGetChar stdout) >>= put sink >> interleaveEnd-compile inputTag (Select e) = case compile inputTag e- of Compiled (SplitterTag tag _) s -> Compiled (TransducerTag tag tag) (select s)- Compiled tag _ -> TypeError tag (SplitterTag inputTag AnyTag) e- e'@TypeError{} -> e'+compile inputTag (Select e) | MonoidClass{} <- constrainMonoid inputTag = + case compile inputTag e+ of Compiled (SplitterTag tag) s -> Compiled (TransducerTag tag tag) (select s)+ Compiled tag _ -> TypeError tag (SplitterTag inputTag) 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)+ | MonoidNullClass{} <- constrainMonoidNull tag1 -> let tag2' = TransducerTag tag1 tag1 in tryComponentCast tag2 tag2' t body (\t'-> Compiled tag2' (while t' s))-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 (FollowedBy left right) = combineFactorialSplitters followedBy inputTag left right+compile inputTag (And left right) = combineSplitters (>&) inputTag left right+compile inputTag (Or left right) = combineSplitters (>|) inputTag left right+compile inputTag (ZipWithAnd left right) = combineFactorialSplitters (Combinators.&&) inputTag left right+compile inputTag (ZipWithOr left right) = combineFactorialSplitters (Combinators.||) inputTag left right+compile inputTag (Nested left right) = combineNullSplitters nestedIn inputTag left right compile inputTag (Having left right) = combineSplittersOfCoercibleTypes having inputTag left right compile inputTag (HavingOnly left right) = combineSplittersOfCoercibleTypes havingOnly inputTag left right-compile inputTag (Between left right) = combineSplittersOfSameType (...) inputTag left right-compile inputTag (Not splitter) = wrapSplitter snot inputTag splitter-compile inputTag (First splitter) = wrapSplitter first inputTag splitter-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 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 (Between left right) = combineFactorialSplitters (...) inputTag left right+compile inputTag (Not splitter) | MonoidClass{} <- constrainMonoid inputTag = wrapSplitter snot inputTag splitter+compile inputTag (First splitter) = wrapMonoidNullSplitter first inputTag splitter+compile inputTag (Last splitter) = wrapMonoidNullSplitter last inputTag splitter+compile inputTag (Prefix splitter) = wrapMonoidNullSplitter prefix inputTag splitter+compile inputTag (Suffix splitter) = wrapMonoidNullSplitter suffix inputTag splitter+compile inputTag (StartOf splitter) = wrapMonoidNullSplitter startOf inputTag splitter+compile inputTag (EndOf splitter) = wrapMonoidNullSplitter endOf inputTag splitter+compile inputTag (Prepend prefix) | MonoidClass{} <- constrainMonoid inputTag =+ wrapProducerIntoTransducer prepend inputTag prefix+compile inputTag (Append suffix) | MonoidClass{} <- constrainMonoid inputTag =+ wrapProducerIntoTransducer append inputTag suffix+compile inputTag (Substitute replacement) | MonoidClass{} <- constrainMonoid inputTag =+ wrapGenericProducerIntoTransducer substitute inputTag replacement compile _ ExecuteTransducer- = Compiled (TransducerTag CharTag CharTag) (atomic "execute" ioCost $ Transducer execute)- where execute :: forall a1 a2 d. OpenTransducer IO a1 a2 d Char Char ()- execute source sink = do let (source' :: Source IO d Char) = liftSource source- ((), command) <- pipe (pour source') getList+ = Compiled (TransducerTag (ListTag CharTag) TextTag) (atomic "execute" ioCost $ Transducer execute)+ where execute :: forall a1 a2 d. OpenTransducer IO a1 a2 d String Text ()+ execute source sink = do let (source' :: Source IO d String) = liftSource source+ ((), command) <- pipe (pour_ source') getAll (Nothing, Just stdout, Nothing, pid) <- lift (Process.createProcess (Process.shell command){Process.std_out= Process.CreatePipe}) produce (with $ fromHandle stdout) sink lift (hClose stdout) -compile inputTag IdentityTransducer = Compiled (TransducerTag inputTag inputTag) id-compile inputTag Count = Compiled (TransducerTag inputTag IntTag) count-compile inputTag@(ListTag itemTag) Concatenate = Compiled (TransducerTag inputTag itemTag) concatenate+compile inputTag IdentityTransducer | MonoidClass{} <- constrainMonoid inputTag =+ Compiled (TransducerTag inputTag inputTag) id+compile inputTag Count | FactorialMonoidClass{} <- constrainFactorialMonoid inputTag =+ Compiled (TransducerTag inputTag (ListTag IntTag)) count+compile inputTag@(ListTag itemTag) Concatenate+ | MonoidClass{} <- constrainMonoid itemTag = 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 t2) unparse-compile inputTag Unparse- = TypeError (TransducerTag (MarkupTag AnyTag AnyTag) AnyTag) (TransducerTag inputTag AnyTag) Unparse-compile _ Uppercase = Compiled (TransducerTag CharTag CharTag) uppercase-compile inputTag ShowTransducer - | ShowClass{} <- constrainShow inputTag = Compiled (TransducerTag inputTag (ListTag CharTag)) toString-compile inputTag ShowTransducer- = TypeError (TransducerTag IntTag (ListTag CharTag)) (TransducerTag inputTag AnyTag) ShowTransducer-compile inputTag EverythingSplitter = Compiled (SplitterTag inputTag UnitTag) everything-compile inputTag NothingSplitter = Compiled (SplitterTag inputTag UnitTag) nothing-compile _ WhitespaceSplitter = Compiled (SplitterTag CharTag UnitTag) whitespace-compile _ LineSplitter = Compiled (SplitterTag CharTag UnitTag) line-compile _ LetterSplitter = Compiled (SplitterTag CharTag UnitTag) letters-compile _ DigitSplitter = Compiled (SplitterTag CharTag UnitTag) digits-compile inputTag@(MarkupTag tag _) MarkedSplitter - | EqClass{} <- constrainEq tag = Compiled (SplitterTag inputTag UnitTag) marked-compile _ MarkedSplitter = Compiled (SplitterTag (MarkupTag AnyTag AnyTag) UnitTag) marked-compile inputTag OneSplitter = Compiled (SplitterTag inputTag UnitTag) one-compile _ (SubstringSplitter part) = Compiled (SplitterTag CharTag UnitTag) (substring part)-compile _ XMLTokenParser = Compiled (TransducerTag CharTag (MarkupTag XMLTokenTag TextTag)) xmlParseTokens-compile _ XMLElement = Compiled (SplitterTag (MarkupTag XMLTokenTag TextTag) UnitTag) xmlElement-compile _ XMLAttribute = Compiled (SplitterTag (MarkupTag XMLTokenTag TextTag) UnitTag) xmlAttribute-compile _ XMLAttributeName = Compiled (SplitterTag (MarkupTag XMLTokenTag TextTag) UnitTag) xmlAttributeName-compile _ XMLAttributeValue = Compiled (SplitterTag (MarkupTag XMLTokenTag TextTag) UnitTag) xmlAttributeValue-compile _ XMLElementContent = Compiled (SplitterTag (MarkupTag XMLTokenTag TextTag) UnitTag) xmlElementContent-compile _ XMLElementName = Compiled (SplitterTag (MarkupTag XMLTokenTag TextTag) UnitTag) xmlElementName-compile _ (XMLElementHavingTag s) = wrapConcreteSplitter xmlElementHavingTagWith (MarkupTag XMLTokenTag TextTag) s+compile inputTag Group | MonoidClass{} <- constrainMonoid inputTag =+ Compiled (TransducerTag inputTag (ListTag inputTag)) group+compile t@(ListTag (MarkupTag t1 t2)) Unparse + | MonoidClass{} <- constrainMonoid t2 = Compiled (TransducerTag t t2) unparse+compile inputTag Unparse | MonoidClass{} <- constrainMonoid inputTag = + TypeError (TransducerTag (ListTag $ MarkupTag AnyTag AnyTag) AnyTag) (TransducerTag inputTag AnyTag) Unparse+compile _ Uppercase = Compiled (TransducerTag (ListTag CharTag) (ListTag CharTag)) uppercase+compile inputTag@(ListTag itemTag) ShowTransducer | ShowClass{} <- constrainShow itemTag = + Compiled (TransducerTag inputTag (ListTag $ ListTag CharTag)) toString+compile inputTag ShowTransducer | MonoidClass{} <- constrainMonoid inputTag =+ TypeError (TransducerTag (ListTag IntTag) (ListTag $ ListTag CharTag)) (TransducerTag inputTag AnyTag) ShowTransducer+compile inputTag EverythingSplitter | MonoidClass{} <- constrainMonoid inputTag =+ Compiled (SplitterTag inputTag) everything+compile inputTag NothingSplitter | MonoidClass{} <- constrainMonoid inputTag =+ Compiled (SplitterTag inputTag) nothing+compile _ WhitespaceSplitter = Compiled (SplitterTag (ListTag CharTag)) whitespace+compile _ LineSplitter = Compiled (SplitterTag (ListTag CharTag)) line+compile _ LetterSplitter = Compiled (SplitterTag (ListTag CharTag)) letters+compile _ DigitSplitter = Compiled (SplitterTag (ListTag CharTag)) digits+compile inputTag@(ListTag (MarkupTag tag _)) MarkedSplitter+ | EqClass{} <- constrainEq tag = Compiled (SplitterTag inputTag) marked+compile _ MarkedSplitter = Compiled (SplitterTag (ListTag $ MarkupTag AnyTag AnyTag)) marked+compile inputTag OneSplitter | FactorialMonoidClass{} <- constrainFactorialMonoid inputTag =+ Compiled (SplitterTag inputTag) one+-- compile inputTag (SubstringSplitter part) | FactorialMonoidClass{} <- constrainFactorialMonoid inputTag =+-- Compiled (SplitterTag inputTag) (substring part)+compile _ (SubstringSplitter part) = Compiled (SplitterTag (ListTag CharTag)) (substring part)+compile _ XMLTokenParser = Compiled (TransducerTag TextTag (ListTag $ MarkupTag XMLTokenTag TextTag)) xmlParseTokens+compile _ XMLElement = Compiled (SplitterTag (ListTag $ MarkupTag XMLTokenTag TextTag)) xmlElement+compile _ XMLAttribute = Compiled (SplitterTag (ListTag $ MarkupTag XMLTokenTag TextTag)) xmlAttribute+compile _ XMLAttributeName = Compiled (SplitterTag (ListTag $ MarkupTag XMLTokenTag TextTag)) xmlAttributeName+compile _ XMLAttributeValue = Compiled (SplitterTag (ListTag $ MarkupTag XMLTokenTag TextTag)) xmlAttributeValue+compile _ XMLElementContent = Compiled (SplitterTag (ListTag $ MarkupTag XMLTokenTag TextTag)) xmlElementContent+compile _ XMLElementName = Compiled (SplitterTag (ListTag $ MarkupTag XMLTokenTag TextTag)) xmlElementName+compile _ (XMLElementHavingTag s) = + wrapConcreteSplitter xmlElementHavingTagWith (ListTag $ MarkupTag XMLTokenTag TextTag) s compile inputTag expression = error ("Cannot compile " ++ show expression ++ " with input " ++ show inputTag) @@ -658,47 +710,48 @@ (Compiled tag@SplitterTag{} _, _) -> TypeError tag (ProducerTag AnyTag) e1 (_, Compiled tag@SplitterTag{} _) -> TypeError tag (ProducerTag AnyTag) e2 -wrapSplitter :: forall x. - (forall x b. SplitterComponent IO x b -> SplitterComponent IO x b) ->+wrapSplitter :: forall x. Monoid x =>+ (forall x. Monoid x => SplitterComponent IO x -> SplitterComponent IO x) -> 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+ of Compiled tag@(SplitterTag tx) splitter -> Compiled (SplitterTag tx) (combinator splitter)+ Compiled tag _ -> TypeError tag (SplitterTag inputTag) expression e@TypeError{} -> e -wrapConcreteSplitter :: forall x.- (forall b. SplitterComponent IO x b -> SplitterComponent IO x b) ->+wrapMonoidNullSplitter :: forall x.+ (forall x. MonoidNull x => SplitterComponent IO x -> SplitterComponent IO x) ->+ TypeTag x -> Expression -> Expression+wrapMonoidNullSplitter combinator inputTag expression+ = case compile inputTag expression+ of Compiled tag@(SplitterTag tx) splitter | MonoidNullClass{} <- constrainMonoidNull tx ->+ Compiled (SplitterTag tx) (combinator splitter)+ Compiled tag _ | MonoidClass{} <- constrainMonoid inputTag -> TypeError tag (SplitterTag inputTag) expression+ e@TypeError{} -> e++wrapConcreteSplitter :: forall x. Monoid x =>+ (SplitterComponent IO x -> SplitterComponent IO x) -> TypeTag x -> Expression -> Expression wrapConcreteSplitter combinator inputTag expression = case compile inputTag expression- of Compiled tag@(SplitterTag tx tb) splitter ->- tryComponentCast tag (SplitterTag inputTag tb) splitter expression $- \s'-> Compiled (SplitterTag inputTag tb) (combinator s')- Compiled tag _ -> TypeError tag (SplitterTag inputTag AnyTag) expression+ of Compiled tag@(SplitterTag tx) splitter ->+ tryComponentCast tag (SplitterTag inputTag) splitter expression $+ \s'-> Compiled (SplitterTag inputTag) (combinator s')+ Compiled tag _ -> TypeError tag (SplitterTag inputTag) expression e@TypeError{} -> e -wrapConcreteSplitter' :: forall x y.- (forall b. SplitterComponent IO x b -> SplitterComponent IO y ()) ->+wrapConcreteSplitter' :: forall x y. (Monoid x, Monoid y) =>+ (SplitterComponent IO x -> SplitterComponent IO y) -> TypeTag x -> TypeTag y -> Expression -> Expression wrapConcreteSplitter' combinator inputTag outputTag expression = case compile inputTag expression- of Compiled tag@(SplitterTag tx tb) splitter ->- tryComponentCast 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.- (forall x b. SplitterComponent IO x b -> SplitterComponent IO x (c b)) ->- TypeTag x -> (forall 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+ of Compiled tag@(SplitterTag tx) splitter ->+ tryComponentCast tag (SplitterTag inputTag) splitter expression $+ \s'-> Compiled (SplitterTag outputTag) (combinator s')+ Compiled tag _ -> TypeError tag (SplitterTag inputTag) expression e@TypeError{} -> e -wrapProducerIntoTransducer :: forall x.+wrapProducerIntoTransducer :: forall x. Monoid x => (ProducerComponent IO x () -> TransducerComponent IO x x) -> TypeTag x -> Expression -> Expression wrapProducerIntoTransducer combinator inputTag expression = case compile inputTag expression@@ -708,8 +761,8 @@ Compiled tag _ -> TypeError tag (ProducerTag inputTag) expression e@TypeError{} -> e -wrapGenericProducerIntoTransducer :: forall x.- (forall y r. ProducerComponent IO y r -> TransducerComponent IO x y)+wrapGenericProducerIntoTransducer :: forall x. Monoid x =>+ (forall y r. Monoid y => ProducerComponent IO y r -> TransducerComponent IO x y) -> TypeTag x -> Expression -> Expression wrapGenericProducerIntoTransducer combinator inputTag expression = case compile inputTag expression@@ -717,135 +770,131 @@ Compiled tag _ -> TypeError tag (ProducerTag inputTag) expression e@TypeError{} -> e -combineSplitters :: forall x c.- (forall x b1 b2. SplitterComponent IO x b1 -> SplitterComponent IO x b2 -> SplitterComponent IO x (c b1 b2))- -> TypeTag x -> (forall b1 b2. TypeTag b1 -> TypeTag b2 -> TypeTag (c b1 b2))- -> Expression -> Expression -> Expression-combineSplitters combinator inputTag constructor left right+combineSplitters :: forall x.+ (forall x. Monoid x => SplitterComponent IO x -> SplitterComponent IO x -> SplitterComponent IO x)+ -> TypeTag x -> Expression -> Expression -> Expression+combineSplitters combinator inputTag left right = case (compile inputTag left, compile inputTag right)- of (Compiled tag1@(SplitterTag x1 b1) s1, Compiled tag2@(SplitterTag x2 b2) s2)- -> tryComponentCast tag2 (SplitterTag x1 b2) s2 right $- \s2'-> Compiled (SplitterTag x1 (constructor b1 b2)) (combinator s1 s2')+ of (Compiled tag1@(SplitterTag x1) s1, Compiled tag2@(SplitterTag x2) s2)+ -> tryComponentCast tag2 (SplitterTag x1) s2 right $+ \s2'-> Compiled (SplitterTag x1) (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.- (forall x b. SplitterComponent IO x b -> SplitterComponent IO x b -> SplitterComponent IO x b)- -> TypeTag x -> Expression -> Expression -> Expression-combineSplittersOfSameType combinator inputTag left right+combineFactorialSplitters :: forall x c.+ (forall x. FactorialMonoid x => + SplitterComponent IO x -> SplitterComponent IO x -> SplitterComponent IO x)+ -> TypeTag x+ -> Expression -> Expression -> Expression+combineFactorialSplitters combinator inputTag left right = case (compile inputTag left, compile inputTag right)- of (Compiled tag1@SplitterTag{} s1, Compiled tag2@SplitterTag{} s2)- -> tryComponentCast tag2 tag1 s2 right (\s2'-> Compiled tag1 (combinator s1 s2'))+ of (Compiled tag1@(SplitterTag x1) s1, Compiled tag2@(SplitterTag x2) s2)+ | FactorialMonoidClass{} <- constrainFactorialMonoid x1+ -> tryComponentCast tag2 (SplitterTag x1) s2 right $+ \s2'-> Compiled (SplitterTag x1) (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 -combineSplittersOfCoercibleTypes :: - forall x. (forall x y b1 b2. Coercions.Coercible x y =>- SplitterComponent IO x b1 -> SplitterComponent IO y b2 -> SplitterComponent IO x b1)- -> TypeTag x -> Expression -> Expression -> Expression-combineSplittersOfCoercibleTypes combinator inputTag left right+combineNullSplitters :: forall x c.+ (forall x. MonoidNull x => + SplitterComponent IO x -> SplitterComponent IO x -> SplitterComponent IO x)+ -> TypeTag x+ -> Expression -> Expression -> Expression+combineNullSplitters combinator inputTag left right = case (compile inputTag left, compile inputTag right)- of (Compiled ts1@(SplitterTag tag1 tag1b) s1, Compiled ts2@(SplitterTag tag2 _) s2)- -> case relateTags tag1 tag2- of IdentityRelation tag'-> Compiled (SplitterTag tag' tag1b) (combinator s1 s2)- CoercibleRelation tag1' tag2'-> Compiled (SplitterTag tag1' tag1b) (combinator s1 s2)- NoRelation -> TypeError ts2 ts1 right- (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.- (forall b1 b2. SplitterComponent IO x1 b1 -> SplitterComponent IO x2 b2 -> SplitterComponent 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)- -> tryComponentCast tag1' (SplitterTag tag1 b1) s1 left $- \s1'-> tryComponentCast tag2' (SplitterTag tag2 b2) s2 right $- \s2'-> Compiled (SplitterTag tag1 b1) (combinator s1' s2')+ of (Compiled tag1@(SplitterTag x1) s1, Compiled tag2@(SplitterTag x2) s2)+ | MonoidNullClass{} <- constrainMonoidNull x1+ -> tryComponentCast tag2 (SplitterTag x1) s2 right $+ \s2'-> Compiled (SplitterTag x1) (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 -combineXMLTextSplitters :: forall x1.- (forall b1 b2.- SplitterComponent IO x1 b1 -> SplitterComponent IO Text b2 -> SplitterComponent IO x1 b1)- -> TypeTag x1 -> Expression -> Expression -> Expression-combineXMLTextSplitters combinator tag left right- = case (compile tag left, compile CharTag right)- of (Compiled tag1'@(SplitterTag _ b1) s1, Compiled tag2'@(SplitterTag tag' b2) s2)- -> tryComponentCast tag1' (SplitterTag tag b1) s1 left $- \s1'-> tryComponentCast tag2' (SplitterTag TextTag b2) s2 right $- \s2'-> Compiled (SplitterTag tag b1) (combinator s1' s2')+combineSplittersOfCoercibleTypes :: + forall x. (forall x y. (MonoidNull x, MonoidNull y, Coercions.Coercible x y) =>+ SplitterComponent IO x -> SplitterComponent IO y -> SplitterComponent IO x)+ -> TypeTag x -> Expression -> Expression -> Expression+combineSplittersOfCoercibleTypes combinator inputTag left right+ = case (compile inputTag left, compile inputTag right)+ of (Compiled ts1@(SplitterTag tag1) s1, Compiled ts2@(SplitterTag tag2) s2)+ | MonoidNullClass{} <- constrainMonoidNull tag1, MonoidNullClass{} <- constrainMonoidNull tag2+ -> case relateTags tag1 tag2+ of IdentityRelation tag'-> Compiled (SplitterTag tag') (combinator s1 s2)+ CoercibleRelation tag1' tag2'-> Compiled (SplitterTag tag1') (combinator s1 s2)+ NoRelation -> TypeError ts2 ts1 right (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.- (forall x y. TransducerComponent IO x y -> TransducerComponent IO x y -> TransducerComponent IO x y)- -> TypeTag x -> Expression -> Expression -> Expression-combineTransducersOfSameType combinator inputTag left right- = case (compile inputTag left, compile inputTag right)- of (Compiled tag1@TransducerTag{} t1, Compiled tag2@TransducerTag{} t2)- -> tryComponentCast tag2 tag1 t2 right (\t2'-> Compiled tag1 (combinator t1 t2'))- combineSplitterAndBranches :: forall x.- (forall x b cc. Branching cc IO x () => SplitterComponent IO x b -> Component cc -> Component cc -> Component cc)- -> TypeTag x -> Expression -> Expression -> Expression -> Expression+ (forall x b cc. (MonoidNull x, Branching cc IO x ()) => + SplitterComponent IO x -> Component cc -> Component cc -> Component cc)+ -> TypeTag x -> Expression -> Expression -> Expression -> Expression combineSplitterAndBranches combinator inputTag splitter true false = case (compile inputTag splitter, compile inputTag true, compile inputTag false)- 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)+ | MonoidNullClass{} <- constrainMonoidNull tag1 -> tryComponentCast tag2 (ConsumerTag tag1) t true $ \t'-> tryComponentCast tag3 (ConsumerTag tag1) f false $ \f'-> Compiled (ConsumerTag tag1) (combinator s t' f')- (Compiled tag1@SplitterTag{} s, Compiled tag2@SplitterTag{} t, Compiled tag3@SplitterTag{} f)+ (Compiled tag1@(SplitterTag tag1i) s, Compiled tag2@SplitterTag{} t, Compiled tag3@SplitterTag{} f)+ | MonoidNullClass{} <- constrainMonoidNull tag1i -> tryComponentCast tag2 tag1 t true $ \t'-> tryComponentCast 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)+ | MonoidNullClass{} <- constrainMonoidNull tag1 -> let tag2' = TransducerTag tag1 tag2b in tryComponentCast tag2 tag2' t true $ \t'-> tryComponentCast 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)+ | MonoidNullClass{} <- constrainMonoidNull tag1 -> let tag2' = TransducerTag tag1 tag2b in tryComponentCast tag2 tag2' t true $ \t'-> tryComponentCast 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)+ | MonoidNullClass{} <- constrainMonoidNull tag1 -> let tag3' = TransducerTag tag1 tag3b in tryComponentCast tag2 (ConsumerTag tag1) t true $ \t'-> tryComponentCast 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)+ (Compiled (SplitterTag tag1) s, Compiled tag2@(TransducerTag tag2a tag2b) t, Compiled tag3@ProducerTag{} f)+ | MonoidNullClass{} <- constrainMonoidNull tag1 -> let tag2' = TransducerTag tag1 tag2b in tryComponentCast tag2 tag2' t true $ \t'-> tryComponentCast 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)+ (Compiled (SplitterTag tag1) s, Compiled tag2@ProducerTag{} t, Compiled tag3@(TransducerTag tag3a tag3b) f)+ | MonoidNullClass{} <- constrainMonoidNull tag1 -> let tag3' = TransducerTag tag1 tag3b in tryComponentCast tag2 (ProducerTag tag3b) t true $ \t'-> tryComponentCast 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)+ (Compiled (SplitterTag tag1) s, Compiled tag2@(ConsumerTag tag2a) t, Compiled tag3@(ProducerTag tag3a) f)+ | MonoidNullClass{} <- constrainMonoidNull tag1 -> tryComponentCast 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)+ (Compiled (SplitterTag tag1) s, Compiled tag2@(ProducerTag tag2a) t, Compiled tag3@(ConsumerTag tag3a) f)+ | MonoidNullClass{} <- constrainMonoidNull tag1 -> tryComponentCast 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 AnyTag) splitter+ (Compiled SplitterTag{} _, Compiled tag _, _)+ | MonoidClass{} <- constrainMonoid inputTag -> TypeError tag (TransducerTag inputTag AnyTag) true+ (Compiled SplitterTag{} _, _, Compiled tag _)+ | MonoidClass{} <- constrainMonoid inputTag -> TypeError tag (TransducerTag inputTag AnyTag) false+ (Compiled tag _, _, _) + | MonoidClass{} <- constrainMonoid inputTag -> TypeError tag (SplitterTag inputTag) splitter parseExpression :: String -> Either Int (Expression, [Char], Int) parseExpression s = case Parsec.parse partialExpressionParser "" s of@@ -945,7 +994,7 @@ <|> try (nativeSourceParser "ls") <|> try (do symbol lexer "echo" string <- nativeCommand True- return (FromList string))+ return (ProduceFrom string)) <|> try (symbol lexer "stdin" >> return StdInProducer) <|> try (do symbol lexer ">>" file <- parameterParser True
Test/TestSCC.hs view
@@ -1,5 +1,5 @@ {- - Copyright 2008-2010 Mario Blazevic+ Copyright 2008-2012 Mario Blazevic This file is part of the Streaming Component Combinators (SCC) project. @@ -18,14 +18,8 @@ module Main where -import Control.Concurrent.Configuration-import Control.Monad.Coroutine-import Control.Concurrent.SCC.Streams-import Control.Concurrent.SCC.Types-import qualified Control.Concurrent.SCC.Combinators as Combinator-import Control.Concurrent.SCC.Configurable hiding ((&&), (||))-import qualified Control.Concurrent.SCC.XML as XML-import qualified Control.Concurrent.SCC.Configurable as C+import Prelude hiding (even, id, last)+import qualified Prelude import Control.Monad (liftM, when) import Data.Char (ord, isLetter, isSpace, toUpper)@@ -34,19 +28,29 @@ import Data.List (find, findIndices, groupBy, intersect, union, intercalate, isInfixOf, isPrefixOf, isSuffixOf, nub, sort, tails) import Data.Maybe (fromJust, isJust, mapMaybe)+import Data.Monoid (Monoid)+import Data.Monoid.Null (MonoidNull) import qualified Data.List as List import qualified Data.Foldable as Foldable import qualified Data.Sequence as Seq import Data.Sequence (Seq, (|>), (><), ViewL (EmptyL, (:<)))-import Debug.Trace (trace)-import Prelude hiding (even, id, last)-import qualified Prelude+import Data.String (IsString(fromString))+ import Test.QuickCheck (Arbitrary, Gen, Property, CoArbitrary, Positive(Positive), NonNegative(NonNegative), NonEmptyList(NonEmpty), arbitrary, coarbitrary, label, classify, choose, mapSize, oneof, resize, sized, quickCheck, variant, (==>)) +import Control.Concurrent.Configuration+import Control.Monad.Coroutine+import Control.Concurrent.SCC.Streams+import Control.Concurrent.SCC.Types+import qualified Control.Concurrent.SCC.Combinators as Combinator+import Control.Concurrent.SCC.Configurable hiding ((&&), (||))+import qualified Control.Concurrent.SCC.XML as XML+import qualified Control.Concurrent.SCC.Configurable as C + sublists [] _ = [] sublists _ [] = [] sublists sublist input = map@@ -62,7 +66,7 @@ main = mapM_ quickCheck tests -tests = [label "pipe" $ \(input :: [Int])-> runCoroutine (pipe (putList input) getList) == Just ([], input),+tests = [label "pipe" $ \(input :: [Int])-> runCoroutine (pipe (putAll input) getAll) == Just ([], input), label "pour" prop_pour, label "id" prop_id, label "suppress" prop_suppress,@@ -76,25 +80,25 @@ label "concatenate" prop_concatenate, label "concatSeparate" prop_concatSeparate, label "uppercase ->>" $ \s-> runCoroutine (pipe- (putList s)+ (putAll s) (consume $ with $- uppercase >-> atomic "getList" 1 (Consumer getList)))+ uppercase >-> atomic "getAll" 1 (Consumer getAll))) == Just ([], map toUpper s), label "uppercase <<-" $ \s-> runCoroutine (pipe (produce $ with $- atomic "putList" 1 (Producer (putList s)) >-> uppercase)- getList)+ atomic "putAll" 1 (Producer (putAll s)) >-> uppercase)+ getAll) == Just ([], map toUpper s), label "uppercase `join` id" $ \s-> transducerOutput (uppercase `join` id) s == map toUpper s ++ s, label "prepend >-> append" (\(s :: String) prefix suffix->- transducerOutput (prepend (fromList prefix) >-> append (fromList suffix)) s+ transducerOutput (prepend (produceFrom prefix) >-> append (produceFrom suffix)) s == prefix ++ s ++ suffix), label "prepend == (`join` id) . substitute" $- \(s :: String) prefix-> transducerOutput (prepend (fromList prefix)) s- == transducerOutput (substitute (fromList prefix) `join` id) s,+ \(s :: String) prefix-> transducerOutput (prepend (produceFrom prefix)) s+ == transducerOutput (substitute (produceFrom prefix) `join` id) s, label "append == (id `join`) . substitute" $- \(s :: String) suffix-> transducerOutput (append (fromList suffix)) s- == transducerOutput (id `join` substitute (fromList suffix)) s,+ \(s :: String) suffix-> transducerOutput (append (produceFrom suffix)) s+ == transducerOutput (id `join` substitute (produceFrom suffix)) s, label "whitespace" $ \s-> splitterOutputs whitespace s == (filter isSpace s, filter (not . isSpace) s), label "ifs everything id id" $ \(s :: [TestEnum])-> transducerOutput (ifs everything id id) s == s, label "substring" $ \s (c :: TestEnum)-> splitterOutputs (substring [c]) s == (filter (==c) s, filter (/=c) s),@@ -119,7 +123,7 @@ label "count >-> toString >-> concatenate" $ \(s :: [TestEnum])-> transducerOutput (count >-> toString >-> concatenate) s == show (length s), label "foreach whitespace id (prepend \"[\" >-> append \"]\")" $- \s-> transducerOutput (foreach whitespace id (prepend (fromList "[") >-> append (fromList "]"))) s+ \s-> transducerOutput (foreach whitespace id (prepend (produceFrom "[") >-> append (produceFrom "]"))) s == mapWords (("[" ++) . (++ "]")) s, label "foreach whitespace id (count >-> toString >-> concatenate)" $ \s-> transducerOutput (foreach whitespace id (count >-> toString >-> concatenate)) s@@ -188,7 +192,7 @@ label "uptoFirst" $ prop_uptoFirst . splitterFromTrace, label "lastAndAfter" $ prop_lastAndAfter . splitterFromTrace, label "followedBy prefix" $- \trace1 trace2 n-> prop_followedBy1 (splitterFromTrace trace1) (splitterFromTrace trace2) n,+ \trace1 trace2 n-> prop_followedBy1 (splitterFromTrace trace1) (simplestSplitterFromTrace 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,@@ -208,26 +212,26 @@ prop_pour :: [Int] -> Bool-prop_pour input = runCoroutine (pipe (putList input) (\source-> pipe (\sink-> pour source sink) getList))+prop_pour input = runCoroutine (pipe (putAll input) (\source-> pipe (\sink-> pour_ source sink) getAll)) == Just ([], ((), input)) prop_id :: [Int] -> Bool prop_id input = transducerOutput id input == input prop_suppress :: [Int] -> Bool-prop_suppress input = null (transducerOutput (consumeBy suppress :: TransducerComponent Identity Int ()) input)+prop_suppress input = null (transducerOutput (consumeBy suppress :: TransducerComponent Identity [Int] [()]) input) prop_substitute :: [Int] -> [Maybe Int] -> Bool-prop_substitute input replacement = transducerOutput (substitute $ fromList replacement) input == replacement+prop_substitute input replacement = transducerOutput (substitute $ produceFrom replacement) input == replacement prop_prepend :: [Int] -> [Int] -> Int -> Property prop_prepend input prefix threads = threads > 0 ==>- transducerOutput (usingThreads (prepend $ fromList prefix) threads) input+ transducerOutput (usingThreads (prepend $ produceFrom prefix) threads) input == prefix ++ input prop_append :: [Int] -> [Int] -> Int -> Property prop_append input suffix threads = threads > 0 ==>- transducerOutput (usingThreads (append $ fromList suffix) threads) input+ transducerOutput (usingThreads (append $ produceFrom suffix) threads) input == input ++ suffix prop_allTrue :: [Int] -> Bool@@ -245,9 +249,10 @@ && not (sublist `isInfixOf` (tail sublist ++ init sublist)) ==> classify (not (sublist `isInfixOf` input)) "trivial" (transducerOutput (parseRegions (substring sublist)) input- == map unitFromOccurrence (transducerOutput (parseSubstring sublist) input))- where unitFromOccurrence (Content x) = Content x- unitFromOccurrence (Markup b) = Markup (fmap (const ()) b)+ == concatMap unitFromOccurrence (transducerOutput (parseSubstring sublist) input))+ where unitFromOccurrence (Content []) = []+ unitFromOccurrence (Content x) = [Content x]+ unitFromOccurrence (Markup b) = [Markup (fmap (const ()) b)] prop_group :: [Int] -> Bool prop_group input = transducerOutput group input == [input]@@ -258,7 +263,7 @@ prop_concatSeparate :: [[TestEnum]] -> [TestEnum] -> Bool prop_concatSeparate input separator = transducerOutput (concatSeparate separator) input == intercalate separator input -prop_snot :: SplitterComponent Identity Int () -> [Int] -> Bool+prop_snot :: SplitterComponent 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@@ -279,53 +284,53 @@ s2 = splitterFromTrace st2 s3 = splitterFromTrace st3 -prop_DeMorgan1 :: SplitterComponent Identity Int () -> SplitterComponent Identity Int () -> [Int]+prop_DeMorgan1 :: SplitterComponent Identity [Int] -> SplitterComponent Identity [Int] -> [Int] -> Positive Int -> Positive Int -> Bool prop_DeMorgan1 s1 s2 input (Positive t1) (Positive t2) = splitterOutputs (usingThreads (snot (s1 C.&& s2)) (t1 `mod` 50)) input == splitterOutputs (usingThreads (snot s1 C.|| snot s2) (t2 `mod` 50)) input -prop_DeMorgan2 :: SplitterComponent Identity Int () -> SplitterComponent Identity Int () -> [Int]+prop_DeMorgan2 :: SplitterComponent Identity [Int] -> SplitterComponent Identity [Int] -> [Int] -> Positive Int -> Positive Int -> Bool prop_DeMorgan2 s1 s2 input (Positive t1) (Positive t2) = splitterOutputs (usingThreads (snot (s1 C.|| s2)) (t1 `mod` 50)) input == splitterOutputs (usingThreads (snot s1 C.&& snot s2) (t2 `mod` 50)) input -prop_and :: SplitterComponent Identity Int () -> SplitterComponent Identity Int () -> Positive Int -> Bool+prop_and :: SplitterComponent Identity [Int] -> SplitterComponent Identity [Int] -> Positive Int -> Bool prop_and s1 s2 (Positive n) = fst (splitterOutputs (s1 C.&& s2) l) == fst (splitterOutputs s1 l) `intersect` fst (splitterOutputs s2 l) where l = [1 .. n `mod` 1000] -prop_or :: SplitterComponent Identity Int () -> SplitterComponent Identity Int () -> Positive Int -> Bool+prop_or :: SplitterComponent Identity [Int] -> SplitterComponent Identity [Int] -> Positive Int -> Bool prop_or s1 s2 (Positive n) = fst (splitterOutputs (s1 C.|| s2) l) == sort (fst (splitterOutputs s1 l) `union` fst (splitterOutputs s2 l)) where l = [1 .. n `mod` 1000] -prop_even :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool+prop_even :: SplitterComponent 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 :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool+prop_prefix_1 :: SplitterComponent 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 :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool+prop_prefix_2 :: SplitterComponent 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 :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool+prop_suffix_1 :: SplitterComponent 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 :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool+prop_suffix_2 :: SplitterComponent 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@@ -334,7 +339,7 @@ && rest1 == concat (map fst (reverse rest2)) ++ suffix2 [] -> rest1 ++ suffix1 == [] -prop_first :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool+prop_first :: SplitterComponent 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)@@ -343,7 +348,7 @@ (prefix, False):[] -> first1 == [] && rest1 == prefix [] -> first1 ++ rest1 == [] -prop_last :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool+prop_last :: SplitterComponent 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)@@ -353,7 +358,7 @@ (suffix, False):[] -> last1 == [] && rest1 == suffix [] -> last1 ++ rest1 == [] -prop_uptoFirst :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool+prop_uptoFirst :: SplitterComponent 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)@@ -362,7 +367,7 @@ (prefix, False):[] -> first1 == [] && rest1 == prefix [] -> first1 ++ rest1 == [] -prop_lastAndAfter :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool+prop_lastAndAfter :: SplitterComponent 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))@@ -371,12 +376,12 @@ (suffix, False):[] -> last1 == [] && rest1 == suffix [] -> last1 ++ rest1 == [] -prop_followedBy1 :: SplitterComponent Identity Int () -> SplitterComponent Identity Int () -> Positive Int -> Bool+prop_followedBy1 :: SplitterComponent Identity [Int] -> SplitterComponent Identity [Int] -> Positive Int -> Bool prop_followedBy1 s1 s2 (Positive n) = splitterOutputs (s1 `followedBy` s2) l == splitterOutputs (s1 `followedBy` prefix s2) l where l = [1 .. n `mod` 300] -prop_followedBy2 :: SplitterComponent Identity Int () -> Int -> Bool+prop_followedBy2 :: SplitterComponent Identity [Int] -> Int -> Bool prop_followedBy2 s n = splitterOutputs (s `followedBy` startOf everything) l == splitterOutputs s l where l = [1 .. n `mod` 300] @@ -399,7 +404,7 @@ in splitterOutputs (substring [n1 .. n2] `followedBy` substring [n2 + 1 .. n3]) [0 .. n4] == ([n1 .. n3], [0 .. n1 - 1] ++ [n3 + 1 .. n4]) -prop_followedBy6 :: SplitterComponent Identity Int () -> SplitterComponent Identity Int () -> Positive Int -> Bool+prop_followedBy6 :: SplitterComponent Identity [Int] -> SplitterComponent Identity [Int] -> Positive Int -> Bool prop_followedBy6 s1 s2 (Positive n) = sort (fst (splitterOutputs (endOf s1 `followedBy` s2) l) `union` fst (splitterOutputs (s1 `followedBy` startOf s2) l)) == fst (splitterOutputs (s1 `followedBy` s2) l)@@ -416,13 +421,13 @@ [0 .. n4] == ([n1 .. n3], [0 .. n1 - 1] ++ [n3 + 1 .. n4]) -prop_between1 :: SplitterComponent Identity Int () -> Positive Int -> Bool+prop_between1 :: SplitterComponent Identity [Int] -> Positive Int -> Bool prop_between1 splitter (Positive n) = splitterOutputs (startOf splitter ... endOf splitter) input == splitterOutputs splitter input && splitterOutputs (endOf splitter ... startOf splitter) input == ([], input) where input = [1 .. n `mod` 500] -prop_between2 :: SplitterComponent Identity Int () -> Positive Int -> Bool+prop_between2 :: SplitterComponent Identity [Int] -> Positive Int -> Bool prop_between2 splitter (Positive n) = splitterOutputs (startOf everything ... endOf splitter) input == splitterOutputs (uptoFirst splitter) input || null (fst $ splitterOutputs splitter input)@@ -430,15 +435,16 @@ prop_XMLtokens1 :: [LowercaseLetter] -> String -> Property prop_XMLtokens1 name content = name /= [] && intersect content "<&" == []- ==> splitterOutputs xmlTokens (start ++ content ++ end) == (start ++ end, content)+ ==> splitterOutputs xmlTokens (fromString $ start ++ content ++ end)+ == (fromString $ start ++ end, fromString content) where name' = map letterChar name start = "<" ++ name' ++ ">" end = "</" ++ name' ++ ">" prop_XMLtokens2 :: [LowercaseLetter] -> [(Identifier, String)] -> String -> Property prop_XMLtokens2 name attrs content = name /= [] && all validAttribute attrs && intersect content "<&" == []- ==> splitterOutputs xmlTokens (start ++ content ++ end)- == (start ++ end, content)+ ==> splitterOutputs xmlTokens (fromString $ start ++ content ++ end)+ == (fromString $ start ++ end, fromString content) where name' = map letterChar name start = "<" ++ name' ++ concatMap attribute attrs ++ ">" end = "</" ++ name' ++ ">"@@ -446,9 +452,9 @@ prop_XMLtokens3 :: [LowercaseLetter] -> Bool -> [(Identifier, String)] -> String -> Property prop_XMLtokens3 name ws attrs content = name /= [] && all validAttribute attrs && intersect content "<&" == [] ==> transducerOutput- (xmlParseTokens >-> select xmlElementContent >-> unparse >-> coerce)- (start ++ content ++ end)- == content+ (xmlParseTokens >-> select xmlElementContent >-> unparse)+ (fromString $ start ++ content ++ end)+ == fromString content where name' = map letterChar name ++ spaces spaces = if ws then "\n\t " else "" start = "<" ++ name' ++ List.intercalate spaces (map attribute attrs) ++ ">"@@ -456,7 +462,7 @@ prop_XMLtokens4 :: NonEmptyList LowercaseLetter -> [(Identifier, String)] -> String -> Bool prop_XMLtokens4 (NonEmpty name) attrs content =- transducerOutput (xmlParseTokens >-> unparse >-> coerce) input == input+ transducerOutput (xmlParseTokens >-> unparse) (fromString input) == fromString input where name' = map letterChar name start = "<" ++ name' ++ concatMap attribute attrs ++ ">" end = "</" ++ name' ++ ">"@@ -467,17 +473,20 @@ prop_nestedInXMLcontent startTagsAndContent = transducerOutput (xmlParseTokens >-> select (snot xmlElement `nestedIn` xmlElementContent)- >-> unparse >-> coerce)- (nestXMLelements startTagsAndContent)- == concatMap escapeContentCharacter (concat (rights startTagsAndContent))+ >-> unparse)+ (fromString $ nestXMLelements startTagsAndContent)+ == (fromString $+ concatMap escapeContentCharacter $+ concat (rights startTagsAndContent)) prop_whileXMLelement :: [Either (Identifier, [(Identifier, String)]) String] -> Bool prop_whileXMLelement startTagsAndContent = transducerOutput (xmlParseTokens >-> (select xmlElementContent `while` xmlElement)- >-> unparse >-> coerce)- (nestXMLelements startTagsAndContent)- == concatMap escapeContentCharacter (concat (rights startTagsAndContent))+ >-> unparse)+ (fromString $ nestXMLelements startTagsAndContent)+ == (fromString $+ concatMap escapeContentCharacter (concat (rights startTagsAndContent))) nestXMLelements [] = [] nestXMLelements (Left (Identifier (NonEmpty name), attrs) : rest) = "<" ++ name' ++ concatMap attribute attrs ++ ">"@@ -503,84 +512,96 @@ escapeContentCharacter '&' = "&" escapeContentCharacter x = [x] -uppercaseContent :: (Functor f, Monad m) => TransducerComponent m (f Char) (f Char)-uppercaseContent = atomic "uppercase" 1 (oneToOneTransducer $ fmap toUpper)+uppercaseContent :: (Functor f, Monad m) => TransducerComponent m [f String] [f String]+uppercaseContent = atomic "uppercase" 1 (oneToOneTransducer $ map $ fmap (map toUpper)) -transducerOutput :: TransducerComponent Identity x y -> [x] -> [y]+transducerOutput :: (MonoidNull x, MonoidNull y) => TransducerComponent Identity x y -> x -> y transducerOutput t = transducerOutput' (with t) -transducerOutput' :: Transducer Identity x y -> [x] -> [y]+transducerOutput' :: (MonoidNull x, MonoidNull y) => Transducer Identity x y -> x -> y transducerOutput' t input = case runCoroutine (pipe- (putList input)+ (putAll input) (\source-> pipe (\sink-> transduce t source sink)- getList))- of Identity (_, (_, output)) -> output+ getAll))+ of Identity (_, (_, output)) -> output -splitterOutputs :: SplitterComponent Identity x b -> [x] -> ([x], [x])-splitterOutputs s input = +splitterOutputs :: MonoidNull x => SplitterComponent Identity x -> x -> (x, x)+splitterOutputs s input = case runCoroutine (pipe- (putList input)- (\source-> + (putAll input)+ (\source-> pipe - (\true-> + (\true-> pipe- (\false-> - pipe- (\edge-> split (with s) source true false edge)- (mapMStream_ (const $ return ())))- getList)- getList))+ (split (with s) source true)+ getAll)+ getAll)) of Identity (_, ((_, false), true)) -> (true, false) -splitterUnifiedOutput :: forall x b. SplitterComponent Identity x b -> [x] -> [Either (x, Bool) b]+splitterUnifiedOutput :: forall x b. SplitterComponent Identity [x] -> [x] -> [(x, Bool)] splitterUnifiedOutput s input = snd $ runIdentity $ runCoroutine (pipe (\sink-> pipe- (putList input)+ (putAll input) (mapSplit s sink))- getList)+ getAll) where mapSplit :: forall a d. AncestorFunctor a d =>- SplitterComponent Identity x b -> Sink Identity a (Either (x, Bool) b) -> Source Identity d x+ SplitterComponent Identity [x] -> Sink Identity a [(x, Bool)] -> Source Identity d [x] -> Coroutine d Identity ()- mapSplit s sink source = let sink' = liftSink sink :: Sink Identity d (Either (x, Bool) b)+ mapSplit s sink source = let sink' = liftSink sink :: Sink Identity d [(x, Bool)] in split (with s) source- (mapSink (Left . (\x-> (x, True))) sink')- (mapSink (Left . (\x-> (x, False))) sink')- (mapSink Right sink')+ (mapSink (\x-> (x, True)) sink')+ (mapSink (\x-> (x, False)) sink') -splitterOutputChunks :: SplitterComponent Identity x b -> [x] -> [([x], Bool)]-splitterOutputChunks s input = transducerOutput (foreach s- (group >-> atomic "true" 1 (oneToOneTransducer (\chunk-> (chunk, True))))- (group >-> atomic "true" 1 (oneToOneTransducer (\chunk-> (chunk, False)))))- input+splitterOutputChunks :: SplitterComponent Identity [x] -> [x] -> [([x], Bool)]+splitterOutputChunks s input = + transducerOutput (foreach s+ (group >-> atomic "true" 1 (oneToOneTransducer (\[chunk]-> [(chunk, True)])))+ (group >-> atomic "false" 1 (oneToOneTransducer (\[chunk]-> [(chunk, False)]))))+ input -simpleSplitterFromTrace :: SimpleSplitterTrace -> SplitterComponent Identity x ()-simpleSplitterFromTrace (init, last) = splitterFromTrace (fmap Just init, last)+splitterRawChunks :: SplitterComponent Identity [x] -> [[x]] -> [Maybe ([x], Bool)]+splitterRawChunks s input =+ snd $ runIdentity $ runCoroutine $+ pipe+ (\sink-> pipe+ (\sink-> mapM_ (putChunk sink) input)+ (\source-> pipe+ (\true-> pipe+ (split (with s) source true)+ (\source-> mapStreamChunks (\chunk-> [Just (chunk, False)]) source sink))+ (\source-> mapStreamChunks (\chunk-> [Just (chunk, True)]) source sink)))+ getAll -splitterFromTrace :: SplitterTrace -> SplitterComponent Identity x ()+simplestSplitterFromTrace :: SimplestSplitterTrace -> SplitterComponent Identity [x]+simplestSplitterFromTrace (init, last) = splitterFromTrace (map (Just . Just) init, last)++simpleSplitterFromTrace :: SimpleSplitterTrace -> SplitterComponent Identity [x]+simpleSplitterFromTrace (init, last) = splitterFromTrace (map Just init, last)++splitterFromTrace :: SplitterTrace -> SplitterComponent Identity [x] splitterFromTrace trace = atomic "splitterFromTrace" 1 (splitterFromTrace' trace) -splitterFromTrace' :: SplitterTrace -> Splitter Identity x ()+splitterFromTrace' :: SplitterTrace -> Splitter Identity [x] splitterFromTrace' trace1 = Splitter $- \source true false edge->+ \source true false-> 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 previous tail q'- Just Nothing -> when (not previous) (put edge ())+ Just Nothing -> when (not previous) (putChunk true [] >> return ()) >> follow False tail q'- Just (Just True) -> when (not previous) (put edge ())- >> putList (Foldable.toList (Seq.viewl q')) true+ Just (Just True) -> when (not previous) (putChunk true [] >> return ())+ >> putAll (Foldable.toList (Seq.viewl q')) true >> follow True tail Seq.empty- Just (Just False) -> putList (Foldable.toList (Seq.viewl q')) false+ Just (Just False) -> putAll (Foldable.toList (Seq.viewl q')) false >> follow False tail Seq.empty fail = if find (maybe False isJust) trace2 == Just (Just (Just True))- then do when (not previous) (put edge ())- putList (Foldable.toList (Seq.viewl q)) true- else putList (Foldable.toList (Seq.viewl q)) false+ then putAll (Foldable.toList (Seq.viewl q)) true+ else putAll (Foldable.toList (Seq.viewl q)) false in follow False (cycle (fst trace1 ++ [Just (Just $ snd trace1)])) Seq.empty >> return () @@ -590,8 +611,8 @@ mapWords :: (String -> String) -> String -> String mapWords f s = concat (map (\w@(c:_)-> if isSpace c then w else f w) (groupBy (\x y-> isSpace x == isSpace y) s)) +type SimplestSplitterTrace = ([Bool], Bool) type SimpleSplitterTrace = ([Maybe Bool], Bool)- type SplitterTrace = ([Maybe (Maybe Bool)], Bool) data TestEnum = One | Two | Three | Four | Five deriving (Enum, Eq, Show)@@ -622,10 +643,10 @@ instance CoArbitrary c => CoArbitrary (Component c) where coarbitrary c = coarbitrary (with c) -instance Arbitrary (Splitter Identity Int ()) where+instance Arbitrary (Splitter Identity [Int]) where arbitrary = fmap splitterFromTrace' arbitrary-instance CoArbitrary (Splitter Identity Int ()) where+instance CoArbitrary (Splitter Identity [Int]) where coarbitrary s gen = sized (\n-> coarbitrary (transducerOutput' (Combinator.ifs sequentialBinder s- (oneToOneTransducer $ const True)- (oneToOneTransducer $ const False))+ (oneToOneTransducer $ const [True])+ (oneToOneTransducer $ const [False])) [1..n]) gen)
scc.cabal view
@@ -1,15 +1,15 @@ Name: scc-Version: 0.7.1-Cabal-Version: >= 1.2+Version: 0.8+Cabal-Version: >= 1.10 Build-Type: Simple Synopsis: Streaming component combinators Category: Control, Combinators, Concurrency-Tested-with: GHC == 6.12.3, GHC == 7.0+Tested-with: GHC == 7.4, GHC == 7.6 Description:- SCC is a layered library of Streaming Component Combinators. The lowest layer defines stream abstractions and nested- producer-consumer coroutine pairs based on the Coroutine monad transformer. On top of that are streaming component- types, a number of primitive streaming components and a set of component combinators. Finally, there is an executable- that exposes all the framework functionality in a command-line shell.+ SCC is a layered library of Streaming Component Combinators. The lowest layer in "Control.Concurent.SCC.Streams"+ defines stream abstractions and nested producer-consumer coroutine pairs based on the Coroutine monad transformer.+ On top of that are streaming component types, a number of primitive streaming components and a set of component+ combinators. Finally, there is an executable that exposes all the framework functionality in a command-line shell. . The original library design is based on paper <http://conferences.idealliance.org/extreme/html/2006/Blazevic01/EML2006Blazevic01.html> .@@ -17,14 +17,14 @@ License: GPL License-file: LICENSE.txt-Copyright: (c) 2008-2011 Mario Blazevic+Copyright: (c) 2008-2013 Mario Blazevic Author: Mario Blazevic Maintainer: blamario@yahoo.com Homepage: http://trac.haskell.org/SCC/ Extra-source-files: grammar.bnf Makefile--- Source-repository head--- type: darcs--- location: http://code.haskell.org/SCC/+Source-repository head+ type: darcs+ location: http://code.haskell.org/SCC/ Flag Test Description: Install QuickCheck test suite Default: False@@ -34,31 +34,42 @@ Other-Modules: Control.Concurrent.SCC.Streams, Control.Concurrent.SCC.Types, Control.Concurrent.SCC.Coercions, Control.Concurrent.SCC.Combinators, Control.Concurrent.SCC.Primitives, Control.Concurrent.SCC.XML, Control.Concurrent.Configuration, Control.Concurrent.SCC.Configurable- Build-Depends: base < 5, containers, transformers >= 0.2 && < 0.3, incremental-parser >= 0.2 && < 0.3,- monad-parallel, monad-coroutine >= 0.7 && < 0.8, bytestring < 1.0, text < 1.0,- process, readline, parsec >= 3.0 && < 4.0+ Build-Depends: base < 5, containers, transformers >= 0.2 && < 0.4, bytestring < 1.0, text < 1.0,+ monoid-subclasses == 0.1.*, incremental-parser >= 0.2.2 && < 0.3,+ monad-parallel, monad-coroutine == 0.8.*,+ process, haskeline, parsec == 3.* GHC-options: -threaded+ if impl(ghc >= 7.0.0)+ default-language: Haskell2010 -Executable test-scc+test-suite Main+ Type: exitcode-stdio-1.0+ x-uses-tf: true Main-is: Test/TestSCC.hs Other-Modules: Control.Concurrent.SCC.Streams, Control.Concurrent.SCC.Types, Control.Concurrent.SCC.Coercions, Control.Concurrent.SCC.Combinators, Control.Concurrent.SCC.Primitives, Control.Concurrent.SCC.XML, Control.Concurrent.Configuration, Control.Concurrent.SCC.Configurable- Build-Depends: base < 5, containers, transformers >= 0.2 && < 0.3, incremental-parser >= 0.2 && < 0.3,- monad-parallel, monad-coroutine >= 0.7 && < 0.8, bytestring < 1.0, text < 1.0,- QuickCheck >= 2 && < 3+ Build-Depends: base < 5, containers, transformers >= 0.2 && < 0.4, bytestring < 1.0, text < 1.0,+ monoid-subclasses == 0.1.*, incremental-parser >= 0.2.2 && < 0.3,+ monad-parallel, monad-coroutine == 0.8.*,+ QuickCheck >= 2 && < 3, test-framework >= 0.4.1, test-framework-quickcheck2 GHC-options: -threaded -fcontext-stack=30 if !flag(test) buildable: False+ if impl(ghc >= 7.0.0)+ default-language: Haskell2010 Library- Exposed-Modules: Control.Concurrent.Configuration, Control.Concurrent.SCC.Configurable,+ Exposed-Modules: Control.Concurrent.SCC.Streams, Control.Concurrent.SCC.Types,+ Control.Concurrent.SCC.Configurable, Control.Concurrent.SCC.Parallel, Control.Concurrent.SCC.Sequential- Other-Modules: Control.Concurrent.SCC.Streams, Control.Concurrent.SCC.Types, Control.Concurrent.SCC.Coercions,+ Other-Modules: Control.Concurrent.Configuration, Control.Concurrent.SCC.Coercions, Control.Concurrent.SCC.Combinators.Parallel, Control.Concurrent.SCC.Combinators.Sequential, Control.Concurrent.SCC.Combinators, Control.Concurrent.SCC.Primitives, Control.Concurrent.SCC.XML- - Build-Depends: base < 5, containers, transformers >= 0.2 && < 0.3, incremental-parser >= 0.2 && < 0.3,- monad-parallel, monad-coroutine >= 0.7 && < 0.8, bytestring < 1.0, text < 1.0+ Build-Depends: base < 5, containers, transformers >= 0.2 && < 0.4, bytestring < 1.0, text < 1.0,+ monoid-subclasses == 0.1.*, incremental-parser >= 0.2.2 && < 0.3,+ monad-parallel, monad-coroutine == 0.8.* GHC-prof-options: -auto-all+ if impl(ghc >= 7.0.0)+ default-language: Haskell2010