diff --git a/Control/Concurrent/Configuration.hs b/Control/Concurrent/Configuration.hs
--- a/Control/Concurrent/Configuration.hs
+++ b/Control/Concurrent/Configuration.hs
@@ -1,5 +1,5 @@
{-
- Copyright 2008-2009 Mario Blazevic
+ Copyright 2008-2010 Mario Blazevic
This file is part of the Streaming Component Combinators (SCC) project.
@@ -33,6 +33,7 @@
where
import Data.List (minimumBy)
+import GHC.Conc (numCapabilities)
-- | 'AnyComponent' is an existential type wrapper around a 'Component'.
data AnyComponent = forall a. AnyComponent {component :: Component a}
@@ -58,6 +59,9 @@
with :: c
}
+instance Functor Component where
+ fmap f c = c{with= f (with c), usingThreads= fmap f . usingThreads c}
+
-- | Show details of the given component's configuration.
showComponentTree :: forall c. Component c -> String
showComponentTree c = showIndentedComponent 1 c
@@ -175,13 +179,15 @@
-- | Builds a tree of recursive components. The combinator takes a list of pairs of a boolean flag denoting whether the
-- level should be run in parallel and the value.
-recursiveComponentTree :: forall c1 c2. String -> ([(Bool, c1)] -> c2) -> Component c1 -> Component c2
+recursiveComponentTree :: forall c1 c2. String -> (Bool -> c1 -> c2 -> c2) -> Component c1 -> Component c2
recursiveComponentTree name combinator c =
- toComponent name maxBound $
- \threads-> let (configuration, levels) = optimalRecursion threads
- optimalRecursion :: Int -> (ComponentConfiguration, [(Bool, c1)])
- optimalRecursion threads =
- let (configuration, c', levels', parallel) = optimalTwoParallelConfigurations threads c r
- r = toComponent name maxBound optimalRecursion
- in (configuration, (parallel, with c') : with levels')
- in (configuration, combinator levels)
+ toComponent name numCapabilities $
+ \threads-> let optimalRecursion :: Int -> Int -> (ComponentConfiguration, c2)
+ optimalRecursion oldThreads threads
+ | oldThreads == threads = let final = combinator False (with $ usingThreads c threads) final
+ in (ComponentConfiguration [] threads (cost c), final)
+ | otherwise =
+ let (configuration, c', r', parallel) = optimalTwoParallelConfigurations threads c r
+ r = toComponent name (threads - 1) (optimalRecursion threads)
+ in (configuration, combinator parallel (with c') (with r'))
+ in optimalRecursion 0 threads
diff --git a/Control/Concurrent/SCC/Coercions.hs b/Control/Concurrent/SCC/Coercions.hs
new file mode 100644
--- /dev/null
+++ b/Control/Concurrent/SCC/Coercions.hs
@@ -0,0 +1,85 @@
+{-
+ Copyright 2009-2010 Mario Blazevic
+
+ This file is part of the Streaming Component Combinators (SCC) project.
+
+ The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public
+ License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later
+ version.
+
+ SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty
+ of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License along with SCC. If not, see
+ .
+-}
+
+-- | This module defines class 'Coercible' and its instances.
+
+{-# LANGUAGE Rank2Types, ScopedTypeVariables, MultiParamTypeClasses,
+ FlexibleContexts, FlexibleInstances, IncoherentInstances #-}
+{-# OPTIONS_HADDOCK hide #-}
+
+module Control.Concurrent.SCC.Coercions
+ (
+ -- * Coercible class
+ Coercible(..),
+ -- * Splitter isomorphism
+ adaptSplitter
+ )
+where
+
+import Prelude hiding ((.))
+import Control.Category ((.))
+import Control.Monad (liftM)
+import Data.Text (Text, pack, unpack)
+
+import Control.Monad.Coroutine
+import Control.Monad.Parallel (MonadParallel(..))
+
+import Control.Concurrent.SCC.Streams
+import Control.Concurrent.SCC.Types
+
+
+-- | Two streams of 'Coercible' types can be unambigously converted one to another.
+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 consumer = isolateConsumer $ \source-> liftM snd $ pipe (transduce coerce source) (consume consumer)
+ adaptProducer :: Monad m => 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
+ adaptConsumer = id
+ adaptProducer = id
+
+instance Coercible Char 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 x y => Coercible (Markup b x) y where
+ coerce = coerce . statelessTransducer unmark
+ where unmark (Content x) = [x]
+ unmark (Markup _) = []
+
+-- | 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 sx =
+ isolateSplitter $ \source true false edge->
+ pipe
+ (transduce coerce source)
+ (\source'->
+ pipe
+ (\true'->
+ pipe
+ (\false'-> split sx source' true' false' edge)
+ (flip (transduce coerce) false))
+ (flip (transduce coerce) true))
+ >> return ()
diff --git a/Control/Concurrent/SCC/Combinators.hs b/Control/Concurrent/SCC/Combinators.hs
--- a/Control/Concurrent/SCC/Combinators.hs
+++ b/Control/Concurrent/SCC/Combinators.hs
@@ -14,82 +14,82 @@
.
-}
-{-# LANGUAGE ScopedTypeVariables, Rank2Types, KindSignatures, EmptyDataDecls,
+{-# LANGUAGE ScopedTypeVariables, RankNTypes, KindSignatures, EmptyDataDecls,
MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, FunctionalDependencies, TypeFamilies #-}
+{-# OPTIONS_HADDOCK hide #-}
-- | The "Combinators" module defines combinators applicable to values of the 'Transducer' and 'Splitter' types defined
-- in the "Control.Concurrent.SCC.Types" module.
-module Control.Concurrent.SCC.Combinators
- (-- * Consumer, producer, and transducer combinators
- splitterToMarker,
- consumeBy, prepend, append, substitute,
- PipeableComponentPair (compose), JoinableComponentPair (join, sequence),
- -- * Pseudo-logic splitter combinators
- -- | Combinators 'sAnd' and 'sOr' are only /pseudo/-logic. While the laws of double negation and De Morgan's laws
- -- hold, 'sAnd' and 'sOr' are in general not commutative, associative, nor idempotent. In the special case when all
- -- argument splitters are stateless, such as those produced by 'Control.Concurrent.SCC.Types.statelessSplitter',
- -- these combinators do satisfy all laws of Boolean algebra.
- sNot, sAnd, sOr,
- -- ** Zipping logic combinators
- -- | The 'pAnd' and 'pOr' combinators run the argument splitters in parallel and combine their logical outputs using
- -- the corresponding logical operation on each output pair, in a manner similar to 'Data.List.zipWith'. They fully
- -- satisfy the laws of Boolean algebra.
- pAnd, pOr,
- -- * Flow-control combinators
- -- | The following combinators resemble the common flow-control programming language constructs. Combinators
- -- 'wherever', 'unless', and 'select' are just the special cases of the combinator 'ifs'.
- --
- -- * /transducer/ ``wherever`` /splitter/ = 'ifs' /splitter/ /transducer/ 'Control.Category.id'
- --
- -- * /transducer/ ``unless`` /splitter/ = 'ifs' /splitter/ 'Control.Category.id' /transducer/
- --
- -- * 'select' /splitter/ = 'ifs' /splitter/ 'Control.Category.id'
- -- 'Control.Concurrent.SCC.Primitives.suppress'
- --
- ifs, wherever, unless, select,
- -- ** Recursive
- while, nestedIn,
- -- * Section-based combinators
- -- | All combinators in this section use their 'Control.Concurrent.SCC.Splitter' argument to determine the structure
- -- of the input. Every contiguous portion of the input that gets passed to one or the other sink of the splitter is
- -- treated as one section in the logical structure of the input stream. What is done with the section depends on the
- -- combinator, but the sections, and therefore the logical structure of the input stream, are determined by the
- -- argument splitter alone.
- foreach, having, havingOnly, followedBy, even,
- -- ** first and its variants
- first, uptoFirst, prefix,
- -- ** last and its variants
- last, lastAndAfter, suffix,
- -- ** positional splitters
- startOf, endOf,
- -- ** input ranges
- between,
- -- * parser support
- parseRegions, parseNestedRegions,
- -- * helper functions
- groupMarks, findsTrueIn, findsFalseIn, teeConsumers)
+module Control.Concurrent.SCC.Combinators (
+ -- * Consumer, producer, and transducer combinators
+ consumeBy, prepend, append, substitute,
+ PipeableComponentPair (compose), JoinableComponentPair (join, sequence),
+ -- * Splitter combinators
+ sNot,
+ -- ** Pseudo-logic flow combinators
+ -- | Combinators 'sAnd' and 'sOr' are only /pseudo/-logic. While the laws of double negation and De Morgan's laws
+ -- hold, 'sAnd' and 'sOr' are in general not commutative, associative, nor idempotent. In the special case when all
+ -- argument splitters are stateless, such as those produced by 'Control.Concurrent.SCC.Types.statelessSplitter',
+ -- these combinators do satisfy all laws of Boolean algebra.
+ sAnd, sOr,
+ -- ** Zipping logic combinators
+ -- | The 'pAnd' and 'pOr' combinators run the argument splitters in parallel and combine their logical outputs using
+ -- the corresponding logical operation on each output pair, in a manner similar to 'Data.List.zipWith'. They fully
+ -- satisfy the laws of Boolean algebra.
+ pAnd, pOr,
+ -- * Flow-control combinators
+ -- | The following combinators resemble the common flow-control programming language constructs. Combinators
+ -- 'wherever', 'unless', and 'select' are just the special cases of the combinator 'ifs'.
+ --
+ -- * /transducer/ ``wherever`` /splitter/ = 'ifs' /splitter/ /transducer/ 'Control.Category.id'
+ --
+ -- * /transducer/ ``unless`` /splitter/ = 'ifs' /splitter/ 'Control.Category.id' /transducer/
+ --
+ -- * 'select' /splitter/ = 'ifs' /splitter/ 'Control.Category.id'
+ -- 'Control.Concurrent.SCC.Primitives.suppress'
+ --
+ ifs, wherever, unless, select,
+ -- ** Recursive
+ while, nestedIn,
+ -- * Section-based combinators
+ -- | All combinators in this section use their 'Control.Concurrent.SCC.Splitter' argument to determine the structure
+ -- of the input. Every contiguous portion of the input that gets passed to one or the other sink of the splitter is
+ -- treated as one section in the logical structure of the input stream. What is done with the section depends on the
+ -- combinator, but the sections, and therefore the logical structure of the input stream, are determined by the
+ -- argument splitter alone.
+ foreach, having, havingOnly, followedBy, even,
+ -- ** first and its variants
+ first, uptoFirst, prefix,
+ -- ** last and its variants
+ last, lastAndAfter, suffix,
+ -- ** positional splitters
+ startOf, endOf, between,
+ -- * Parser support
+ splitterToMarker, parseRegions, parseNestedRegions, parseEachNestedRegion,
+ -- * Helper functions
+ groupMarks, findsTrueIn, findsFalseIn, teeConsumers
+ )
where
-import Control.Monad.Coroutine
-import Control.Monad.Parallel (MonadParallel(..))
-
-import Control.Concurrent.SCC.Streams
-import Control.Concurrent.SCC.Types
-
import Prelude hiding (even, last, sequence)
import Control.Category ((>>>))
+import qualified Control.Category as Category
import Control.Monad (liftM, when)
import qualified Control.Monad as Monad
import Control.Monad.Trans.Class (lift)
-import Data.Maybe (isJust, isNothing, fromJust)
+import Data.Maybe (isJust, isNothing, fromJust, mapMaybe)
import qualified Data.Foldable as Foldable
import qualified Data.Sequence as Seq
import Data.Sequence (Seq, (|>), (><), ViewL (EmptyL, (:<)))
-import qualified Control.Category
-import qualified Data.List
+import Control.Monad.Coroutine
+import Control.Monad.Parallel (MonadParallel(..))
+import Control.Concurrent.SCC.Streams
+import Control.Concurrent.SCC.Types
+import Control.Concurrent.SCC.Coercions
+
-- | Converts a 'Consumer' into a 'Transducer' with no output.
consumeBy :: forall m x y r. (Monad m) => Consumer m x r -> Transducer m x y
consumeBy c = Transducer $ \ source _sink -> consume c source >> return ()
@@ -104,31 +104,32 @@
-- * The result output, if any, is the output of the second component.
class PipeableComponentPair (m :: * -> *) w c1 c2 c3 | c1 c2 -> c3, c1 c3 -> c2, c2 c3 -> c2,
c1 -> m w, c2 -> m w, c3 -> m
- where compose :: Bool -> c1 -> c2 -> c3
+ where compose :: PairBinder m -> c1 -> c2 -> c3
-instance forall m x. (MonadParallel m) =>
- PipeableComponentPair m x (Producer m x ()) (Consumer m x ()) (Performer m ())
- where compose parallel p c = let performPipe :: Coroutine Naught m ((), ())
- performPipe = pipePS parallel (produce p) (consume c)
- in Performer (runCoroutine performPipe >> return ())
+instance 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 (MonadParallel m)
- => PipeableComponentPair m y (Transducer m x y) (Consumer m y r) (Consumer m x r)
- where compose parallel t c = isolateConsumer $ \source->
- liftM snd $
- pipePS parallel
- (transduce t source)
- (consume c)
+instance 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 (MonadParallel m) => PipeableComponentPair m x (Producer m x r) (Transducer m x y) (Producer m y r)
- where compose parallel p t = isolateProducer $ \sink->
- liftM fst $
- pipePS parallel
- (produce p)
- (\source-> transduce t source sink)
+instance 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 MonadParallel m => PipeableComponentPair m y (Transducer m x y) (Transducer m y z) (Transducer m x z)
- where compose parallel t1 t2 = if parallel then t1 >|> t2 else t1 >>> t2
+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
@@ -151,193 +152,168 @@
-- following properties:
--
-- * if both argument components consume input, the input of the combined component gets distributed to both
--- components in parallel,
+-- components in parallel, and
--
-- * if both argument components produce output, the output of the combined component is a concatenation of the
--- complete output from the first component followed by the complete output of the second component, and
---
--- * the 'join' method may apply the components in any order, the 'sequence' method makes sure its first argument
--- has completed before using the second one.
+-- complete output from the first component followed by the complete output of the second component.
class (Monad m, CompatibleSignature c1 t1 m x y, CompatibleSignature c2 t2 m x y, CompatibleSignature c3 t3 m x y)
=> JoinableComponentPair t1 t2 t3 m x y c1 c2 c3 | c1 c2 -> c3, c1 -> t1 m, c2 -> t2 m, c3 -> t3 m x y,
t1 m x y -> c1, t2 m x y -> c2, t3 m x y -> c3
- where join :: Bool -> c1 -> c2 -> c3
- sequence :: c1 -> c2 -> c3
- join = const sequence
+ where
+ -- | The 'join' combinator may apply the components in any order.
+ join :: PairBinder m -> c1 -> c2 -> c3
+ join = const sequence
+ -- | The 'sequence' combinator makes sure its first argument has completed before using the second one.
+ sequence :: c1 -> c2 -> c3
instance forall m x r1 r2. Monad m =>
JoinableComponentPair (ProducerType r1) (ProducerType r2) (ProducerType r2) m () [x]
(Producer m x r1) (Producer m x r2) (Producer m x r2)
where sequence p1 p2 = Producer $ \sink-> produce p1 sink >> produce p2 sink
-instance forall m x. MonadParallel m =>
+instance forall m x. Monad m =>
JoinableComponentPair (ConsumerType ()) (ConsumerType ()) (ConsumerType ()) m [x] ()
(Consumer m x ()) (Consumer m x ()) (Consumer m x ())
- where join parallel c1 c2 = Consumer (liftM (const ()) . teeConsumers parallel (consume c1) (consume c2))
+ where join binder c1 c2 = Consumer (liftM (const ()) . teeConsumers binder (consume c1) (consume c2))
sequence c1 c2 = Consumer $ \source->
- teeConsumers False (consume c1) getList source
+ teeConsumers sequentialBinder (consume c1) getList source
>>= \((), list)-> pipe (putList list) (consume c2)
>> return ()
-instance forall m x y. (MonadParallel m) =>
+instance forall m x y. Monad m =>
JoinableComponentPair TransducerType TransducerType TransducerType m [x] [y]
(Transducer m x y) (Transducer m x y) (Transducer m x y)
- where join parallel t1 t2 = isolateTransducer $ \source sink->
- pipe
- (\buffer-> teeConsumers parallel
- (\source-> transduce t1 source sink)
- (\source-> transduce t2 source buffer)
- source)
- getList
- >>= \(_, list)-> putList list sink
+ where join binder t1 t2 = isolateTransducer $ \source sink->
+ pipe
+ (\buffer-> teeConsumers binder
+ (\source-> transduce t1 source sink)
+ (\source-> transduce t2 source buffer)
+ source)
+ getList
+ >>= \(_, list)-> putList list sink
+ >> return ()
sequence t1 t2 = isolateTransducer $ \source sink->
- teeConsumers False (flip (transduce t1) sink) getList source
+ teeConsumers sequentialBinder (flip (transduce t1) sink) getList source
>>= \(_, list)-> pipe (putList list) (\source-> transduce t2 source sink)
>> return ()
-instance forall m r1 r2. MonadParallel m =>
+instance forall m r1 r2. Monad m =>
JoinableComponentPair (PerformerType r1) (PerformerType r2) (PerformerType r2) m () ()
(Performer m r1) (Performer m r2) (Performer m r2)
- where join parallel p1 p2 = Performer $ if parallel
- then bindM2 (const return) (perform p1) (perform p2)
- else perform p1 >> perform p2
+ where join binder p1 p2 = Performer $ binder (const return) (perform p1) (perform p2)
sequence p1 p2 = Performer $ perform p1 >> perform p2
-instance forall m x r1 r2. (MonadParallel m) =>
+instance forall m x r1 r2. Monad m =>
JoinableComponentPair (PerformerType r1) (ProducerType r2) (ProducerType r2) m () [x]
(Performer m r1) (Producer m x r2) (Producer m x r2)
- where join parallel pe pr = Producer $ \sink-> if parallel
- then bindM2 (const return) (lift (perform pe)) (produce pr sink)
- else lift (perform pe) >> produce pr sink
+ 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. (MonadParallel m) =>
+instance forall m x r1 r2. Monad m =>
JoinableComponentPair (ProducerType r1) (PerformerType r2) (ProducerType r2) m () [x]
(Producer m x r1) (Performer m r2) (Producer m x r2)
- where join parallel pr pe = Producer $ \sink-> if parallel
- then bindM2 (const return) (produce pr sink) (lift (perform pe))
- else produce pr sink >> lift (perform pe)
+ 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. (MonadParallel m) =>
+instance forall m x r1 r2. Monad m =>
JoinableComponentPair (PerformerType r1) (ConsumerType r2) (ConsumerType r2) m [x] ()
(Performer m r1) (Consumer m x r2) (Consumer m x r2)
- where join parallel p c = Consumer $ \source-> if parallel
- then bindM2 (const return) (lift (perform p)) (consume c source)
- else lift (perform p) >> consume c source
+ 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. (MonadParallel m) =>
+instance forall m x r1 r2. Monad m =>
JoinableComponentPair (ConsumerType r1) (PerformerType r2) (ConsumerType r2) m [x] ()
(Consumer m x r1) (Performer m r2) (Consumer m x r2)
- where join parallel c p = Consumer $ \source-> if parallel
- then bindM2 (const return) (consume c source) (lift (perform p))
- else consume c source >> lift (perform p)
+ 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. (MonadParallel m) =>
+instance forall m x y r. Monad m =>
JoinableComponentPair (PerformerType r) TransducerType TransducerType m [x] [y]
(Performer m r) (Transducer m x y) (Transducer m x y)
- where join parallel p t = Transducer $ \ source sink -> if parallel
- then bindM2 (const return)
- (lift (perform p)) (transduce t source sink)
- else lift (perform p) >> transduce t source sink
+ where join binder p t =
+ Transducer $ \ source sink ->
+ liftBinder binder (const return) (lift (perform p)) (transduce t source sink)
sequence p t = Transducer $ \ source sink -> lift (perform p) >> transduce t source sink
-instance forall m x y r. (MonadParallel m)
+instance forall m x y r. Monad m
=> JoinableComponentPair TransducerType (PerformerType r) TransducerType m [x] [y]
(Transducer m x y) (Performer m r) (Transducer m x y)
- where join parallel t p = Transducer $ \ source sink -> if parallel
- then bindM2 (const . return)
- (transduce t source sink) (lift (perform p))
- else do result <- transduce t source sink
- lift (perform p)
- return result
+ where join binder t p =
+ Transducer $ \ source sink ->
+ liftBinder binder (const . return) (transduce t source sink) (lift (perform p))
sequence t p = Transducer $ \ source sink -> do result <- transduce t source sink
lift (perform p)
return result
-instance forall m x y. (MonadParallel m) =>
+instance forall m x y. Monad m =>
JoinableComponentPair (ProducerType ()) TransducerType TransducerType m [x] [y]
(Producer m y ()) (Transducer m x y) (Transducer m x y)
- where join parallel p t = if parallel
- then isolateTransducer $ \source sink->
- do (rest, out) <- pipe
- (\buffer-> bindM2 (const return)
- (produce p sink) (transduce t source buffer))
- getList
- putList out sink
- return rest
- else sequence p t
+ 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 ()
sequence p t = Transducer $ \ source sink -> produce p sink >> transduce t source sink
-instance forall m x y. (MonadParallel m) =>
+instance forall m x y. Monad m =>
JoinableComponentPair TransducerType (ProducerType ()) TransducerType m [x] [y]
(Transducer m x y) (Producer m y ()) (Transducer m x y)
- where join parallel t p = if parallel
- then isolateTransducer $ \source sink->
- do (rest, out) <- pipe
- (\buffer-> bindM2 (const . return)
- (transduce t source sink)
- (produce p buffer))
- getList
- putList out sink
- return rest
- else sequence t p
+ 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 ()
sequence t p = Transducer $ \ source sink -> do result <- transduce t source sink
produce p sink
return result
-instance forall m x y. (MonadParallel m) =>
+instance forall m x y. Monad m =>
JoinableComponentPair (ConsumerType ()) TransducerType TransducerType m [x] [y]
(Consumer m x ()) (Transducer m x y) (Transducer m x y)
- where join parallel c t = isolateTransducer $ \source sink->
- teeConsumers parallel (consume c) (\source-> transduce t source sink) source
- >> return ()
+ 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 False (consume c) getList source
+ teeConsumers sequentialBinder (consume c) getList source
>>= \(_, list)-> pipe (putList list) (\source-> transduce t source sink)
>> return ()
-instance forall m x y. MonadParallel m =>
+instance forall m x y. Monad m =>
JoinableComponentPair TransducerType (ConsumerType ()) TransducerType m [x] [y]
(Transducer m x y) (Consumer m x ()) (Transducer m x y)
- where join parallel t c = join parallel c t
+ where join binder t c = join binder c t
sequence t c = isolateTransducer $ \source sink->
- teeConsumers False (\source-> transduce t source sink) getList source
+ teeConsumers sequentialBinder (\source-> transduce t source sink) getList source
>>= \(_, list)-> pipe (putList list) (consume c)
>> return ()
-instance forall m x y. (MonadParallel m) =>
+instance forall m x y. Monad m =>
JoinableComponentPair (ProducerType ()) (ConsumerType ()) TransducerType m [x] [y]
(Producer m y ()) (Consumer m x ()) (Transducer m x y)
- where join parallel p c = Transducer $ \ source sink ->
- if parallel
- then bindM2 (\ _ _ -> return ()) (produce p sink) (consume c source)
- else produce p sink >> consume c source
+ 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. (MonadParallel m) =>
+instance forall m x y. Monad m =>
JoinableComponentPair (ConsumerType ()) (ProducerType ()) TransducerType m [x] [y]
(Consumer m x ()) (Producer m y ()) (Transducer m x y)
- where join parallel c p = join parallel p c
+ where join binder c p = join binder p c
sequence c p = Transducer $ \ source sink -> consume c source >> produce p sink
-- | Combinator 'prepend' converts the given producer to a 'Control.Concurrent.SCC.Types.Transducer' that passes all its
-- input through unmodified, except for prepending the output of the argument producer to it. The following law holds: @
-- 'prepend' /prefix/ = 'join' ('substitute' /prefix/) 'Control.Category.id' @
-prepend :: forall m x r. (Monad m) => Producer m x r -> Transducer m x x
+prepend :: forall m x r. Monad m => Producer m x r -> Transducer m x x
prepend prefix = Transducer $ \ source sink -> produce prefix sink >> pour source sink
-- | Combinator 'append' converts the given producer to a 'Control.Concurrent.SCC.Types.Transducer' that passes all its
-- input through unmodified, finally appending the output of the argument producer to it. The following law holds: @
-- 'append' /suffix/ = 'join' 'Control.Category.id' ('substitute' /suffix/) @
-append :: forall m x r. (Monad m) => Producer m x r -> Transducer m x x
+append :: forall m x r. Monad m => Producer m x r -> Transducer m x x
append suffix = Transducer $ \ source sink -> pour source sink >> produce suffix sink >> return ()
-- | The 'substitute' combinator converts its argument producer to a 'Control.Concurrent.SCC.Types.Transducer' that
-- produces the same output, while consuming its entire input and ignoring it.
-substitute :: forall m x y r. (Monad m) => Producer m y r -> Transducer m x y
+substitute :: forall m x y r. Monad m => Producer m y r -> Transducer m x y
substitute feed = Transducer $ \ source sink -> mapMStream_ (const $ return ()) source >> produce feed sink >> return ()
-- | The 'sNot' (streaming not) combinator simply reverses the outputs of the argument splitter. In other words, data
@@ -348,12 +324,12 @@
-- | The 'sAnd' combinator sends the /true/ sink output of its left operand to the input of its right operand for
-- further splitting. Both operands' /false/ sinks are connected to the /false/ sink of the combined splitter, but any
-- input value to reach the /true/ sink of the combined component data must be deemed true by both splitters.
-sAnd :: forall m x b1 b2. MonadParallel m => Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)
-sAnd parallel s1 s2 =
+sAnd :: forall m x b1 b2. Monad m => PairBinder m -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)
+sAnd binder s1 s2 =
isolateSplitter $ \ source true false edge ->
liftM (fst . fst) $
pipe
- (\edges-> pipePS parallel
+ (\edges-> pipeG binder
(\true-> split s1 source true false (mapSink Left edges))
(\source-> split s2 source true false (mapSink Right edges)))
(flip intersectRegions edge)
@@ -370,56 +346,52 @@
-- | A 'sOr' combinator's input value can reach its /false/ sink only by going through both argument splitters' /false/
-- sinks.
-sOr :: forall m x b1 b2. MonadParallel m =>
- Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x (Either b1 b2)
-sOr parallel s1 s2 = isolateSplitter $ \ source true false edge ->
- liftM fst $
- pipePS parallel
- (\false-> split s1 source true false (mapSink Left edge))
- (\source-> split s2 source true false (mapSink Right edge))
+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 binder s1 s2 =
+ isolateSplitter $ \ source true false edge ->
+ liftM fst $
+ pipeG binder
+ (\false-> split s1 source true false (mapSink Left edge))
+ (\source-> split s2 source true false (mapSink Right edge))
-- | Combinator 'pAnd' is a pairwise logical conjunction of two splitters run in parallel on the same input.
-pAnd :: forall m x b1 b2. MonadParallel m => Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)
-pAnd parallel s1 s2 = isolateSplitter $ \ source true false edge ->
- pipePS parallel
- (transduce (splittersToPairMarker parallel s1 s2) source)
- (\source-> let split l r = getWith (test l r) source
- test l r (Left (x, t1, t2))
- = (if t1 && t2 then put true x else put false x)
- >> split
- (if t1 then l else Nothing)
- (if t2 then r else Nothing)
- test _ Nothing (Right (Left l)) = split (Just l) Nothing
- test _ (Just r) (Right (Left l))
- = put edge (l, r) >> split (Just l) (Just r)
- test Nothing _ (Right (Right r)) = split Nothing (Just r)
- test (Just l) _ (Right (Right r))
- = put edge (l, r) >> split (Just l) (Just r)
- in split Nothing Nothing)
- >> return ()
+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 split l r = getWith (test l r) source
+ test l r (Left (x, t1, t2)) =
+ (if t1 && t2 then put true x else put false x)
+ >> split (if t1 then l else Nothing) (if t2 then r else Nothing)
+ test _ Nothing (Right (Left l)) = split (Just l) Nothing
+ test _ (Just r) (Right (Left l)) = put edge (l, r) >> split (Just l) (Just r)
+ test Nothing _ (Right (Right r)) = split Nothing (Just r)
+ test (Just l) _ (Right (Right r)) = put edge (l, r) >> split (Just l) (Just r)
+ in split Nothing Nothing)
+ >> return ()
-- | Combinator 'pOr' is a pairwise logical disjunction of two splitters run in parallel on the same input.
-pOr :: forall c m x b1 b2. MonadParallel m =>
- Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x (Either b1 b2)
+pOr :: forall c 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
-ifs :: forall c m x b. (MonadParallel m, Branching c m x ()) => Bool -> Splitter m x b -> c -> c -> c
-ifs parallel s c1 c2 = combineBranches if' parallel c1 c2
- where if' :: forall d. Bool -> (forall a d'. AncestorFunctor d d' => OpenConsumer m a d' x ()) ->
+ifs :: forall c m x b. (Monad m, Branching c m x ()) => PairBinder m -> Splitter m x b -> 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' parallel c1 c2 source = splitInputToConsumers parallel s source c1 c2
+ if' binder c1 c2 source = splitInputToConsumers binder s source c1 c2
-wherever :: forall m x b. MonadParallel m => Bool -> Transducer m x x -> Splitter m x b -> Transducer m x x
-wherever parallel t s = isolateTransducer wherever'
+wherever :: forall m x b. Monad m => PairBinder m -> Transducer m x x -> Splitter m x b -> 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 = pipePS parallel
+ wherever' source sink = pipeG binder
(\true-> split s source true sink (nullSink :: Sink m d b))
(flip (transduce t) sink)
>> return ()
-unless :: forall m x b. MonadParallel m => Bool -> Transducer m x x -> Splitter m x b -> Transducer m x x
-unless parallel t s = wherever parallel t (sNot s)
+unless :: forall m x b. Monad m => PairBinder m -> Transducer m x x -> Splitter m x b -> 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 s = isolateTransducer $ \source sink-> suppressProducer (suppressProducer . split s source sink)
@@ -429,79 +401,82 @@
parseRegions s = isolateTransducer $ \source sink->
pipe
(transduce (splitterToMarker s) source)
- (\source-> wrapRegions source sink)
+ (\source-> concatMapAccumStream wrap Nothing source sink
+ >>= maybe (return ()) (put sink . flush))
>> return ()
- where wrapRegions source sink = let wrap Nothing (Left (x, _)) = put sink (Content x)
- >> return Nothing
- wrap (Just p) (Left (x, False)) = flush p
- >> put sink (Content x)
- >> return Nothing
- wrap (Just (b, t)) (Left (x, True)) =
- do Monad.unless t (put sink (Markup (Start b)))
- put sink (Content x)
- return (Just (b, True))
- wrap (Just p) (Right b') = flush p >> return (Just (b', False))
- wrap Nothing (Right b) = return (Just (b, False))
- flush (b, t) = put sink $ Markup $ (if t then End else Point) b
- in foldMStream wrap Nothing source >>= maybe (return ()) flush
+ 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), [])
+ 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 source = transduce t source (mapSink Content sink)
+ in pipeG binder
+ (transduce (splitterToMarker s) source)
+ (\source-> groupMarks source (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. MonadParallel m => [(Bool, (Transducer m x x, Splitter m x b))] -> Transducer m x x
-while ((parallel, (t, s)) : rest) = isolateTransducer while'
+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 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 =
- pipePS parallel
+ pipeG binder
(\true-> split s source true sink (nullSink :: Sink m d b))
- (\source-> getWith
- (\x-> liftM fst $
- pipe
- (\sink-> put sink x >> pour source sink)
- (\source-> transduce while'' source sink))
- source)
+ (\source-> peek source
+ >>= maybe
+ (return ())
+ (\_-> transduce (compose binder t whileRest) source sink))
>> return ()
- while'' = compose parallel t (while rest)
-- | The recursive combinator 'nestedIn' combines two splitters into a mutually recursive loop acting as a single
--- splitter. The true sink of one of the argument splitters and false sink of the other become the true and false sinks
--- of the loop. The other two sinks are bound to the other splitter's source. The use of 'nestedIn' makes sense only
--- on hierarchically structured streams. If we gave it some input containing a flat sequence of values, and assuming
--- both component splitters are deterministic and stateless, an input value would either not loop at all or it would
--- loop forever.
-nestedIn :: forall m x b. MonadParallel m => [(Bool, (Splitter m x b, Splitter m x b))] -> Splitter m x b
-nestedIn ((parallel, (s1, s2)) : rest) =
+-- splitter. The true sink of one of the argument splitters and false sink of the other become the true and false sinks
+-- of the loop. The other two sinks are bound to the other splitter's source. The use of 'nestedIn' makes sense only on
+-- hierarchically structured streams. If we gave it some input containing a flat sequence of values, and assuming both
+-- component splitters are deterministic and stateless, an input value would either not loop at all or it would loop
+-- forever.
+nestedIn :: forall m x b. Monad m =>
+ PairBinder m -> Splitter m x b -> Splitter m x b -> Splitter m x b -> Splitter m x b
+nestedIn binder s1 s2 nestedRest =
isolateSplitter $ \ source true false edge ->
liftM fst $
- pipePS parallel
+ pipeG binder
(\false-> split s1 source true false edge)
(\source-> pipe
- (\true-> split s2 source true false (filterMSink (const $ return False) edge))
- (\source-> get source
+ (\true-> splitInput s2 source true false)
+ (\source-> peek source
>>= maybe
- (return ((), ()))
- (\x-> pipe
- (\sink-> put sink x >> pour source sink)
- (\source-> split (nestedIn rest) source true false edge))))
+ (return ())
+ (\_-> split nestedRest source true false edge)))
-- | The 'foreach' combinator is similar to the combinator 'ifs' in that it combines a splitter and two transducers into
-- another transducer. However, in this case the transducers are re-instantiated for each consecutive portion of the
-- input as the splitter chunks it up. Each contiguous portion of the input that the splitter sends to one of its two
-- sinks gets transducered through the appropriate argument transducer as that transducer's whole input. As soon as the
-- contiguous portion is finished, the transducer gets terminated.
-foreach :: forall m x b c. (MonadParallel m, Branching c m x ()) => Bool -> Splitter m x b -> c -> c -> c
-foreach parallel s c1 c2 = combineBranches foreach' parallel c1 c2
- where foreach' :: forall d. Bool ->
+foreach :: forall m x b c. (Monad m, Branching c m x ()) => PairBinder m -> Splitter m x b -> 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 ()) ->
(forall a d'. AncestorFunctor d d' => OpenConsumer m a d' x ()) ->
forall a. OpenConsumer m a d x ()
- foreach' parallel c1 c2 source =
+ foreach' binder c1 c2 source =
liftM fst $
- pipePS parallel
+ pipeG binder
(transduce (splitterToMarker s) (liftSource source :: Source m d x))
(\source-> groupMarks source (maybe c2 (const c1)))
@@ -510,51 +485,56 @@
-- second splitter is instantiated and run on each portion of the input that goes to first splitter's /true/ sink. If
-- the second splitter sends any output at all to its /true/ sink, the whole input portion is passed on to the /true/
-- sink of the combined splitter, otherwise it goes to its /false/ sink.
-having :: forall m x b1 b2. MonadParallel m => Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x b1
-having parallel s1 s2 = isolateSplitter s
- where s source true false edge = pipePS parallel
+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 binder s1 s2 = isolateSplitter s
+ where s :: forall a2 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 = teeConsumers False getList (findsTrueIn s2) chunk
- >>= \(chunk, maybeFound)->
- if isJust maybeFound
- then maybe (return ()) (put edge) mb
- >> putList chunk true
- else putList 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
+ else putList 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 b1 b2. MonadParallel m => Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x b1
-havingOnly parallel s1 s2 = isolateSplitter s
- where s source true false edge = pipePS parallel
+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 binder s1 s2 = isolateSplitter s
+ where s :: forall a2 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 = teeConsumers False getList (findsFalseIn s2) chunk
- >>= \(chunk, anyFalse)->
- if anyFalse
- then putList chunk false
- else maybe (return ()) (put edge) mb
- >> putList chunk true
+ test (Just mb) chunk =
+ do chunkBuffer <- getList chunk
+ (_, anyFalse) <-
+ pipe (produce $ adaptProducer $ Producer $ putList chunkBuffer) (findsFalseIn s2)
+ if anyFalse
+ then putList chunkBuffer false
+ else maybe (return ()) (put edge) mb >> putList chunkBuffer true
+ return ()
-- | The result of combinator 'first' behaves the same as the argument splitter up to and including the first portion of
-- the input which goes into the argument's /true/ sink. All input following the first true portion goes into the
-- /false/ sink.
first :: forall m x b. Monad m => Splitter m x b -> Splitter m x b
first splitter = wrapMarkedSplitter splitter $
- \source true false edge->
- let split 1 (Left (x, False)) = put false x >> return 1
- split 1 (Left (x, True)) = put true x >> return 2
- split 1 (Right b) = put edge b >> return 2
- split 2 b@Right{} = return 3
- split 2 (Left (x, True)) = put true x >> return 2
- split 2 (Left (x, False)) = put false x >> return 3
- split 3 (Left (x, _)) = put false x >> return 3
- split 3 (Right _) = return 3
- in foldMStream_ split 1 source
+ \source true false edge->
+ 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 (mapSink (\(Left (x, True))-> x) true)
+ >> mapMaybeStream (either (Just . fst) (const Nothing)) 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
@@ -563,20 +543,15 @@
uptoFirst :: forall m x b. Monad m => Splitter m x b -> Splitter m x b
uptoFirst splitter = wrapMarkedSplitter splitter $
\source true false edge->
- let split (Left q) (Left (x, False)) = return (Left (q |> x))
- split (Left q) (Left (x, True)) = putQueue q true
- >> put true x
- >> return (Right True)
- split (Left q) (Right b) = putQueue q true
- >> put edge b
- >> return (Right True)
- split (Right True) Right{} = return (Right False)
- split (Right True) (Left (x, True)) = put true x >> return (Right True)
- split (Right True) (Left (x, False)) = put false x >> return (Right False)
- split (Right False) (Left (x, _)) = put false x >> return (Right False)
- split (Right False) (Right _) = return (Right False)
- in foldMStream split (Left Seq.empty) source
- >>= either (flip putQueue false) (const $ return ())
+ do (prefix, mx) <- getUntil (either snd (const True)) source
+ let prefix' = map (\(Left (x, False))-> x) prefix
+ 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 (mapSink (\(Left (x, True))-> x) true)
+ >> mapMaybeStream (either (Just . fst) (const Nothing)) source false)
+ mx
-- | The result of the combinator 'last' is a splitter which directs all input to its /false/ sink, up to the last
-- portion of the input which goes to its argument's /true/ sink. That portion of the input is the only one that goes to
@@ -584,93 +559,72 @@
-- portions of its input, because it cannot know if a true portion of the input is the last one until it sees the end of
-- the input or another portion succeeding the previous one.
last :: forall m x b. Monad m => Splitter m x b -> Splitter m x b
-last splitter = wrapMarkedSplitter splitter $
- \source true false edge->
- let get1 (Left (x, False)) = put false x
- >> getWith get1 source
- get1 p@(Left (x, True)) = get2 Nothing Seq.empty p
- get1 (Right b) = getWith (get2 (Just b) Seq.empty) source
- get2 mb q (Left (x, True)) = let q' = q |> x
- in get source
- >>= maybe
- (flush mb q')
- (get2 mb q')
- get2 mb q p = get3 mb q Seq.empty p
- get3 mb qt qf (Left (x, False)) =
- let qf' = qf |> x
- in get source
- >>= maybe
- (flush mb qt >> putQueue qf' false)
- (get3 mb qt qf')
- get3 mb qt qf p = do putQueue qt false
- putQueue qf false
- get1 p
- flush mb q = maybe (return ()) (put edge) mb
- >> putQueue q true
- in getWith get1 source
+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 (x, 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 mb (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 mb ts (fs, x@Just{}) = putList ts false' >> putList fs false' >> split1 x
+ in pourUntil (either snd (const True)) source false' >>= split1 >> return ()
-- | The result of the combinator 'lastAndAfter' is a splitter which directs all input to its /false/ sink, up to the
-- last portion of the input which goes to its argument's /true/ sink. That portion and the remainder of the input is
-- fed to the resulting component's /true/ sink. The difference between 'last' and 'lastAndAfter' combinators is where
-- they feed the /false/ portion of the input, if any, remaining after the last /true/ part.
lastAndAfter :: forall m x b. Monad m => Splitter m x b -> Splitter m x b
-lastAndAfter splitter = wrapMarkedSplitter splitter $
- \source true false edge->
- let get1 (Left (x, False)) = put false x
- >> getWith get1 source
- get1 p@(Left (x, True)) = get2 Nothing Seq.empty p
- get1 (Right b) = getWith (get2 (Just b) Seq.empty) source
- get2 mb q (Left (x, True)) = let q' = q |> x
- in get source
- >>= maybe
- (flush mb q')
- (get2 mb q')
- get2 mb q p = get3 mb q p
- get3 mb q (Left (x, False)) = let q' = q |> x
- in get source
- >>= maybe
- (flush mb q')
- (get3 mb q')
- get3 _ q p@(Left (x, True)) = putQueue q false
- >> get1 p
- get3 _ q b'@Right{} = putQueue q false
- >> get1 b'
- flush mb q = maybe (return ()) (put edge) mb
- >> putQueue q true
- in getWith get1 source
+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 (x, 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 mb (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 mb ts (fs, x@Just{}) = putList ts false' >> putList fs false' >> split1 x
+ in pourUntil (either snd (const True)) source false' >>= split1 >> return ()
-- | The 'prefix' combinator feeds its /true/ sink only the prefix of the input that its argument feeds to its /true/
-- sink. All the rest of the input is dumped into the /false/ sink of the result.
prefix :: forall m x b. Monad m => Splitter m x b -> Splitter m x b
prefix splitter = wrapMarkedSplitter splitter $
\source true false edge->
- let split 0 p@Left{} = split 1 p
- split 0 (Right b) = put edge b >> return 1
- split 1 (Left (x, False)) = put false x >> return 2
- split 1 (Left (x, True)) = put true x >> return 1
- split 1 (Right b) = return 2
- split 2 (Left (x, _)) = put false x >> return 2
- split 2 Right{} = return 2
- in foldMStream_ split 0 source
+ peek source
+ >>= maybe
+ (return ())
+ (\x-> either (return . snd) (\x-> put edge x >> get source >> return True) x
+ >>= flip when (pourWhile (either snd (const False))
+ source
+ (mapSink (\(Left (x, True))-> x) true))
+ >> mapMaybeStream (either (Just . fst) (const Nothing)) 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 splitter = wrapMarkedSplitter splitter $
- \source true false edge->
- let split Nothing (Left (x, False)) = put false x >> return Nothing
- split Nothing (Left (x, True)) = return (Just (Nothing, Seq.singleton x))
- split Nothing (Right b) = return (Just (Just b, Seq.empty))
- split (Just (mb, q)) (Left (x, True)) = return (Just (mb, q |> x))
- split (Just (mb, q)) (Left (x, False)) = putQueue q false
- >> put false x
- >> return Nothing
- split (Just (mb, q)) (Right b) = putQueue q false
- >> return (Just (Just b, Seq.empty))
- in foldMStream split Nothing source
- >>= \r-> case r of Nothing -> return ()
- Just (Nothing, q) -> putQueue q true
- Just (Just b, q) -> put edge b >> putQueue q true
+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 (x, 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{}) = putList trues false' >> split0
+ in split0 >> return ()
-- | 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
@@ -697,109 +651,119 @@
startOf :: forall m x b. Monad m => Splitter m x b -> Splitter m x (Maybe b)
startOf splitter = wrapMarkedSplitter splitter $
\source true false edge->
- let split 1 (Left (x, False)) = put false x >> return 1
- split 1 p@(Left (x, True)) = put edge Nothing >> split 2 p
- split 1 (Right b) = put edge (Just b) >> return 2
- split 2 (Left (x, True)) = put false x >> return 2
- split 2 p = split 1 p
- in foldMStream_ split 1 source
+ 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 (x, 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
+ split3 Nothing = return ()
+ split3 (Just (Left (x, False))) = split0
+ split3 mb@(Just Right{}) = split1 mb
+ 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 splitter = wrapMarkedSplitter splitter $
\source true false edge->
- let split Nothing (Left (x, False)) = put false x >> return Nothing
- split Nothing p@(Left (x, True)) = split (Just Nothing) p
- split Nothing (Right b) = return (Just (Just b))
- split (Just mb) (Left (x, True)) = put false x >> return (Just mb)
- split (Just mb) p@(Left (x, False)) = put edge mb >> split Nothing p
- split (Just mb) (Right b) = put edge mb >> return (Just $ Just b)
- in foldMStream split Nothing source >>= maybe (return ()) (put edge)
+ 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 (x, 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
+ split3 Nothing = return ()
+ split3 (Just (Left (x, False))) = split0
+ split3 mb@(Just Right{}) = split1 mb
+ 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. MonadParallel m =>
- Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)
-followedBy parallel s1 s2 =
+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 ->
- pipePS parallel
+ pipeG binder
(transduce (splitterToMarker s1) source)
(\source-> let get0 q = case Seq.viewl q
- of Seq.EmptyL -> getWith get1 source
+ of Seq.EmptyL -> split0
(Left (x, False)) :< rest -> put false x
>> get0 rest
(Left (x, True)) :< rest -> get2 Nothing Seq.empty q
(Right b) :< rest -> get2 (Just b) Seq.empty rest
- get1 (Left (x, False)) = put false x
- >> getWith get1 source
- get1 p@(Left (x, True)) = get2 Nothing Seq.empty (Seq.singleton p)
- get1 (Right b) = get2 (Just b) Seq.empty Seq.empty
+ 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 (x, False)) :< rest -> get3 mb q q'
Right{} :< rest -> get3 mb q q'
- get3 mb q q' = do ((q1, q2), n) <- pipe (get7 Seq.empty q') (test mb q)
- case n of Nothing -> putQueue q false
- >> get0 (q1 >< q2)
- Just 0 -> get0 (q1 >< q2)
- Just n -> get8 (Just mb) n (q1 >< q2)
- get7 q1 q2 sink = case Seq.viewl q2
- of Seq.EmptyL -> get source
- >>= maybe (return (q1, q2))
- (\p-> either
- (put sink . fst)
- (const $ return ())
- p
- >> get7 (q1 |> p) q2 sink)
- p :< rest -> either
- (put sink . fst)
- (const $ return ()) p
- >> get7 (q1 |> p) rest sink
+ get3 mb q q' = do let list = mapMaybe
+ (either (Just . fst) (const Nothing))
+ (Foldable.toList $ Seq.viewl q')
+ (q'', n) <- pipe (\sink-> putList list sink >> get7 q' sink) (test mb q)
+ case n 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
+ case n of Nothing -> putQueue q false >> return ()
_ -> return ()
test mb q source = liftM snd $
pipe
(transduce (splitterToMarker s2) source)
- (\source-> let get4 (Left (_, False)) = return Nothing
- get4 p@(Left (_, True)) = putQueue q true
- >> get5 0 p
- get4 p@(Right b) = maybe
- (return ())
- (\b1-> put edge (b1, b))
+ (\source-> let test0 (Left (_, False)) = get source >> return Nothing
+ test0 (Left (_, True)) = test1
+ test0 (Right b') = maybe
+ (return ())
+ (\b-> put edge (b, b'))
mb
- >> putQueue q true
- >> get6 0
- get5 n (Left (x, True)) = put true x
- >> get6 (succ n)
- get5 n _ = return (Just n)
- get6 n = get source
- >>= maybe
- (return $ Just n)
- (get5 n)
- in get source >>= maybe (return Nothing) get4)
+ >> 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 (x, False) :< rest -> get8 Nothing (pred n) rest
Left (x, True) :< rest
-> get8 (maybe (Just Nothing) Just mmb) (pred n) rest
Right b :< rest -> get8 (Just (Just b)) n rest
- in get0 Seq.empty)
+ in split0)
>> return ()
--- | Combinator '...' tracks the running balance of difference between the number of preceding starts of sections
+-- | 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. MonadParallel m => Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x b1
-between parallel s1 s2 = isolateSplitter $ \ source true false edge ->
- pipePS parallel
- (transduce (splittersToPairMarker parallel s1 s2) source)
+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)
@@ -835,12 +799,13 @@
(mapSink (\x-> Left (x, False)) sink)
(mapSink Right sink)
-splittersToPairMarker :: forall m x b1 b2. (MonadParallel m) => Bool -> Splitter m x b1 -> Splitter m x b2 ->
+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 parallel s1 s2 =
- let t source sink =
+splittersToPairMarker binder s1 s2 =
+ let t :: forall d. Functor d => Source m d x -> Sink m d (Either (x, Bool, Bool) (Either b1 b2)) -> Coroutine d m ()
+ t source sink =
pipe
- (\sync-> teeConsumers parallel
+ (\sync-> teeConsumers binder
(\source1-> split s1 source1
(mapSink (\x-> Left ((x, True), True)) sync)
(mapSink (\x-> Left ((x, False), True)) sync)
@@ -855,8 +820,8 @@
synchronizeMarks :: forall m a1 a2 d. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d) =>
Sink m a1 (Either (x, Bool, Bool) (Either b1 b2))
-> Source m a2 (Either ((x, Bool), Bool) (Either b1 b2))
- -> Coroutine d m ()
- synchronizeMarks sink source = foldMStream handleMark Nothing source >>= \Nothing-> return () where
+ -> Coroutine d m (Maybe (Seq (Either (x, Bool) (Either b1 b2)), Bool))
+ synchronizeMarks sink source = foldMStream handleMark Nothing source where
handleMark Nothing (Right b) = put sink (Right b) >> return Nothing
handleMark Nothing (Left (p, first)) = return (Just (Seq.singleton (Left p), first))
handleMark state@(Just (q, first)) (Left (p, first')) | first == first' = return (Just (q |> Left p, first))
@@ -870,20 +835,19 @@
>> handleMark (if Seq.null rest then Nothing else Just (rest, pos')) mark
Left (y, t') :< rest -> put sink (Left $ if pos then (y, t, t') else (y, t', t))
>> return (if Seq.null rest then Nothing else Just (rest, pos'))
- returnQueuedList q = return $ concatMap (either ((:[]) . fst) (const [])) $ Foldable.toList $ Seq.viewl q
in isolateTransducer t
-zipSplittersWith :: forall m x b1 b2 b. MonadParallel m =>
+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 ()) ->
- Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x b
-zipSplittersWith f boundaries parallel s1 s2
+ 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->
- pipePS parallel
- (transduce (splittersToPairMarker parallel s1 s2) source)
+ 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)
@@ -897,23 +861,21 @@
Source m a (Either (x, Bool) b) ->
(Maybe (Maybe b) -> Source m (SourceFunctor d x) x -> Coroutine (SourceFunctor d x) m r) ->
Coroutine d m ()
-groupMarks source getConsumer = start
- where start = getWith (either startContent startRegion) source
- startContent (x, False) = pipe (\sink-> pass False sink x) (getConsumer Nothing)
- >>= maybe (return ()) (either startContent startRegion) . fst
- startContent (x, True) = pipe (\sink-> pass True sink x) (getConsumer $ Just Nothing)
- >>= maybe (return ()) (either startContent startRegion) . fst
- startRegion b = pipe (next True) (getConsumer (Just $ Just b))
- >>= maybe (return ()) (either startContent startRegion) . fst
- pass t sink x = put sink x >> next t sink
- next t sink = get source >>= maybe (return Nothing) (continue t sink)
- continue t sink (Left (x, t')) | t == t' = pass t sink x
- continue t sink p = return (Just p)
+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 (\(x, t')-> t /= t') (const True)) source (mapSink (\(Left (x, t))-> x) sink)
-- | 'suppressProducer' runs the /producer/ argument with a new sink, suppressing everything 'put' in the sink.
suppressProducer :: forall m a x r. (Functor a, Monad m) => (Sink m a x -> Coroutine a m r) -> Coroutine a m r
suppressProducer producer = producer (nullSink :: Sink m a x)
+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)
+
findsTrueIn :: forall m a d x b. (Monad m, AncestorFunctor a d)
=> Splitter m x b -> Source m a x -> Coroutine d m (Maybe (Maybe b))
findsTrueIn splitter source = pipe
@@ -937,11 +899,28 @@
get
>>= \((), maybeFalse)-> return (isJust maybeFalse)
-teeConsumers :: forall m a d x r1 r2. MonadParallel m
- => Bool -> (forall a. OpenConsumer m a (SinkFunctor d x) x r1)
+teeConsumers :: forall m a d x r1 r2. Monad m
+ => PairBinder m -> (forall a. OpenConsumer m a (SinkFunctor d x) x r1)
-> (forall a. OpenConsumer m a (SourceFunctor d x) x r2)
-> OpenConsumer m a d x (r1, r2)
-teeConsumers parallel c1 c2 source = pipePS parallel consume1 c2
+teeConsumers binder c1 c2 source = pipeG binder consume1 c2
where consume1 sink = c1 (teeSource sink source' :: Source m (SinkFunctor d x) x)
source' :: Source m d x
+ source' = liftSource source
+
+-- | 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 ->
+ (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))
+ trueConsumer)
+ falseConsumer
+ >> return ()
+ where source' :: Source m d x
source' = liftSource source
diff --git a/Control/Concurrent/SCC/Combinators/Parallel.hs b/Control/Concurrent/SCC/Combinators/Parallel.hs
new file mode 100644
--- /dev/null
+++ b/Control/Concurrent/SCC/Combinators/Parallel.hs
@@ -0,0 +1,175 @@
+{-
+ Copyright 2010 Mario Blazevic
+
+ This file is part of the Streaming Component Combinators (SCC) project.
+
+ The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public
+ License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later
+ version.
+
+ SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty
+ of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License along with SCC. If not, see
+ .
+-}
+
+{-# LANGUAGE Rank2Types, FlexibleContexts #-}
+{-# OPTIONS_HADDOCK hide #-}
+
+-- | This module exports parallel versions of the combinators from the "Control.Concurrent.SCC.Combinators" module.
+
+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,
+ -- * Splitter combinators
+ Combinators.sNot,
+ -- ** Pseudo-logic flow combinators
+ -- | Combinators '>&' and '>|' are only /pseudo/-logic. While the laws of double negation and De Morgan's laws
+ -- hold, 'sAnd' and 'sOr' are in general not commutative, associative, nor idempotent. In the special case when all
+ -- argument splitters are stateless, such as those produced by 'Control.Concurrent.SCC.Types.statelessSplitter',
+ -- these combinators do satisfy all laws of Boolean algebra.
+ (>&), (>|),
+ -- ** Zipping logic combinators
+ -- | The '&&' and '||' combinators run the argument splitters in parallel and combine their logical outputs using
+ -- the corresponding logical operation on each output pair, in a manner similar to 'Data.List.zipWith'. They fully
+ -- satisfy the laws of Boolean algebra.
+ (&&), (||),
+ -- * Flow-control combinators
+ -- | The following combinators resemble the common flow-control programming language constructs. Combinators
+ -- 'wherever', 'unless', and 'select' are just the special cases of the combinator 'ifs'.
+ --
+ -- * /transducer/ ``wherever`` /splitter/ = 'ifs' /splitter/ /transducer/ 'Control.Category.id'
+ --
+ -- * /transducer/ ``unless`` /splitter/ = 'ifs' /splitter/ 'Control.Category.id' /transducer/
+ --
+ -- * 'select' /splitter/ = 'ifs' /splitter/ 'Control.Category.id'
+ -- 'Control.Concurrent.SCC.Primitives.suppress'
+ --
+ ifs, wherever, unless, Combinators.select,
+ -- ** Recursive
+ while, nestedIn,
+ -- * Section-based combinators
+ -- | All combinators in this section use their 'Control.Concurrent.SCC.Splitter' argument to determine the structure
+ -- of the input. Every contiguous portion of the input that gets passed to one or the other sink of the splitter is
+ -- treated as one section in the logical structure of the input stream. What is done with the section depends on the
+ -- combinator, but the sections, and therefore the logical structure of the input stream, are determined by the
+ -- argument splitter alone.
+ foreach, having, havingOnly, followedBy, Combinators.even,
+ -- ** first and its variants
+ Combinators.first, Combinators.uptoFirst, Combinators.prefix,
+ -- ** last and its variants
+ Combinators.last, Combinators.lastAndAfter, Combinators.suffix,
+ -- ** positional splitters
+ Combinators.startOf, Combinators.endOf, (...),
+ -- * Parser support
+ Combinators.splitterToMarker, Combinators.parseRegions, Combinators.parseNestedRegions, parseEachNestedRegion,
+ )
+where
+
+import Prelude hiding ((&&), (||), even, last, sequence)
+import Data.Text (Text)
+
+import Control.Monad.Parallel (MonadParallel)
+import Control.Monad.Coroutine (parallelBinder)
+import Control.Concurrent.SCC.Types
+import Control.Concurrent.SCC.Coercions (Coercible)
+import qualified Control.Concurrent.SCC.Combinators as Combinators
+import qualified Control.Concurrent.SCC.XML as XML
+
+-- | 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.
+(>->) :: (MonadParallel m, Combinators.PipeableComponentPair m w c1 c2 c3) => c1 -> c2 -> c3
+(>->) = Combinators.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
+join = Combinators.join parallelBinder
+
+-- | 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)
+(>&) = 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)
+(>|) = 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)
+(&&) = 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)
+(||) = Combinators.pOr parallelBinder
+
+ifs :: (MonadParallel m, Branching c m x ()) => Splitter m x b -> c -> c -> c
+ifs = Combinators.ifs parallelBinder
+
+wherever :: MonadParallel m => Transducer m x x -> Splitter m x b -> Transducer m x x
+wherever = Combinators.wherever parallelBinder
+
+unless :: MonadParallel m => Transducer m x x -> Splitter m x b -> 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 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
+-- splitter. The true sink of one of the argument splitters and false sink of the other become the true and false sinks
+-- of the loop. The other two sinks are bound to the other splitter's source. The use of 'nestedIn' makes sense only on
+-- hierarchically structured streams. If we gave it some input containing a flat sequence of values, and assuming both
+-- component splitters are deterministic and stateless, an input value would either not loop at all or it would loop
+-- forever.
+nestedIn :: MonadParallel m => Splitter m x b -> Splitter m x b -> Splitter m x b
+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
+-- 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 :: (MonadParallel m, Branching c m x ()) => Splitter m x b -> 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
+-- 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 :: (MonadParallel m, Coercible x y) => Splitter m x b1 -> Splitter m y b2 -> Splitter m x b1
+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 = 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 = 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
+(...) = Combinators.between parallelBinder
diff --git a/Control/Concurrent/SCC/Combinators/Sequential.hs b/Control/Concurrent/SCC/Combinators/Sequential.hs
new file mode 100644
--- /dev/null
+++ b/Control/Concurrent/SCC/Combinators/Sequential.hs
@@ -0,0 +1,174 @@
+{-
+ Copyright 2010 Mario Blazevic
+
+ This file is part of the Streaming Component Combinators (SCC) project.
+
+ The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public
+ License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later
+ version.
+
+ SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty
+ of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License along with SCC. If not, see
+ .
+-}
+
+{-# LANGUAGE Rank2Types, FlexibleContexts #-}
+{-# OPTIONS_HADDOCK hide #-}
+
+-- | This module exports sequential versions of the combinators from the "Control.Concurrent.SCC.Combinators" module.
+
+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,
+ -- * Splitter combinators
+ Combinators.sNot,
+ -- ** Pseudo-logic flow combinators
+ -- | Combinators '>&' and '>|' are only /pseudo/-logic. While the laws of double negation and De Morgan's laws
+ -- hold, 'sAnd' and 'sOr' are in general not commutative, associative, nor idempotent. In the special case when all
+ -- argument splitters are stateless, such as those produced by 'Control.Concurrent.SCC.Types.statelessSplitter',
+ -- these combinators do satisfy all laws of Boolean algebra.
+ (>&), (>|),
+ -- ** Zipping logic combinators
+ -- | The '&&' and '||' combinators run the argument splitters in parallel and combine their logical outputs using
+ -- the corresponding logical operation on each output pair, in a manner similar to 'Data.List.zipWith'. They fully
+ -- satisfy the laws of Boolean algebra.
+ (&&), (||),
+ -- * Flow-control combinators
+ -- | The following combinators resemble the common flow-control programming language constructs. Combinators
+ -- 'wherever', 'unless', and 'select' are just the special cases of the combinator 'ifs'.
+ --
+ -- * /transducer/ ``wherever`` /splitter/ = 'ifs' /splitter/ /transducer/ 'Control.Category.id'
+ --
+ -- * /transducer/ ``unless`` /splitter/ = 'ifs' /splitter/ 'Control.Category.id' /transducer/
+ --
+ -- * 'select' /splitter/ = 'ifs' /splitter/ 'Control.Category.id'
+ -- 'Control.Concurrent.SCC.Primitives.suppress'
+ --
+ ifs, wherever, unless, Combinators.select,
+ -- ** Recursive
+ while, nestedIn,
+ -- * Section-based combinators
+ -- | All combinators in this section use their 'Control.Concurrent.SCC.Splitter' argument to determine the structure
+ -- of the input. Every contiguous portion of the input that gets passed to one or the other sink of the splitter is
+ -- treated as one section in the logical structure of the input stream. What is done with the section depends on the
+ -- combinator, but the sections, and therefore the logical structure of the input stream, are determined by the
+ -- argument splitter alone.
+ foreach, having, havingOnly, followedBy, Combinators.even,
+ -- ** first and its variants
+ Combinators.first, Combinators.uptoFirst, Combinators.prefix,
+ -- ** last and its variants
+ Combinators.last, Combinators.lastAndAfter, Combinators.suffix,
+ -- ** positional splitters
+ Combinators.startOf, Combinators.endOf, (...),
+ -- * Parser support
+ Combinators.splitterToMarker, Combinators.parseRegions, Combinators.parseNestedRegions, parseEachNestedRegion,
+ )
+where
+
+import Prelude hiding ((&&), (||), even, last, sequence)
+import Data.Text (Text)
+
+import Control.Monad.Coroutine (sequentialBinder)
+import Control.Concurrent.SCC.Types
+import Control.Concurrent.SCC.Coercions (Coercible)
+import qualified Control.Concurrent.SCC.Combinators as Combinators
+import qualified Control.Concurrent.SCC.XML as XML
+
+-- | 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.
+(>->) :: (Monad m, Combinators.PipeableComponentPair m w c1 c2 c3) => c1 -> c2 -> c3
+(>->) = Combinators.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
+join = Combinators.join sequentialBinder
+
+-- | 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)
+(>&) = 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)
+(>|) = 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)
+(&&) = 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)
+(||) = Combinators.pOr sequentialBinder
+
+ifs :: (Monad m, Branching c m x ()) => Splitter m x b -> c -> c -> c
+ifs = Combinators.ifs sequentialBinder
+
+wherever :: Monad m => Transducer m x x -> Splitter m x b -> Transducer m x x
+wherever = Combinators.wherever sequentialBinder
+
+unless :: Monad m => Transducer m x x -> Splitter m x b -> 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 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
+-- splitter. The true sink of one of the argument splitters and false sink of the other become the true and false sinks
+-- of the loop. The other two sinks are bound to the other splitter's source. The use of 'nestedIn' makes sense only on
+-- hierarchically structured streams. If we gave it some input containing a flat sequence of values, and assuming both
+-- component splitters are deterministic and stateless, an input value would either not loop at all or it would loop
+-- forever.
+nestedIn :: Monad m => Splitter m x b -> Splitter m x b -> Splitter m x b
+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
+-- 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 :: (Monad m, Branching c m x ()) => Splitter m x b -> 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
+-- 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 :: (Monad m, Coercible x y) => Splitter m x b1 -> Splitter m y b2 -> Splitter m x b1
+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 = 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 = 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
+(...) = Combinators.between sequentialBinder
diff --git a/Control/Concurrent/SCC/Components.hs b/Control/Concurrent/SCC/Components.hs
deleted file mode 100644
--- a/Control/Concurrent/SCC/Components.hs
+++ /dev/null
@@ -1,491 +0,0 @@
-{-
- Copyright 2008-2010 Mario Blazevic
-
- This file is part of the Streaming Component Combinators (SCC) project.
-
- The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public
- License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later
- version.
-
- SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty
- of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License along with SCC. If not, see
- .
--}
-
-{-# LANGUAGE ScopedTypeVariables, Rank2Types, KindSignatures, EmptyDataDecls,
- MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, FunctionalDependencies, TypeFamilies #-}
-
--- | The "Components" module defines thin wrappers around the 'Transducer' and 'Splitter' primitives and combinators,
--- relying on the "Control.Concurrent.SCC.ComponentTypes" module.
-
-module Control.Concurrent.SCC.Components where
-
-import Control.Monad.Coroutine
-import Control.Monad.Parallel (MonadParallel(..))
-
-import Control.Concurrent.SCC.Types
-import Control.Concurrent.SCC.Types as Types
-import qualified Control.Concurrent.SCC.Combinators as Combinator
-import qualified Control.Concurrent.SCC.Primitives as Primitive
-import qualified Control.Concurrent.SCC.XML as XML
-import Control.Concurrent.SCC.Primitives (OccurenceTag)
-import Control.Concurrent.SCC.XML (Token)
-import Control.Concurrent.Configuration
-
-import Prelude hiding (appendFile, even, id, last, sequence, (||), (&&))
-import qualified Control.Category
-import Control.Monad (liftM)
-
-import System.IO (Handle)
-
--- | A component that performs a computation with no inputs nor outputs is a 'PerformerComponent'.
-type PerformerComponent m r = Component (Performer m r)
-
--- | A component that consumes values from a 'Source' is called 'ConsumerComponent'.
-type ConsumerComponent m x r = Component (Consumer m x r)
-
--- | A component that produces values and puts them into a 'Sink' is called 'ProducerComponent'.
-type ProducerComponent m x r = Component (Producer m x r)
-
--- | The 'TransducerComponent' type represents computations that transform a data stream.
-type TransducerComponent m x y = Component (Transducer m x y)
-
-type ParserComponent m x y = Component (Parser m x y)
-
--- | The 'SplitterComponent' type represents computations that distribute data acording to some criteria. A splitter
--- should distribute only the original input data, and feed it into the sinks in the same order it has been read from
--- the source. If the two 'Sink 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)
-
--- | The constant cost of each I/O-performing component.
-ioCost :: Int
-ioCost = 5
-
--- | ConsumerComponent 'toList' copies the given source into a list.
-toList :: forall m x. Monad m => ConsumerComponent m x [x]
-toList = atomic "toList" 1 Primitive.toList
-
--- | 'fromList' produces the contents of the given list argument.
-fromList :: forall m x. Monad m => [x] -> ProducerComponent m x ()
-fromList l = atomic "fromList" 1 (Primitive.fromList l)
-
--- | ConsumerComponent 'toStdOut' copies the given source into the standard output.
-toStdOut :: ConsumerComponent IO Char ()
-toStdOut = atomic "toStdOut" ioCost Primitive.toStdOut
-
--- | ProducerComponent 'fromStdIn' feeds the given sink from the standard input.
-fromStdIn :: ProducerComponent IO Char ()
-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 path = atomic "fromFile" ioCost (Primitive.fromFile path)
-
--- | ProducerComponent 'fromHandle' feeds the given sink from the open file /handle/. The argument /doClose/ determines
--- | if /handle/ should be closed when the handle is consumed or the sink closed.
-fromHandle :: Handle -> Bool -> ProducerComponent IO Char ()
-fromHandle handle doClose = atomic "fromHandle" ioCost (Primitive.fromHandle handle doClose)
-
--- | ConsumerComponent 'toFile' opens the named file and copies the given source into it.
-toFile :: String -> ConsumerComponent IO Char ()
-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 path = atomic "appendFile" ioCost (Primitive.appendFile path)
-
--- | ConsumerComponent 'toHandle' copies the given source into the open file /handle/. The argument /doClose/ determines
--- | if /handle/ should be closed once the entire source is consumed and copied.
-toHandle :: Handle -> Bool -> ConsumerComponent IO Char ()
-toHandle handle doClose = atomic "toHandle" ioCost (Primitive.toHandle handle doClose)
-
--- | TransducerComponent 'id' passes its input through unmodified.
-id :: forall m x. Monad m => TransducerComponent m x x
-id = atomic "id" 1 Control.Category.id
-
--- | TransducerComponent 'unparse' removes all markup from its input and passes the content through.
-unparse :: forall m x y. Monad m => TransducerComponent m (Markup y x) x
-unparse = atomic "unparse" 1 Primitive.unparse
-
--- | TransducerComponent 'parse' prepares input content for subsequent parsing.
-parse :: forall m x y. Monad m => TransducerComponent m x (Markup y x)
-parse = atomic "parse" 1 Primitive.parse
-
--- | The 'suppress' consumer suppresses all input it receives. It is equivalent to 'substitute' []
-suppress :: forall m x y. Monad m => ConsumerComponent m x ()
-suppress = atomic "suppress" 1 Primitive.suppress
-
--- | The 'erroneous' consumer reports an error if any input reaches it.
-erroneous :: forall m x. Monad m => String -> ConsumerComponent m x ()
-erroneous message = atomic "erroneous" 0 (Primitive.erroneous message)
-
--- | The 'lowercase' transforms all uppercase letters in the input to lowercase, leaving the rest unchanged.
-lowercase :: forall m. Monad m => TransducerComponent m Char Char
-lowercase = atomic "lowercase" 1 Primitive.lowercase
-
--- | The 'uppercase' transforms all lowercase letters in the input to uppercase, leaving the rest unchanged.
-uppercase :: forall m. Monad m => TransducerComponent m Char Char
-uppercase = atomic "uppercase" 1 Primitive.uppercase
-
--- | The 'count' transducer counts all its input values and outputs the final tally.
-count :: forall m x. Monad m => TransducerComponent m x Integer
-count = atomic "count" 1 Primitive.count
-
--- | Converts each input value @x@ to @show x@.
-toString :: forall m x. (Monad m, Show x) => TransducerComponent m x String
-toString = atomic "toString" 1 Primitive.toString
-
--- | TransducerComponent 'group' collects all its input values into a single list.
-group :: forall m x. Monad m => 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 :: forall m x. Monad m => 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 :: forall m x. Monad m => [x] -> TransducerComponent m [x] x
-concatSeparate separator = atomic "concatSeparate" 1 (Primitive.concatSeparate separator)
-
--- | SplitterComponent 'whitespace' feeds all white-space characters into its /true/ sink, all others into /false/.
-whitespace :: forall m. Monad m => SplitterComponent m Char ()
-whitespace = atomic "whitespace" 1 Primitive.whitespace
-
--- | SplitterComponent 'letters' feeds all alphabetical characters into its /true/ sink, all other characters into
--- | /false/.
-letters :: forall m. Monad m => SplitterComponent m Char ()
-letters = atomic "letters" 1 Primitive.letters
-
--- | SplitterComponent 'digits' feeds all digits into its /true/ sink, all other characters into /false/.
-digits :: forall m. Monad m => SplitterComponent m Char ()
-digits = atomic "digits" 1 Primitive.digits
-
--- | SplitterComponent 'nonEmptyLine' feeds line-ends into its /false/ sink, and all other characters into /true/.
-nonEmptyLine :: forall m. Monad m => SplitterComponent m Char ()
-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 :: forall m. Monad m => SplitterComponent m Char ()
-line = atomic "line" 1 Primitive.line
-
--- | SplitterComponent 'everything' feeds its entire input into its /true/ sink.
-everything :: forall m x. Monad m => SplitterComponent m x ()
-everything = atomic "everything" 1 Primitive.everything
-
--- | SplitterComponent 'nothing' feeds its entire input into its /false/ sink.
-nothing :: forall m x. Monad m => SplitterComponent m x ()
-nothing = atomic "nothing" 1 Primitive.nothing
-
--- | SplitterComponent 'one' feeds all input values to its /true/ sink, treating every value as a separate section.
-one :: forall m x. Monad m => SplitterComponent m x ()
-one = atomic "one" 1 Primitive.one
-
--- | SplitterComponent '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) => 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 :: forall m x y. (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 :: forall m x y. (Monad m, Eq y) => (y -> Bool) -> SplitterComponent m (Markup y x) ()
-markedWith select = atomic "markedWith" 1 (Primitive.markedWith select)
-
--- | 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 :: forall m x y. (Monad m, Eq y) => (y -> Bool) -> SplitterComponent m (Markup y x) ()
-contentMarkedWith select = atomic "contentMarkedWith" 1 (Primitive.contentMarkedWith select)
-
--- | Performs the same task as the 'substring' splitter, but instead of splitting it outputs the input as @'Markup' x
--- 'OccurenceTag'@ in order to distinguish overlapping strings.
-parseSubstring :: forall m x y. (Monad m, Eq x) => [x] -> ParserComponent m x OccurenceTag
-parseSubstring list = atomic "parseSubstring" 1 (Primitive.parseSubstring list)
-
--- | 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 :: forall m x. (Monad m, Eq x) => [x] -> SplitterComponent m x ()
-substring list = atomic "substring" 1 (Primitive.substring list)
-
--- | Converts a 'ConsumerComponent' into a 'TransducerComponent' with no output.
-consumeBy :: forall m x y r. (Monad m) => ConsumerComponent m x r -> TransducerComponent m x y
-consumeBy = lift 1 "consumeBy" Combinator.consumeBy
-
--- | 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.
-
-(>->) :: Combinator.PipeableComponentPair m w c1 c2 c3 => Component c1 -> Component c2 -> Component c3
-(>->) = liftParallelPair ">->" Combinator.compose
-
-class CompatibleSignature c cons (m :: * -> *) input output | c -> cons m
-
-class AnyListOrUnit c
-
-instance AnyListOrUnit [x]
-instance AnyListOrUnit ()
-
-instance (AnyListOrUnit x, AnyListOrUnit y) => CompatibleSignature (Performer m r) (PerformerType r) m x y
-instance AnyListOrUnit y => CompatibleSignature (Consumer m x r) (ConsumerType r) m [x] y
-instance AnyListOrUnit y => CompatibleSignature (Producer m x r) (ProducerType r) m y [x]
-instance CompatibleSignature (Transducer m x y) TransducerType m [x] [y]
-
-data PerformerType r
-data ConsumerType r
-data ProducerType r
-data TransducerType
-
--- | Class 'JoinableComponentPair' applies to any two components that can be combined into a third component with the
--- following properties:
---
--- * if both argument components consume input, the input of the combined component gets distributed to both
--- components in parallel,
---
--- * if both argument components produce output, the output of the combined component is a concatenation of the
--- complete output from the first component followed by the complete output of the second component, and
---
--- * the 'join' method may apply the components in any order, the 'sequence' method makes sure its first argument
--- has completed before using the second one.
-join :: Combinator.JoinableComponentPair t1 t2 t3 m x y c1 c2 c3 => Component c1 -> Component c2 -> Component c3
-join = liftParallelPair "join" Combinator.join
-
-sequence :: Combinator.JoinableComponentPair t1 t2 t3 m x y c1 c2 c3 => Component c1 -> Component c2 -> Component c3
-sequence = 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 :: forall m x r. (Monad m) => ProducerComponent m x r -> TransducerComponent m x x
-prepend = 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 :: forall m x r. (Monad m) => ProducerComponent m x r -> TransducerComponent m x x
-append = 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 :: forall m x y r. (Monad m) => ProducerComponent m y r -> TransducerComponent m x y
-substitute = lift 1 "substitute" Combinator.substitute
-
--- | The 'snot' (streaming not) combinator simply reverses the outputs of the argument splitter. In other words, data
--- that the argument splitter sends to its /true/ sink goes to the /false/ sink of the result, and vice versa.
-snot :: forall m x b. Monad m => SplitterComponent m x b -> SplitterComponent m x b
-snot = lift 1 "not" Combinator.sNot
-
--- | 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 =>
- SplitterComponent m x b1 -> SplitterComponent m x b2 -> SplitterComponent m x (b1, b2)
-(>&) = liftParallelPair ">&" Combinator.sAnd
-
--- | A '>|' combinator's input value can reach its /false/ sink only by going through both argument splitters' /false/
--- sinks.
-(>|) :: forall m x b1 b2. MonadParallel m =>
- SplitterComponent m x b1 -> SplitterComponent m x b2 -> SplitterComponent m x (Either b1 b2)
-(>|) = liftParallelPair ">&" Combinator.sOr
-
--- | Combinator '&&' is a pairwise logical conjunction of two splitters run in parallel on the same input.
-(&&) :: forall m x b1 b2. MonadParallel m =>
- SplitterComponent m x b1 -> SplitterComponent m x b2 -> SplitterComponent m x (b1, b2)
-(&&) = liftParallelPair "&&" Combinator.pAnd
-
--- | Combinator '||' is a pairwise logical disjunction of two splitters run in parallel on the same input.
-(||) :: (MonadParallel m)
- => SplitterComponent m x b1 -> SplitterComponent m x b2 -> SplitterComponent m x (Either b1 b2)
-(||) = liftParallelPair "||" Combinator.pOr
-
-ifs :: forall c m x b. (MonadParallel m, Branching c m x ()) =>
- SplitterComponent m x b -> Component c -> Component c -> Component c
-ifs = parallelRouterAndBranches "ifs" Combinator.ifs
-
-wherever :: forall m x b. MonadParallel m =>
- TransducerComponent m x x -> SplitterComponent m x b -> TransducerComponent m x x
-wherever = liftParallelPair "wherever" Combinator.wherever
-
-unless :: forall m x b. MonadParallel m =>
- TransducerComponent m x x -> SplitterComponent m x b -> TransducerComponent m x x
-unless = liftParallelPair "unless" Combinator.unless
-
-select :: forall m x b. Monad m => SplitterComponent m x b -> TransducerComponent m x x
-select = lift 1 "select" Combinator.select
-
--- | Converts a splitter into a parser.
-parseRegions :: forall m x b. 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 :: forall m x b. MonadParallel m =>
- SplitterComponent m x (Boundary b) -> ParserComponent m x b
-parseNestedRegions = lift 1 "parseNestedRegions" Combinator.parseNestedRegions
-
--- | The recursive combinator 'while' feeds the true sink of the argument splitter back to itself, modified by the
--- argument transducer. Data fed to the splitter's false sink is passed on unmodified.
-while :: forall m x b. MonadParallel m =>
- TransducerComponent m x x -> SplitterComponent m x b -> TransducerComponent m x x
-while t s = recursiveComponentTree "while" Combinator.while $ liftSequentialPair "pair" (,) t s
-
--- | The recursive combinator 'nestedIn' combines two splitters into a mutually recursive loop acting as a single
--- splitter. The true sink of one of the argument splitters and false sink of the other become the true and false sinks
--- of the loop. The other two sinks are bound to the other splitter's source. The use of 'nestedIn' makes sense only
--- on hierarchically structured streams. If we gave it some input containing a flat sequence of values, and assuming
--- both component splitters are deterministic and stateless, an input value would either not loop at all or it would
--- loop forever.
-nestedIn :: forall m x b. MonadParallel m =>
- SplitterComponent m x b -> SplitterComponent m x b -> SplitterComponent m x b
-nestedIn s1 s2 = recursiveComponentTree "nestedIn" Combinator.nestedIn $ liftSequentialPair "pair" (,) s1 s2
-
--- | The 'foreach' combinator is similar to the combinator 'ifs' in that it combines a splitter and two transducers into
--- another transducer. However, in this case the transducers are re-instantiated for each consecutive portion of the
--- input as the splitter chunks it up. Each contiguous portion of the input that the splitter sends to one of its two
--- sinks gets transducered through the appropriate argument transducer as that transducer's whole input. As soon as the
--- contiguous portion is finished, the transducer gets terminated.
-foreach :: forall m x b c. (MonadParallel m, Branching c m x ()) =>
- SplitterComponent m x b -> 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
--- into contiguous portions. Its /false/ sink is routed directly to the /false/ sink of the combined splitter. The
--- second splitter is instantiated and run on each portion of the input that goes to first splitter's /true/ sink. If
--- the second splitter sends any output at all to its /true/ sink, the whole input portion is passed on to the /true/
--- sink of the combined splitter, otherwise it goes to its /false/ sink.
-having :: forall m x b1 b2. MonadParallel m =>
- SplitterComponent m x b1 -> SplitterComponent m x b2 -> SplitterComponent m x b1
-having = liftParallelPair "having" Combinator.having
-
--- | The 'havingOnly' combinator is analogous to the 'having' combinator, but it succeeds and passes each chunk of the
--- input to its /true/ sink only if the second splitter sends no part of it to its /false/ sink.
-havingOnly :: forall m x b1 b2. MonadParallel m =>
- SplitterComponent m x b1 -> SplitterComponent m x b2 -> SplitterComponent m x b1
-havingOnly = liftParallelPair "havingOnly" Combinator.havingOnly
-
--- | 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 => SplitterComponent m x b -> SplitterComponent m x b
-first = 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 :: forall m x b. Monad m => SplitterComponent m x b -> SplitterComponent m x b
-uptoFirst = lift 2 "uptoFirst" Combinator.uptoFirst
-
--- | The result of the combinator 'last' is a splitter which directs all input to its /false/ sink, up to the last
--- portion of the input which goes to its argument's /true/ sink. That portion of the input is the only one that goes to
--- the resulting component's /true/ sink. The splitter returned by the combinator 'last' has to buffer the previous two
--- portions of its input, because it cannot know if a true portion of the input is the last one until it sees the end of
--- the input or another portion succeeding the previous one.
-last :: forall m x b. Monad m => SplitterComponent m x b -> SplitterComponent m x b
-last = 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 :: forall m x b. Monad m => SplitterComponent m x b -> SplitterComponent m x b
-lastAndAfter = lift 2 "lastAndAfter" Combinator.lastAndAfter
-
--- | 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 => SplitterComponent m x b -> SplitterComponent m x b
-prefix = lift 2 "prefix" Combinator.prefix
-
--- | 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 => SplitterComponent m x b -> SplitterComponent m x b
-suffix = lift 2 "suffix" Combinator.suffix
-
--- | 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 => SplitterComponent m x b -> SplitterComponent m x b
-even = lift 2 "even" Combinator.even
-
--- | 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 :: forall m x b. Monad m => SplitterComponent m x b -> SplitterComponent m x (Maybe b)
-startOf = 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 :: forall m x b. MonadParallel m => SplitterComponent m x b -> SplitterComponent m x (Maybe b)
-endOf = lift 2 "endOf" Combinator.endOf
-
--- | Combinator 'followedBy' treats its argument 'SplitterComponent's as patterns components and returns a 'SplitterComponent' that
--- matches their concatenation. A section of input is considered /true/ by the result iff its prefix is considered
--- /true/ by argument /s1/ and the rest of the section is considered /true/ by /s2/. The splitter /s2/ is started anew
--- after every section split to /true/ sink by /s1/.
-followedBy :: forall m x b1 b2. MonadParallel m =>
- SplitterComponent m x b1 -> SplitterComponent m x b2 -> SplitterComponent m x (b1, b2)
-followedBy = liftParallelPair "followedBy" Combinator.followedBy
-
--- | Combinator '...' tracks the running balance of difference between the number of preceding starts of sections
--- considered /true/ according to its first argument and the ones according to its second argument. The combinator
--- passes to /true/ all input values for which the difference balance is positive. This combinator is typically used
--- with 'startOf' and 'endOf' in order to count entire input sections and ignore their lengths.
-(...) :: forall m x b1 b2. MonadParallel m =>
- SplitterComponent m x b1 -> SplitterComponent m x b2 -> SplitterComponent m x b1
-(...) = liftParallelPair "..." Combinator.between
-
-xmlTokens :: Monad m => SplitterComponent m Char (Boundary Token)
-xmlTokens = atomic "XML.tokens" 1 XML.tokens
-
-xmlParseTokens :: Monad m => ParserComponent m Char Token
-xmlParseTokens = atomic "XML.parseTokens" 1 XML.parseTokens
-
-xmlElement :: Monad m => SplitterComponent m (Markup Token Char) ()
-xmlElement = atomic "XML.element" 1 XML.element
-
-xmlElementContent :: Monad m => SplitterComponent m (Markup Token Char) ()
-xmlElementContent = atomic "XML.elementContent" 1 XML.elementContent
-
--- | Similiar to @('Control.Concurrent.SCC.Combinators.having' 'element')@, except it runs the argument splitter
--- only on each element's start tag, not on the entire element with its content.
-xmlElementHavingTag :: forall m b. MonadParallel m =>
- SplitterComponent m (Markup Token Char) b -> SplitterComponent m (Markup Token Char) b
-xmlElementHavingTag = lift 2 "XML.elementHavingTag" XML.elementHavingTag
-
--- | Splits every attribute specification to /true/, everything else to /false/.
-xmlAttribute :: Monad m => SplitterComponent m (Markup Token Char) ()
-xmlAttribute = atomic "XML.attribute" 1 XML.attribute
-
--- | 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 Token Char) ()
-xmlElementName = atomic "XML.elementName" 1 XML.elementName
-
--- | Splits every attribute name to /true/, all the rest of input to /false/.
-xmlAttributeName :: Monad m => SplitterComponent m (Markup Token Char) ()
-xmlAttributeName = atomic "XML.attributeName" 1 XML.attributeName
-
--- | Splits every attribute value, excluding the quote delimiters, to /true/, all the rest of input to /false/.
-xmlAttributeValue :: Monad m => SplitterComponent m (Markup Token Char) ()
-xmlAttributeValue = atomic "XML.attributeValue" 1 XML.attributeValue
-
-xmlHavingText :: forall m b1 b2. MonadParallel m =>
- SplitterComponent m (Markup Token Char) b1 -> SplitterComponent m Char b2 ->
- SplitterComponent m (Markup Token Char) b1
-xmlHavingText = liftParallelPair "XML.havingText" XML.havingText
-
-xmlHavingOnlyText :: forall m b1 b2. MonadParallel m =>
- SplitterComponent m (Markup Token Char) b1 -> SplitterComponent m Char b2 ->
- SplitterComponent m (Markup Token Char) b1
-xmlHavingOnlyText = liftParallelPair "XML.havingOnlyText" XML.havingOnlyText
diff --git a/Control/Concurrent/SCC/Configurable.hs b/Control/Concurrent/SCC/Configurable.hs
new file mode 100644
--- /dev/null
+++ b/Control/Concurrent/SCC/Configurable.hs
@@ -0,0 +1,572 @@
+{-
+ Copyright 2008-2010 Mario Blazevic
+
+ This file is part of the Streaming Component Combinators (SCC) project.
+
+ The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public
+ License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later
+ version.
+
+ SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty
+ of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License along with SCC. If not, see
+ .
+-}
+
+{-# LANGUAGE RankNTypes, KindSignatures, EmptyDataDecls,
+ 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.
+
+module Control.Concurrent.SCC.Configurable
+ (
+ module Control.Concurrent.SCC.Streams,
+ module Control.Concurrent.SCC.Types,
+ module Control.Concurrent.SCC.Configurable,
+ XML.XMLToken(..), XML.expandXMLEntity
+ )
+where
+
+import Prelude hiding (appendFile, even, id, last, sequence, (||), (&&))
+import qualified Control.Category
+import Control.Monad (liftM)
+import Data.Text (Text, unpack)
+import System.IO (Handle)
+
+import Control.Monad.Coroutine
+import Control.Monad.Parallel (MonadParallel(..))
+
+import qualified Control.Concurrent.SCC.Streams
+import Control.Concurrent.SCC.Types
+import Control.Concurrent.SCC.Coercions (Coercible)
+import qualified Control.Concurrent.SCC.Coercions as Coercion
+import qualified Control.Concurrent.SCC.Combinators as Combinator
+import qualified Control.Concurrent.SCC.Primitives as Primitive
+import qualified Control.Concurrent.SCC.XML as XML
+import Control.Concurrent.SCC.Primitives (OccurenceTag)
+import Control.Concurrent.SCC.XML (XMLToken)
+import Control.Concurrent.Configuration hiding (liftParallelPair, parallelRouterAndBranches, recursiveComponentTree)
+import qualified Control.Concurrent.Configuration as Configuration
+
+-- * Configurable component types
+
+-- | A component that performs a computation with no inputs nor outputs is a 'PerformerComponent'.
+type PerformerComponent m r = Component (Performer m r)
+
+-- | A component that consumes values from a 'Source' is called 'ConsumerComponent'.
+type ConsumerComponent m x r = Component (Consumer m x r)
+
+-- | A component that produces values and puts them into a 'Sink' is called 'ProducerComponent'.
+type ProducerComponent m x r = Component (Producer m x r)
+
+-- | The 'TransducerComponent' type represents computations that transform a data stream.
+type TransducerComponent m x y = Component (Transducer m x y)
+
+type ParserComponent m x y = Component (Parser m x y)
+
+-- | The 'SplitterComponent' type represents computations that distribute data acording to some criteria. A splitter
+-- should distribute only the original input data, and feed it into the sinks in the same order it has been read from
+-- the source. If the two 'Sink 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)
+
+-- | The constant cost of each I/O-performing component.
+ioCost :: Int
+ioCost = 5
+
+-- * Coercible class
+
+-- | A 'TransducerComponent' that converts a stream of one type to another.
+coerce :: (Monad m, Coercible x y) => TransducerComponent m x y
+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
+
+-- | 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
+
+-- * 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
+
+-- * I/O components
+-- ** I/O producers
+
+-- | ProducerComponent 'fromStdIn' feeds the given sink from the standard input.
+fromStdIn :: ProducerComponent IO Char ()
+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 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 = atomic "fromHandle" ioCost (Primitive.fromHandle handle)
+
+-- ** I/O consumers
+
+-- | ConsumerComponent 'toStdOut' copies the given source into the standard output.
+toStdOut :: ConsumerComponent IO Char ()
+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 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 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 = 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)
+
+-- ** Generic consumers
+
+-- | ConsumerComponent 'toList' copies the given source into a list.
+toList :: Monad m => ConsumerComponent m x [x]
+toList = atomic "toList" 1 Primitive.toList
+
+-- | 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 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
+
+-- | TransducerComponent 'unparse' removes all markup from its input and passes the content through.
+unparse :: Monad m => 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 = 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 = 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 = 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 = atomic "count" 1 Primitive.count
+
+-- | Converts each input value @x@ to @show x@.
+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 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]
+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 = 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 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 = atomic "everything" 1 Primitive.everything
+
+-- | SplitterComponent 'nothing' feeds its entire input into its /false/ sink.
+nothing :: Monad m => 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 = 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 = 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 select = atomic "markedWith" 1 (Primitive.markedWith select)
+
+-- | 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 select = atomic "contentMarkedWith" 1 (Primitive.contentMarkedWith select)
+
+-- | SplitterComponent 'one' feeds all input values to its /true/ sink, treating every value as a separate section.
+one :: Monad m => 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 ()
+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 = 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 = 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 = 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 = 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 = 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
+
+-- | 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.
+
+(>->) :: (MonadParallel m, Combinator.PipeableComponentPair m w c1 c2 c3) =>
+ Component c1 -> Component c2 -> Component c3
+(>->) = liftParallelPair ">->" Combinator.compose
+
+class CompatibleSignature c cons (m :: * -> *) input output | c -> cons m
+
+class AnyListOrUnit c
+
+instance AnyListOrUnit [x]
+instance AnyListOrUnit ()
+
+instance (AnyListOrUnit x, AnyListOrUnit y) => CompatibleSignature (Performer m r) (PerformerType r) m x y
+instance AnyListOrUnit y => CompatibleSignature (Consumer m x r) (ConsumerType r) m [x] y
+instance AnyListOrUnit y => CompatibleSignature (Producer m x r) (ProducerType r) m y [x]
+instance CompatibleSignature (Transducer m x y) TransducerType m [x] [y]
+
+data PerformerType r
+data ConsumerType r
+data ProducerType r
+data TransducerType
+
+-- | Class 'JoinableComponentPair' applies to any two components that can be combined into a third component with the
+-- following properties:
+--
+-- * if both argument components consume input, the input of the combined component gets distributed to both
+-- components in parallel,
+--
+-- * if both argument components produce output, the output of the combined component is a concatenation of the
+-- complete output from the first component followed by the complete output of the second component, and
+
+-- | The 'join' combinator may apply the components in any order.
+join :: (MonadParallel m, Combinator.JoinableComponentPair t1 t2 t3 m x y c1 c2 c3) =>
+ Component c1 -> Component c2 -> Component c3
+join = liftParallelPair "join" Combinator.join
+
+-- | 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
+
+-- | 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
+
+-- | 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
+
+-- | 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
+
+-- * 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
+
+-- ** 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)
+(>&) = 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)
+(>|) = 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)
+(&&) = 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)
+(||) = liftParallelPair "||" Combinator.pOr
+
+-- * Flow-control combinators
+
+ifs :: (MonadParallel m, Branching c m x ()) =>
+ SplitterComponent m x b -> 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 = liftParallelPair "wherever" Combinator.wherever
+
+unless :: MonadParallel m =>
+ TransducerComponent m x x -> SplitterComponent m x b -> 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
+
+-- ** 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
+
+-- | The recursive combinator 'nestedIn' combines two splitters into a mutually recursive loop acting as a single
+-- splitter. The true sink of one of the argument splitters and false sink of the other become the true and false sinks
+-- of the loop. The other two sinks are bound to the other splitter's source. The use of 'nestedIn' makes sense only
+-- on hierarchically structured streams. If we gave it some input containing a flat sequence of values, and assuming
+-- both component splitters are deterministic and stateless, an input value would either not loop at all or it would
+-- loop forever.
+nestedIn :: 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
+
+-- * Section-based combinators
+
+-- | 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 :: (MonadParallel m, Branching c m x ()) =>
+ SplitterComponent m x b -> 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
+-- 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 :: (MonadParallel m, Coercible x y) =>
+ SplitterComponent m x b1 -> SplitterComponent m y b2 -> SplitterComponent m x b1
+having = liftParallelPair "having" Combinator.having
+
+-- | The 'havingOnly' combinator is analogous to the 'having' combinator, but it succeeds and passes each chunk of the
+-- input to its /true/ sink only if the second splitter sends no part of it to its /false/ sink.
+havingOnly :: (MonadParallel m, Coercible x y) =>
+ SplitterComponent m x b1 -> SplitterComponent m y b2 -> SplitterComponent m x b1
+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 = 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
+
+-- ** 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
+
+-- | 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
+
+-- | 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
+
+-- ** last and its variants
+
+-- | The result of the combinator 'last' is a splitter which directs all input to its /false/ sink, up to the last
+-- portion of the input which goes to its argument's /true/ sink. That portion of the input is the only one that goes to
+-- the resulting component's /true/ sink. The splitter returned by the combinator 'last' has to buffer the previous two
+-- portions of its input, because it cannot know if a true portion of the input is the last one until it sees the end of
+-- the input or another portion succeeding the previous one.
+last :: Monad m => SplitterComponent m x b -> SplitterComponent m x b
+last = 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
+
+-- | 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
+
+-- ** 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
+
+-- | 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
+
+-- | 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
+(...) = 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
+
+-- * Parsing XML
+
+-- | This splitter splits XML markup from data content. It is used by 'parseXMLTokens'.
+xmlTokens :: Monad m => SplitterComponent m Char (Boundary XMLToken)
+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 = 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 = 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 = 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
+
+-- | Splits every attribute specification to /true/, everything else to /false/.
+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 = 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 = 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 = atomic "XML.attributeValue" 1 XML.xmlAttributeValue
+
+liftParallelPair :: MonadParallel m =>
+ String -> (PairBinder m -> c1 -> c2 -> c3) -> Component c1 -> Component c2 -> Component c3
+liftParallelPair name combinator = Configuration.liftParallelPair name (\b-> combinator $ chooseBinder b)
+
+parallelRouterAndBranches :: MonadParallel m =>
+ String -> (PairBinder m -> c1 -> c2 -> c3 -> c4)
+ -> Component c1 -> Component c2 -> Component c3 -> Component c4
+parallelRouterAndBranches name combinator =
+ Configuration.parallelRouterAndBranches name (\b-> combinator $ chooseBinder b)
+
+chooseBinder :: MonadParallel m => Bool -> PairBinder m
+chooseBinder parallel = if parallel then parallelBinder else sequentialBinder
+
+recursiveComponentTree :: MonadParallel m => String -> (PairBinder m -> c1 -> c2 -> c2) -> Component c1 -> Component c2
+recursiveComponentTree name combinator = Configuration.recursiveComponentTree name (\b-> combinator $ chooseBinder b)
diff --git a/Control/Concurrent/SCC/Parallel.hs b/Control/Concurrent/SCC/Parallel.hs
new file mode 100644
--- /dev/null
+++ b/Control/Concurrent/SCC/Parallel.hs
@@ -0,0 +1,34 @@
+{-
+ Copyright 2008-2010 Mario Blazevic
+
+ This file is part of the Streaming Component Combinators (SCC) project.
+
+ The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public
+ License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later
+ version.
+
+ SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty
+ of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License along with SCC. If not, see
+ .
+-}
+
+-- | This module exports all of the SCC libraries. 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,
+ module Control.Concurrent.SCC.XML
+)
+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
+import Control.Concurrent.SCC.XML
diff --git a/Control/Concurrent/SCC/Primitives.hs b/Control/Concurrent/SCC/Primitives.hs
--- a/Control/Concurrent/SCC/Primitives.hs
+++ b/Control/Concurrent/SCC/Primitives.hs
@@ -18,104 +18,117 @@
-- defined in the "Types" module.
{-# LANGUAGE ScopedTypeVariables, Rank2Types #-}
+{-# OPTIONS_HADDOCK hide #-}
-module Control.Concurrent.SCC.Primitives
- (
- -- * Tag types
- OccurenceTag,
- -- * List producers and consumers
- fromList, toList,
- -- * I/O producers and consumers
- fromFile, fromHandle, fromStdIn,
- appendFile, toFile, toHandle, toStdOut,
- -- * Generic consumers
- suppress, erroneous,
- -- * Generic transducers
- parse, unparse, parseSubstring,
- -- * Generic splitters
- everything, nothing, marked, markedContent, markedWith, contentMarkedWith, one, substring,
- -- * List transducers
- -- | The following laws hold:
- --
- -- * 'group' '>>>' 'concatenate' == 'id'
- --
- -- * 'concatenate' == 'concatSeparate' []
- group, concatenate, concatSeparate,
- -- * Character stream components
- lowercase, uppercase, whitespace, letters, digits, line, nonEmptyLine,
- -- * Oddballs
- count, toString
-)
+module Control.Concurrent.SCC.Primitives (
+ -- * I/O components
+ -- ** I/O producers
+ fromFile, fromHandle, fromStdIn, fromBinaryHandle,
+ -- ** I/O consumers
+ appendFile, toFile, toHandle, toStdOut, toBinaryHandle,
+ -- * Generic components
+ fromList,
+ -- ** Generic consumers
+ suppress, erroneous, toList,
+ -- ** Generic transducers
+ parse, unparse, parseSubstring, OccurenceTag, count, toString,
+ -- *** List stream transducers
+ -- | The following laws hold:
+ --
+ -- * 'group' '>>>' 'concatenate' == 'id'
+ --
+ -- * 'concatenate' == 'concatSeparate' []
+ group, concatenate, concatSeparate,
+ -- ** Generic splitters
+ everything, nothing, marked, markedContent, markedWith, contentMarkedWith, one, substring,
+ -- * Character stream components
+ lowercase, uppercase, whitespace, letters, digits, line, nonEmptyLine,
+ )
where
import Prelude hiding (appendFile)
-import Control.Monad.Coroutine
-import Control.Concurrent.SCC.Streams
-import Control.Concurrent.SCC.Types
-
+import Control.Category ((>>>))
import Control.Exception (assert)
-
-import Control.Monad (liftM, when)
+import Control.Monad (liftM, when, unless)
import Control.Monad.Trans.Class (lift)
import qualified Control.Monad as Monad
+import Data.ByteString (ByteString)
import Data.Char (isAlpha, isDigit, isPrint, isSpace, toLower, toUpper)
import Data.List (delete, isPrefixOf, stripPrefix)
import Data.Maybe (fromJust)
+import qualified Data.ByteString as ByteString
import qualified Data.Foldable as Foldable
import qualified Data.Sequence as Seq
-import Data.Sequence (Seq, (|>), (><), ViewL (EmptyL, (:<)))
+import Data.Sequence (Seq, (|>), (><), ViewL (EmptyL, (:<)), ViewR (EmptyR, (:>)))
import Debug.Trace (trace)
import System.IO (Handle, IOMode (ReadMode, WriteMode, AppendMode), openFile, hClose,
- hGetChar, hPutChar, hFlush, hIsEOF, hClose, putChar, isEOF, stdout)
+ getLine, hGetLine, hPutStr, hFlush, hIsEOF, hClose, putStr, isEOF, stdout)
--- | Consumer 'toList' copies the given source into a list.
+import Control.Cofunctor.Ticker (tickPrefixOf)
+import Control.Monad.Coroutine
+import Control.Monad.Coroutine.SuspensionFunctors
+import Control.Monad.Coroutine.Nested
+
+import Control.Concurrent.SCC.Streams
+import Control.Concurrent.SCC.Types
+
+-- | Collects the entire input source into a list.
toList :: forall m x. Monad m => Consumer m x [x]
toList = Consumer getList
--- | 'fromList' produces the contents of the given list argument.
+-- | Produces the contents of the given list argument.
fromList :: forall m x. Monad m => [x] -> Producer m x ()
-fromList l = Producer (putList l)
+fromList l = Producer ((>> return ()) . putList l)
-- | Consumer 'toStdOut' copies the given source into the standard output.
toStdOut :: Consumer IO Char ()
-toStdOut = Consumer (mapMStream_ (\x-> lift (putChar x)))
+toStdOut = Consumer (mapMStreamChunks_ (lift . putStr))
-- | Producer 'fromStdIn' feeds the given sink from the standard input.
fromStdIn :: Producer IO Char ()
-fromStdIn = Producer (unmapMStream_ (lift isEOF >>= cond (return Nothing) (lift (liftM Just getChar))))
+fromStdIn = Producer (unmapMStreamChunks_ (lift $ isEOF >>= cond (return []) (liftM (++ "\n") getLine)))
--- | Producer 'fromFile' opens the named file and feeds the given sink from its contents.
+-- | Reads the named file and feeds the given sink from its contents.
fromFile :: String -> Producer IO Char ()
fromFile path = Producer $ \sink-> do handle <- lift (openFile path ReadMode)
- produce (fromHandle handle True) sink
+ produce (fromHandle handle) sink
+ lift (hClose handle)
--- | Producer 'fromHandle' feeds the given sink from the open file /handle/. The argument /doClose/ determines
--- | if /handle/ should be closed when the handle is consumed or the sink closed.
-fromHandle :: Handle -> Bool -> Producer IO Char ()
-fromHandle handle doClose = Producer (\sink-> unmapMStream_ (lift hGetCharMaybe) sink
- >> when doClose (lift $ hClose handle))
- where hGetCharMaybe = hIsEOF handle >>= cond (return Nothing) (liftM Just $ hGetChar handle)
-
+-- | Feeds the given sink from the open text file /handle/.
+fromHandle :: Handle -> Producer IO Char ()
+fromHandle handle = Producer (unmapMStreamChunks_
+ (lift $ hIsEOF handle >>= cond (return []) (liftM (++ "\n") $ hGetLine handle)))
--- | Consumer 'toFile' opens the named file and copies the given source into it.
+-- | 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 produce
+ where produce sink = lift (ByteString.hGet handle chunkSize)
+ >>= \chunk-> unless (ByteString.null chunk) (tryPut sink chunk >>= flip when (produce sink))
+
+-- | Creates the named text file and writes the entire given source to it.
toFile :: String -> Consumer IO Char ()
toFile path = Consumer $ \source-> do handle <- lift (openFile path WriteMode)
- consume (toHandle handle True) source
+ consume (toHandle handle) source
+ lift (hClose handle)
--- | Consumer 'appendFile' opens the name file and appends the given source to it.
+-- | Appends the given source to the named text file.
appendFile :: String -> Consumer IO Char ()
appendFile path = Consumer $ \source-> do handle <- lift (openFile path AppendMode)
- consume (toHandle handle True) source
+ consume (toHandle handle) source
+ lift (hClose handle)
--- | Consumer 'toHandle' copies the given source into the open file /handle/. The argument /doClose/ determines
--- | if /handle/ should be closed once the entire source is consumed and copied.
-toHandle :: Handle -> Bool -> Consumer IO Char ()
-toHandle handle doClose = Consumer (\source-> mapMStream_ (lift . hPutChar handle) source
- >> when doClose (lift $ hClose handle))
+-- | Copies the given source into the open text file /handle/.
+toHandle :: Handle -> Consumer IO Char ()
+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))
+
-- | Transducer 'unparse' removes all markup from its input and passes the content through.
-unparse :: forall m x y. Monad m => Transducer m (Markup y x) x
+unparse :: forall m x b. Monad m => Transducer m (Markup b x) x
unparse = statelessTransducer removeTag
where removeTag (Content x) = [x]
removeTag _ = []
@@ -126,7 +139,7 @@
-- | The 'suppress' consumer suppresses all input it receives. It is equivalent to 'substitute' []
suppress :: forall m x y. Monad m => Consumer m x ()
-suppress = Consumer (mapMStream_ (const $ return ()))
+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 ()
@@ -150,7 +163,7 @@
-- | 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-> foldStream (|>) Seq.empty source >>= put sink . Foldable.toList)
+group = Transducer (\source sink-> getList 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
@@ -181,18 +194,16 @@
-- | 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-> let split Nothing x = put boundaries () >> handle x
- split (Just '\n') x@'\r' = put false x >> return Nothing
- split (Just '\r') x@'\n' = put false x >> return Nothing
- split (Just '\n') x = split Nothing x
- split (Just '\r') x = split Nothing x
- split (Just _) x = handle x
- handle x = (if x == '\n' || x == '\r'
- then put false x
- else put true x)
- >> return (Just x)
- in foldMStream_ split Nothing source
+line = Splitter $ \source true false boundaries->
+ let loop = peek source >>= maybe (return ()) (( >> loop) . line)
+ line c = put boundaries ()
+ >> if c == '\r' || c == '\n'
+ then lineEnd c
+ else pourUntil (\x-> x == '\n' || x == '\r') source true
+ >>= maybe (return ()) lineEnd
+ lineEnd '\n' = pourTicked (tickPrefixOf "\n\r") source false
+ lineEnd '\r' = pourTicked (tickPrefixOf "\r\n") source false
+ in loop
-- | Splitter 'everything' feeds its entire input into its /true/ sink.
everything :: forall m x. Monad m => Splitter m x ()
@@ -259,7 +270,17 @@
parseSubstring list
= Transducer $
\ source sink ->
- let getNext id rest q = get source
+ let findFirst = pourUntil (== head list) source (mapSink Content sink)
+ >>= maybe (return ()) (const test)
+ test = getTicked (tickPrefixOf list) source
+ >>= \prefix-> let Just rest = stripPrefix prefix list
+ head:tail = map Content list
+ in if null rest
+ then put sink (Markup (Start (toEnum 0)))
+ >> put sink head
+ >> fallback 0 (Seq.fromList tail |> Markup (End (toEnum 0)))
+ else getNext 0 rest (Seq.fromList $ map Content prefix)
+ getNext id rest q = get source
>>= maybe
(flush q)
(advance id rest q)
@@ -274,7 +295,7 @@
else getNext id tail q'
else fallback id q'
fallback id q = case Seq.viewl q
- of EmptyL -> getNext id list q
+ of EmptyL -> findFirst
head@(Markup (End id')) :< tail -> put sink head
>> fallback
(if id == fromEnum id' then 0 else id)
@@ -283,12 +304,12 @@
of Just rest -> getNext id rest q
Nothing -> put sink head
>> fallback id tail
- flush q = putQueue q sink
+ flush q = putQueue q sink >> return ()
remainingContent :: Seq (Markup OccurenceTag x) -> [x]
remainingContent q = extractContent (Seq.viewl q)
extractContent :: Foldable.Foldable f => f (Markup b x) -> [x]
extractContent = Foldable.concatMap (\e-> case e of {Content x -> [x]; _ -> []})
- in getNext 0 list Seq.empty
+ in findFirst
-- | 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
@@ -298,10 +319,17 @@
substring list
= Splitter $
\ source true false edge ->
- let getNext rest qt qf = get source
+ let findFirst = pourUntil (== head list) source false
+ >>= maybe (return ()) (const test)
+ test = getTicked (tickPrefixOf list) source
+ >>= \prefix-> let Just rest = stripPrefix prefix list
+ head:tail = list
+ in if null rest
+ then put edge () >> put true head >> fallback (Seq.fromList tail) Seq.empty
+ else getNext rest Seq.empty (Seq.fromList prefix)
+ getNext rest qt qf = get source
>>= maybe
- (putList (Foldable.toList (Seq.viewl qt)) true
- >> putList (Foldable.toList (Seq.viewl qf)) false)
+ (putQueue qt true >> putQueue qf false >> return ())
(advance rest qt qf)
advance rest@(head:tail) qt qf x = let qf' = qf |> x
view@(qqh :< qqt) = Seq.viewl (qt >< qf')
@@ -310,10 +338,10 @@
then put edge ()
>> put true qqh
>> fallback qqt Seq.empty
- else getNext tail qt qf'
- else fallback qt qf'
+ else getNext tail qt qf'
+ else fallback qt qf'
fallback qt qf = case Seq.viewl (qt >< qf)
- of EmptyL -> getNext list Seq.empty Seq.empty
+ of EmptyL -> findFirst
view@(head :< tail) -> case stripPrefix (Foldable.toList view) list
of Just rest -> getNext rest qt qf
Nothing -> if Seq.null qt
@@ -321,4 +349,8 @@
>> fallback Seq.empty tail
else put true head
>> fallback (Seq.drop 1 qt) qf
- in getNext list Seq.empty Seq.empty
+ in findFirst
+
+-- | A utility function wrapping if-then-else, useful for handling monadic truth values
+cond :: a -> a -> Bool -> a
+cond x y test = if test then x else y
diff --git a/Control/Concurrent/SCC/Sequential.hs b/Control/Concurrent/SCC/Sequential.hs
new file mode 100644
--- /dev/null
+++ b/Control/Concurrent/SCC/Sequential.hs
@@ -0,0 +1,35 @@
+{-
+ Copyright 2008-2010 Mario Blazevic
+
+ This file is part of the Streaming Component Combinators (SCC) project.
+
+ The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public
+ License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later
+ version.
+
+ SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty
+ of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License along with SCC. If not, see
+ .
+-}
+
+-- | This module exports all of the SCC libraries. 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,
+ module Control.Concurrent.SCC.XML
+)
+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
+import Control.Concurrent.SCC.XML
diff --git a/Control/Concurrent/SCC/Streams.hs b/Control/Concurrent/SCC/Streams.hs
--- a/Control/Concurrent/SCC/Streams.hs
+++ b/Control/Concurrent/SCC/Streams.hs
@@ -15,9 +15,9 @@
-}
-- | This module defines 'Source' and 'Sink' types and 'pipe' functions that create them. The method 'get' on 'Source'
--- abstracts away 'Control.Concurrent.Coroutine.await', and the method 'put' on 'Sink' is a higher-level abstraction of
--- 'Control.Concurrent.Coroutine.SuspensionFunctors.yield'. With this arrangement, a single coroutine can yield values
--- to multiple sinks and await values from multiple sources with no need to change the
+-- 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:
@@ -43,56 +43,64 @@
-- @
{-# 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, pipePS, nullSink, nullSource,
+ pipe, pipeP, pipeG, nullSink, nullSource,
-- * Operations on sinks and sources
-- ** Singleton operations
- get, put, getWith,
+ get, getWith, peek, put, tryPut,
-- ** Lifting functions
liftSink, liftSource,
-- ** Bulk operations
+ -- *** Fetching and moving data
pour, tee, teeSink, teeSource,
- mapStream, mapSource, mapSink, mapMStream, mapMSource, mapMSink, mapMStream_,
- mapMaybeStream, mapMaybeSink, mapMaybeSource,
- filterMStream, filterMSource, filterMSink,
- foldStream, foldMStream, foldMStream_, mapAccumStream, partitionStream,
- unfoldMStream, unmapMStream_,
- zipWithMStream, parZipWithMStream,
getList, putList, putQueue,
- -- * Utility functions
- cond
+ getTicked, getWhile, getUntil,
+ pourTicked, pourWhile, pourUntil,
+ -- *** Stream transformations
+ mapSink, mapStream,
+ mapMaybeStream, concatMapStream,
+ mapStreamChunks, foldStream, mapAccumStream, concatMapAccumStream, partitionStream,
+ -- *** Monadic stream transformations
+ mapMStream, mapMStream_, mapMStreamChunks_,
+ filterMStream, foldMStream, foldMStream_, unfoldMStream, unmapMStream_, unmapMStreamChunks_,
+ zipWithMStream, parZipWithMStream,
)
where
-
+
import qualified Control.Monad
import qualified Data.List
import qualified Data.Maybe
-import Control.Monad (liftM, when)
+import Control.Monad (liftM, when, unless, foldM)
import Data.Foldable (toList)
+import Data.Maybe (isJust, mapMaybe)
+import Data.List (concatMap)
import Data.Sequence (Seq, viewl)
+import Control.Cofunctor.Ticker
import Control.Monad.Parallel (MonadParallel(..))
import Control.Monad.Coroutine
-import Control.Monad.Coroutine.SuspensionFunctors (Await(Await), Yield(Yield), EitherFunctor(..), await, yield)
-import Control.Monad.Coroutine.Nested (AncestorFunctor(..), liftOut, seesawNested)
+import Control.Monad.Coroutine.SuspensionFunctors (EitherFunctor(..), Request, request, liftedLazyTickerRequestResolver)
+import Control.Monad.Coroutine.Nested (AncestorFunctor(..), liftAncestor, seesawNested)
-type SourceFunctor a x = EitherFunctor a (Await (Maybe x))
-type SinkFunctor a x = EitherFunctor a (Yield x)
+type SourceFunctor a x = EitherFunctor a (Request (Ticker x) ([x], Either x (Ticker 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
-- the functor /a/. It's the write-only end of a communication channel created by 'pipe'.
newtype Sink (m :: * -> *) a x =
Sink
{
- -- | This function puts a value into the given `Sink`. The intervening 'Coroutine' computations suspend up
- -- to the 'pipe' invocation that has created the argument sink.
- put :: forall d. AncestorFunctor a d => x -> Coroutine d m ()
+ -- | 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]
}
-- | A 'Source' can be used to read values into any nested `Coroutine` computation whose functor provably descends from
@@ -100,164 +108,227 @@
newtype Source (m :: * -> *) a x =
Source
{
- -- | Function 'get' tries to get a value from the given 'Source' argument. The intervening 'Coroutine' computations
- -- suspend all the way to the 'pipe' function invocation that created the source. The function returns 'Nothing' if
- -- the argument source is empty.
- get :: forall d. AncestorFunctor a d => Coroutine d m (Maybe x)
+ -- | 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 s d. AncestorFunctor a d => Ticker x -> Coroutine d m ([x], Either x (Ticker x))
}
-- | A disconnected sink that ignores all values 'put' into it.
nullSink :: forall m a x. Monad m => Sink m a x
-nullSink = Sink{put= const (return ())}
+nullSink = Sink{putChunk= const (return [])}
-- | An empty source whose 'get' always returns Nothing.
nullSource :: forall m a x. Monad m => Source m a x
-nullSource = Source{get= return Nothing}
+nullSource = Source{foldChunk= \t-> return ([], Right t)}
-- | Converts a 'Sink' on the ancestor functor /a/ into a sink on the descendant functor /d/.
liftSink :: forall m a d x. (Monad m, AncestorFunctor a d) => Sink m a x -> Sink m d x
-liftSink s = Sink {put= liftOut . (put s :: x -> Coroutine d m ())}
+liftSink s = Sink {putChunk= liftAncestor . (putChunk s :: [x] -> Coroutine d m [x])}
-- | 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 {get= liftOut (get s :: Coroutine d m (Maybe x))}
+liftSource s = Source {foldChunk= liftAncestor . (foldChunk s :: Ticker x -> Coroutine d m ([x], Either x (Ticker x)))}
-- | 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) =>
(Sink m a1 x -> Coroutine a1 m r1) -> (Source m a2 x -> Coroutine a2 m r2) -> Coroutine a m (r1, r2)
-pipe = pipeG (\ f mx my -> do {x <- mx; y <- my; f x y})
+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) =>
(Sink m a1 x -> Coroutine a1 m r1) -> (Source m a2 x -> Coroutine a2 m r2) -> Coroutine a m (r1, r2)
pipeP = pipeG bindM2
--- | The 'pipePS' function acts either as 'pipeP' or as 'pipe', depending on the argument /parallel/.
-pipePS :: forall m a a1 a2 x r1 r2. (MonadParallel m, Functor a, a1 ~ SinkFunctor a x, a2 ~ SourceFunctor a x) =>
- Bool -> (Sink m a1 x -> Coroutine a1 m r1) -> (Source m a2 x -> Coroutine a2 m r2) ->
- Coroutine a m (r1, r2)
-pipePS parallel = if parallel then pipeP else pipe
-
-- | 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) =>
- (forall x y r. (x -> y -> m r) -> m x -> m y -> m r)
- -> (Sink m a1 x -> Coroutine a1 m r1) -> (Source m a2 x -> Coroutine a2 m r2)
+ 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 resolver (consumer source) (producer sink)
- where sink = Sink {put= liftOut . (mapSuspension RightF . yield :: x -> Coroutine a1 m ())} :: Sink m a1 x
- source = Source (liftOut (mapSuspension RightF await :: Coroutine a2 m (Maybe x))) :: Source m a2 x
- resolver = SeesawResolver {
- resumeLeft = \(Await c)-> c Nothing,
- resumeRight= \(Yield _ c)-> c,
- resumeAny= \ _ resumeProducer resumeBoth (Await cc) (Yield x cp) -> resumeBoth (cc (Just x)) cp
- }
+ liftM (uncurry (flip (,))) $
+ seesawNested run2 (liftedLazyTickerRequestResolver RightF) (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= \t-> liftAncestor (mapSuspension RightF (request t)
+ :: Coroutine a2 m ([x], Either x (Ticker x)))}
+-- | 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 tickOne
+ >>= return . nullOrElse Nothing (Just . head) . fst
+
+-- | 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 tickNone >>= return . either Just (const Nothing) . snd
+
+-- | '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 tickAll
+
-- | Invokes its first argument with the value it gets from the source, if there is any to get.
getWith :: forall m a d x. (Monad m, AncestorFunctor a d) => (x -> Coroutine d m ()) -> Source m a x -> Coroutine d m ()
getWith consumer source = get source >>= maybe (return ()) consumer
--- | 'pour' copies all data from the /source/ argument into the /sink/ argument.
+-- | Consumes values from the /source/ as long as the /ticker/ accepts them.
+getTicked :: forall m a d x. (Monad m, AncestorFunctor a d) => Ticker x -> Source m a x -> Coroutine d m [x]
+getTicked ticker source = loop return ticker
+ where loop cont ticker = foldChunk source ticker
+ >>= \(chunk, result)-> if null chunk then cont chunk
+ else either (const $ cont chunk) (loop (cont . (chunk ++))) result
+
+-- | 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 (tickWhile predicate)
+
+-- | 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 (tickUntil f)
+ >>= \(chunk, result)->
+ if null chunk then return (cont chunk, either Just (const Nothing) result)
+ else either (\x-> return (cont chunk, Just x)) (const $ loop (cont . (chunk ++))) result
+
+-- | Copies all data from the /source/ argument into the /sink/ argument.
pour :: forall m a1 a2 d x . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)
=> Source m a1 x -> Sink m a2 x -> Coroutine d m ()
-pour source sink = mapMStream_ (put sink) source
+pour source sink = loop
+ where loop = getChunk source >>= nullOrElse (return ()) ((>> loop) . putChunk sink)
+-- | Like 'pour', copies data from the /source/ to the /sink/, but only as long as it satisfies the predicate.
+pourTicked :: forall m a1 a2 d x . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)
+ => Ticker x -> Source m a1 x -> Sink m a2 x -> Coroutine d m ()
+pourTicked ticker source sink = loop ticker
+ where loop ticker = foldChunk source ticker
+ >>= \(chunk, next)->
+ unless (null chunk) (putChunk sink chunk >> either (const $ return ()) loop next)
+
+-- | 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)
+ => (x -> Bool) -> Source m a1 x -> Sink m a2 x -> Coroutine d m ()
+pourWhile f = pourTicked (tickWhile f)
+
+-- | 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)
+ => (x -> Bool) -> Source m a1 x -> Sink m a2 x -> Coroutine d m (Maybe x)
+pourUntil f source sink = loop
+ where loop = foldChunk source (tickUntil f)
+ >>= \(chunk, next)-> if null chunk then return (either Just (const Nothing) next)
+ else putChunk sink chunk >> either (return . Just) (const loop) next
+
-- | 'mapStream' is like 'pour' that applies the function /f/ to each argument before passing it into the /sink/.
mapStream :: forall m a1 a2 d x y . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)
=> (x -> y) -> Source m a1 x -> Sink m a2 y -> Coroutine d m ()
-mapStream f source sink = mapMStream_ (put sink . f) source
-
--- | An equivalent of 'Data.List.map' that works on a 'Source' instead of a list. The argument function is applied to
--- every value after it's read from the source argument.
-mapSource :: forall m a x y. Monad m => (x -> y) -> Source m a x -> Source m a y
-mapSource f source = Source{get= liftM (fmap f) (get source)}
+mapStream f source sink = loop
+ where loop = getChunk source >>= nullOrElse (return ()) ((>> loop) . putChunk sink . map f)
-- | An equivalent of 'Data.List.map' that works on a 'Sink' instead of a list. The argument function is applied to
-- every value vefore it's written to the sink argument.
mapSink :: forall m a x y. Monad m => (x -> y) -> Sink m a y -> Sink m a x
-mapSink f sink = Sink{put= put sink . f}
+mapSink f sink = Sink{putChunk= \xs-> putChunk sink (map f xs)
+ >>= \rest-> return (dropExcept (length rest) xs)}
+ where dropExcept :: forall x. Int -> [x] -> [x]
+ dropExcept 0 _ = []
+ dropExcept n xs = snd (drop' xs)
+ where drop' :: [x] -> (Int, [x])
+ drop' [] = (0, [])
+ drop' (x:xs) = let r@(len, tl) = drop' xs in if len < n then (succ len, x:tl) else r
+
-- | '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 ()
-mapMaybeStream f source sink = mapMStream_ (maybe (return ()) (put sink) . f) source
+mapMaybeStream f source sink = mapMStreamChunks_ ((>> return ()) . putChunk sink . mapMaybe f) source
--- | 'mapMaybeSink' is to 'mapSink' like 'Data.Maybe.mapMaybe' is to 'Data.List.map'.
-mapMaybeSink :: forall m a x y . Monad m => (x -> Maybe y) -> Sink m a y -> Sink m a x
-mapMaybeSink f sink = Sink{put= maybe (return ()) (put sink) . f}
+-- | '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)
--- | 'mapMaybeSource' is to 'mapSource' like 'Data.Maybe.mapMaybe' is to 'Data.List.map'.
-mapMaybeSource :: forall m a x y . Monad m => (x -> Maybe y) -> Source m a x -> Source m a y
-mapMaybeSource f source = Source{get= next}
- where next :: forall d. AncestorFunctor a d => Coroutine d m (Maybe y)
- next = get source
- >>= maybe (return Nothing) (maybe next (return . Just) . f)
+-- | 'mapAccumStream' is similar to 'Data.List.mapAccumL' except it reads the values from a 'Source' instead of a list
+-- and writes the mapped values into a 'Sink' instead of returning another list.
+mapAccumStream :: forall m a1 a2 d x y acc . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)
+ => (acc -> x -> (acc, y)) -> acc -> Source m a1 x -> Sink m a2 y -> Coroutine d m acc
+mapAccumStream f acc source sink = foldMStreamChunks (\acc xs-> dispatch $ Data.List.mapAccumL f acc xs) acc source
+ where dispatch (acc, ys) = putChunk sink ys >> return acc
+-- | '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
+concatMapAccumStream f acc source sink = foldMStreamChunks (\acc xs-> dispatch $ concatMapAccumL f acc xs) acc source
+ where dispatch (acc, ys) = putChunk sink ys >> return acc
+ concatMapAccumL _ s [] = (s, [])
+ concatMapAccumL f s (x:xs) = (s'', y ++ ys)
+ where (s', y ) = f s x
+ (s'', ys) = concatMapAccumL f 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 f source sink = loop
+ where loop = getChunk source >>= nullOrElse (return ()) ((>> loop) . flip putList sink . f)
+
-- | 'mapMStream' is similar to 'Control.Monad.mapM'. It draws the values from a 'Source' instead of a list, writes the
-- mapped values to a 'Sink', and returns a 'Coroutine'.
mapMStream :: forall m a1 a2 d x y . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)
=> (x -> Coroutine d m y) -> Source m a1 x -> Sink m a2 y -> Coroutine d m ()
mapMStream f source sink = loop
- where loop = getWith (\x-> f x >>= put sink >> loop) source
-
--- | An equivalent of 'Control.Monad.mapM' that works on a 'Source' instead of a list. Similar to 'mapSource', except
--- the function argument is monadic and may have perform effects.
-mapMSource :: forall m a x y. Monad m
- => (forall d. AncestorFunctor a d => x -> Coroutine d m y) -> Source m a x -> Source m a y
-mapMSource f source = Source{get= get source >>= maybe (return Nothing) (liftM Just . f)}
-
--- | An equivalent of 'Control.Monad.mapM' that works on a 'Sink' instead of a list. Similar to 'mapSink', except the
--- function argument is monadic and may have perform effects.
-mapMSink :: forall m a x y. Monad m
- => (forall d. AncestorFunctor a d => x -> Coroutine d m y) -> Sink m a y -> Sink m a x
-mapMSink f sink = Sink{put= (put sink =<<) . f}
+ where loop = getChunk source >>= nullOrElse (return ()) ((>> loop) . (putChunk sink =<<) . mapM f)
-- | 'mapMStream_' is similar to 'Control.Monad.mapM_' except it draws the values from a 'Source' instead of a list and
-- works with 'Coroutine' instead of an arbitrary monad.
mapMStream_ :: forall m a d x . (Monad m, AncestorFunctor a d)
=> (x -> Coroutine d m ()) -> Source m a x -> Coroutine d m ()
-mapMStream_ f source = loop
- where loop = getWith (\x-> f x >> loop) source
+mapMStream_ f = mapMStreamChunks_ (Control.Monad.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_ f source = loop
+ where loop = getChunk source >>= nullOrElse (return ()) ((>> loop) . f)
+
-- | An equivalent of 'Control.Monad.filterM'. Draws the values from a 'Source' instead of a list, writes the filtered
-- values to a 'Sink', and returns a 'Coroutine'.
filterMStream :: forall m a1 a2 d x . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)
=> (x -> Coroutine d m Bool) -> Source m a1 x -> Sink m a2 x -> Coroutine d m ()
-filterMStream f source sink = mapMStream_ (\x-> f x >>= cond (put sink x) (return ())) source
-
--- | An equivalent of 'Control.Monad.filterM'; filters a 'Source' instead of a list.
-filterMSource :: forall m a x y . Monad m
- => (forall d. AncestorFunctor a d => x -> Coroutine d m Bool) -> Source m a x -> Source m a x
-filterMSource f source = Source{get= find}
- where find :: forall d. AncestorFunctor a d => Coroutine d m (Maybe x)
- find = get source >>= maybe (return Nothing) (\x-> f x >>= cond (return (Just x)) find)
-
--- | An equivalent of 'Control.Monad.filterM'; filters a 'Sink' instead of a list.
-filterMSink :: forall m a x y . Monad m
- => (forall d. AncestorFunctor a d => x -> Coroutine d m Bool) -> Sink m a x -> Sink m a x
-filterMSink f sink = Sink{put= \x-> f x >>= cond (put sink x) (return ())}
+filterMStream f source sink = mapMStream_ (\x-> f x >>= flip when (put sink x)) source
-- | Similar to 'Data.List.foldl', but reads the values from a 'Source' instead of a list.
foldStream :: forall m a d x acc . (Monad m, AncestorFunctor a d)
=> (acc -> x -> acc) -> acc -> Source m a x -> Coroutine d m acc
foldStream f s source = loop s
- where loop s = get source >>= maybe (return s) (\x-> loop (f s x))
+ where loop s = getChunk source >>= nullOrElse (return s) (loop . foldl f s)
-- | 'foldMStream' is similar to 'Control.Monad.foldM' except it draws the values from a 'Source' instead of a list and
-- works with 'Coroutine' instead of an arbitrary monad.
foldMStream :: forall m a d x acc . (Monad m, AncestorFunctor a d)
=> (acc -> x -> Coroutine d m acc) -> acc -> Source m a x -> Coroutine d m acc
foldMStream f acc source = loop acc
- where loop acc = get source >>= maybe (return acc) (\x-> f acc x >>= loop)
+ where loop acc = getChunk source >>= nullOrElse (return acc) ((loop =<<) . foldM f acc)
--- | A version of 'foldMStream' that ignores the final result value.
+-- | 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 ()
-foldMStream_ f acc source = loop acc
- where loop acc = getWith (\x-> f acc x >>= loop) source
+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 f acc source = loop acc
+ where loop acc = getChunk source >>= nullOrElse (return acc) ((loop =<<) . f acc)
+
-- | '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)
@@ -272,18 +343,26 @@
unmapMStream_ f sink = loop
where loop = f >>= maybe (return ()) (\x-> put sink x >> loop)
--- | 'mapAccumStream' is similar to 'Data.List.mapAccumL' except it reads the values from a 'Source' instead of a list
--- and writes the mapped values into a 'Sink' instead of returning another list.
-mapAccumStream :: forall m a1 a2 d x y acc . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)
- => (acc -> x -> (acc, y)) -> acc -> Source m a1 x -> Sink m a2 y -> Coroutine d m acc
-mapAccumStream f acc source sink = loop acc
- where loop acc = get source >>= maybe (return acc) (\x-> let (acc', y) = f acc x in put sink y >> loop acc')
+-- | 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_ f sink = loop >> return ()
+ where loop = f >>= nullOrElse (return []) ((>>= 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 ()
-partitionStream f source true false = mapMStream_ (\x-> if f x then put true x else put false x) source
+partitionStream f source true false = mapMStreamChunks_ partitionChunk source
+ where partitionChunk (x:rest) = partitionTo (f x) x rest
+ 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
+ in putChunk true (x:trues)
+ >> case rest of y:ys -> partitionTo False y ys
+ [] -> return ()
-- | '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.
@@ -309,15 +388,17 @@
tee :: forall m a1 a2 a3 d x . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d)
=> Source m a1 x -> Sink m a2 x -> Sink m a3 x -> Coroutine d m ()
tee source sink1 sink2 = distribute
- where distribute = get source >>= maybe (return ()) (\x-> put sink1 x >> put sink2 x >> distribute)
+ where distribute = getChunk source
+ >>= nullOrElse (return ()) (\x-> putChunk sink1 x >> putChunk sink2 x >> distribute)
-- | 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@.
+-- equivalent to @put s1 x >> put s2 x@. The 'putChunk' method returns the list of values that couldn't fit into the
+-- second sink.
teeSink :: forall m a1 a2 a3 x . (Monad m, AncestorFunctor a1 a3, AncestorFunctor a2 a3)
=> Sink m a1 x -> Sink m a2 x -> Sink m a3 x
-teeSink s1 s2 = Sink{put= tee}
- where tee :: forall d. AncestorFunctor a3 d => x -> Coroutine d m ()
- tee x = put s1' x >> put s2' x
+teeSink s1 s2 = Sink{putChunk= tee}
+ where tee :: forall d. AncestorFunctor a3 d => [x] -> Coroutine d m [x]
+ tee x = putChunk s1' x >> putChunk s2' x
s1' :: Sink m a3 x
s1' = liftSink s1
s2' :: Sink m a3 x
@@ -327,30 +408,37 @@
-- providing it back.
teeSource :: forall m a1 a2 a3 x . (Monad m, AncestorFunctor a1 a3, AncestorFunctor a2 a3)
=> Sink m a1 x -> Source m a2 x -> Source m a3 x
-teeSource sink source = Source{get= tee}
- where tee :: forall d. AncestorFunctor a3 d => Coroutine d m (Maybe x)
- tee = do mx <- get source'
- maybe (return ()) (put sink') mx
- return mx
+teeSource sink source = Source{foldChunk= tee}
+ where tee :: forall d. AncestorFunctor a3 d => Ticker x -> Coroutine d m ([x], Either x (Ticker x))
+ tee t = do p@(chunk, next) <- foldChunk source' t
+ if null chunk then return [] else putChunk sink' chunk
+ return p
sink' :: Sink m a3 x
sink' = liftSink sink
source' :: Source m a3 x
source' = liftSource source
--- | 'putList' puts entire list into its /sink/ argument.
-putList :: forall m a d x. (Monad m, AncestorFunctor a d) => [x] -> Sink m a x -> Coroutine d m ()
-putList [] sink = return ()
-putList l@(x:rest) sink = put sink x >> putList rest sink
+-- | 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 sink x = putChunk sink [x] >> return ()
--- | 'getList' returns the list of all values generated by the source.
-getList :: forall m a d x. (Monad m, AncestorFunctor a d) => Source m a x -> Coroutine d m [x]
-getList source = getList' return
- where getList' f = get source >>= maybe (f []) (\x-> getList' (f . (x:)))
+-- | 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 sink x = liftM null $ putChunk sink [x]
--- | A utility function wrapping if-then-else, useful for handling monadic truth values
-cond :: a -> a -> Bool -> a
-cond x y test = if test then x else y
+-- | 'putList' 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 tickAll
+
-- | 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 ()
+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
+
+nullOrElse :: a -> ([x] -> a) -> [x] -> a
+nullOrElse null _ [] = null
+nullOrElse _ f list = f list
diff --git a/Control/Concurrent/SCC/Types.hs b/Control/Concurrent/SCC/Types.hs
--- a/Control/Concurrent/SCC/Types.hs
+++ b/Control/Concurrent/SCC/Types.hs
@@ -22,35 +22,32 @@
-- signalling interesting input boundaries by writing into the third sink.
--
-{-# LANGUAGE ScopedTypeVariables, KindSignatures, RankNTypes, ExistentialQuantification,
+{-# LANGUAGE ScopedTypeVariables, KindSignatures, RankNTypes,
MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, FunctionalDependencies, TypeFamilies #-}
+{-# OPTIONS_HADDOCK hide #-}
-module Control.Concurrent.SCC.Types
- (-- * Types
- Performer(..),
- OpenConsumer, Consumer(..), OpenProducer, Producer(..),
- OpenTransducer, Transducer(..), OpenSplitter, Splitter(..),
- Boundary(..), Markup(..), Parser,
- -- * Type classes
- Branching (combineBranches),
- -- * Constructors
- isolateConsumer, isolateProducer, isolateTransducer, isolateSplitter,
- oneToOneTransducer, statelessTransducer, statefulTransducer,
- statelessSplitter, statefulSplitter,
- -- * Utility functions
- splitToConsumers, splitInputToConsumers, pipePS, (>|>), (<|<)
+module Control.Concurrent.SCC.Types (
+ -- * Component types
+ Performer(..),
+ OpenConsumer, Consumer(..), OpenProducer, Producer(..),
+ OpenTransducer, Transducer(..), OpenSplitter, Splitter(..),
+ Boundary(..), Markup(..), Parser,
+ Branching (combineBranches),
+ -- * Component constructors
+ isolateConsumer, isolateProducer, isolateTransducer, isolateSplitter,
+ oneToOneTransducer, statelessTransducer, statefulTransducer,
+ statelessSplitter, statefulSplitter,
)
where
+import Control.Category (Category(..))
+import qualified Control.Category as Category
+
import Control.Monad.Coroutine
import Control.Monad.Parallel (MonadParallel(..))
import Control.Concurrent.SCC.Streams
-import Control.Category (Category(..))
-import Control.Monad (liftM, when)
-import Data.Maybe (maybe)
-
type OpenConsumer m a d x r = AncestorFunctor a d => Source m a x -> Coroutine d m r
type OpenProducer m a d x r = AncestorFunctor a d => Sink m a x -> Coroutine d m r
type OpenTransducer m a1 a2 d x y r =
@@ -86,11 +83,14 @@
-- 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 ()}
--- | A 'Markup' value is produced to mark either a 'Start' and 'End' of a region of data, or an arbitrary
--- 'Point' in data. A 'Point' is semantically equivalent to a 'Start' immediately followed by 'End'. The 'Content'
--- constructor wraps the actual data.
+-- | 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'.
data Boundary y = Start y | End y | Point y deriving (Eq, Show)
+
+-- | Type of values in a markup-up stream. The 'Content' constructor wraps the actual data.
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)
instance Functor Boundary where
@@ -102,8 +102,8 @@
fmap f (Content x) = Content (f x)
fmap f (Markup b) = Markup b
-instance (Show y) => Show (Markup y Char) where
- showsPrec p (Content x) s = x : s
+instance (Show x , Show y) => Show (Markup y x) where
+ showsPrec p (Content x) s = shows x s
showsPrec p (Markup b) s = '[' : shows b (']' : s)
instance Monad m => Category (Transducer m) where
@@ -112,18 +112,6 @@
pipe (transduce t2 source) (\source-> transduce t1 source sink)
>> return ()
--- | Same as 'Control.Category.>>>' except it runs the two transducers in parallel.
-(>|>) :: MonadParallel m => Transducer m x y -> Transducer m y z -> Transducer m x z
-t1 >|> t2 = isolateTransducer $ \source sink->
- pipeP (transduce t1 source) (\source-> transduce t2 source sink)
- >> return ()
-
--- | Same as 'Control.Category.<<<' except it runs the two transducers in parallel.
-(<|<) :: MonadParallel m => Transducer m y z -> Transducer m x y -> Transducer m x z
-t1 <|< t2 = isolateTransducer $ \source sink->
- pipeP (transduce t2 source) (\source-> transduce t1 source sink)
- >> return ()
-
-- | Creates a proper 'Consumer' from a function that is, but can't be proven to be, an 'OpenConsumer'.
isolateConsumer :: forall m x r. Monad m => (forall d. Functor d => Source m d x -> Coroutine d m r) -> Consumer m x r
isolateConsumer consume = Consumer consume'
@@ -173,19 +161,19 @@
class Branching c (m :: * -> *) x r | c -> m x where
-- | 'combineBranches' is used to combine two values of 'Branch' class into one, using the given 'Consumer' binary
-- combinator.
- combineBranches :: (forall d. (Bool ->
+ combineBranches :: (forall d. (PairBinder m ->
(forall a d'. AncestorFunctor d d' => OpenConsumer m a d' x r) ->
(forall a d'. AncestorFunctor d d' => OpenConsumer m a d' x r) ->
(forall a. OpenConsumer m a d x r))) ->
- Bool -> c -> c -> c
+ PairBinder m -> c -> c -> c
instance forall m x r. Monad m => Branching (Consumer m x r) m x r where
- combineBranches combinator parallel c1 c2 = Consumer $ combinator parallel (consume c1) (consume c2)
+ combineBranches combinator binder c1 c2 = Consumer $ combinator binder (consume c1) (consume c2)
instance forall m x y. Monad m => Branching (Transducer m x y) m x () where
- combineBranches combinator parallel t1 t2
+ combineBranches combinator binder t1 t2
= let transduce' :: forall a1 a2 d. OpenTransducer m a1 a2 d x y ()
- transduce' source sink = combinator parallel
+ transduce' source sink = combinator binder
(\source-> transduce t1 source sink')
(\source-> transduce t2 source sink')
source
@@ -193,10 +181,10 @@
sink' = liftSink sink
in Transducer transduce'
-instance forall m x b. (MonadParallel m) => Branching (Splitter m x b) m x () where
- combineBranches combinator parallel s1 s2
+instance forall m x b. Monad m => Branching (Splitter m x b) 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 parallel
+ split' source true false edge = combinator binder
(\source-> split s1 source true' false' edge')
(\source-> split s2 source true' false' edge')
source
@@ -216,7 +204,7 @@
-- | Function 'statelessTransducer' takes a function that maps one input value into a list of output values, and
-- lifts it into a 'Transducer'.
statelessTransducer :: Monad m => (x -> [y]) -> Transducer m x y
-statelessTransducer f = Transducer (\source sink-> mapMStream_ (\x-> putList (f x) sink) source)
+statelessTransducer f = Transducer (concatMapStream 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.
@@ -237,40 +225,3 @@
foldMStream_
(\ s x -> let (s', truth) = f s x in (if truth then put true x else put false x) >> return s')
s0 source)
-
--- | Given a 'Splitter', a 'Source', and three consumer functions, 'splitToConsumers' runs the splitter on the source
--- and feeds the splitter's outputs to its /true/, /false/, and /edge/ sinks, respectively, to the three consumers.
-splitToConsumers :: (Functor d, Monad m, d1 ~ SinkFunctor d x, AncestorFunctor a (SinkFunctor (SinkFunctor d1 x) b)) =>
- Splitter m x b ->
- Source m a x ->
- (Source m (SourceFunctor d x) x -> Coroutine (SourceFunctor d x) m r1) ->
- (Source m (SourceFunctor d1 x) x -> Coroutine (SourceFunctor d1 x) m r2) ->
- (Source m (SourceFunctor (SinkFunctor d1 x) b) b
- -> Coroutine (SourceFunctor (SinkFunctor d1 x) b) m r3) ->
- Coroutine d m ((), r1, r2, r3)
-splitToConsumers s source trueConsumer falseConsumer edgeConsumer
- = pipe
- (\true-> pipe
- (\false-> pipe
- (split s source true false)
- edgeConsumer)
- falseConsumer)
- trueConsumer
- >>= \(((extra, r3), r2), r1)-> return (extra, r1, r2, r3)
-
--- | Given a 'Splitter', a 'Source', and two consumer functions, 'splitInputToConsumers' runs the splitter on the source
--- and feeds the splitter's /true/ and /false/ outputs, respectively, to the two consumers.
-splitInputToConsumers :: forall m a d d1 x b. (MonadParallel m, d1 ~ SinkFunctor d x, AncestorFunctor a d) =>
- Bool -> Splitter m x b -> Source m a x ->
- (Source m (SourceFunctor d1 x) x -> Coroutine (SourceFunctor d1 x) m ()) ->
- (Source m (SourceFunctor d x) x -> Coroutine (SourceFunctor d x) m ()) ->
- Coroutine d m ()
-splitInputToConsumers parallel s source trueConsumer falseConsumer
- = pipePS parallel
- (\false-> pipePS parallel
- (\true-> split s source' true false (nullSink :: Sink m d b))
- trueConsumer)
- falseConsumer
- >> return ()
- where source' :: Source m d x
- source' = liftSource source
diff --git a/Control/Concurrent/SCC/XML.hs b/Control/Concurrent/SCC/XML.hs
--- a/Control/Concurrent/SCC/XML.hs
+++ b/Control/Concurrent/SCC/XML.hs
@@ -16,23 +16,20 @@
-- | Module "XML" defines primitives and combinators for parsing and manipulating XML.
-{-# LANGUAGE PatternGuards, ScopedTypeVariables #-}
+{-# LANGUAGE PatternGuards, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables, Rank2Types #-}
+{-# OPTIONS_HADDOCK hide #-}
module Control.Concurrent.SCC.XML (
--- * Types
-Token (..),
--- * Parsing XML
-tokens, parseTokens, expandEntity,
--- * Showing XML
-escapeAttributeCharacter, escapeContentCharacter,
--- * Splitters
-element, elementContent, elementName, attribute, attributeName, attributeValue,
--- * SplitterComponent combinators
-elementHavingTag, havingText, havingOnlyText
-)
+ -- * Parsing XML
+ xmlTokens, parseXMLTokens, expandXMLEntity, XMLToken(..),
+ -- * XML splitters
+ xmlElement, xmlElementContent, xmlElementName, xmlAttribute, xmlAttributeName, xmlAttributeValue, xmlElementHavingTagWith
+ )
where
import Prelude hiding (mapM)
+import Control.Category ((>>>))
+import qualified Control.Category as Category
import Control.Exception (assert)
import Control.Monad (join, liftM, when)
import Data.Char
@@ -40,8 +37,10 @@
import Data.Maybe (fromJust, isJust, mapMaybe)
import Data.List (find, stripPrefix)
import qualified Data.Sequence as Seq
-import Data.Sequence ((|>))
+import Data.Sequence (Seq, (|>))
import Data.Traversable (Traversable, mapM)
+import Data.Text (Text, append)
+import qualified Data.Text as Text
import Numeric (readDec, readHex)
import Debug.Trace (trace)
@@ -50,191 +49,173 @@
import Control.Concurrent.SCC.Streams
import Control.Concurrent.SCC.Types
-import Control.Concurrent.SCC.Combinators (groupMarks, splitterToMarker, parseNestedRegions,
+import Control.Concurrent.SCC.Coercions (coerce)
+import Control.Concurrent.SCC.Combinators (groupMarks, parseEachNestedRegion, splitterToMarker,
findsTrueIn, findsFalseIn, teeConsumers)
+import Control.Concurrent.SCC.Primitives (group)
-data Token = StartTag | EndTag | EmptyTag
- | ElementName | AttributeName | AttributeValue
- | EntityReferenceToken | EntityName
- | ProcessingInstruction | ProcessingInstructionText
- | Comment | CommentText
- | StartMarkedSectionCDATA | EndMarkedSection
- | ErrorToken String
- deriving (Eq, Show)
-
-
--- | Escapes a character for inclusion into an XML attribute value.
-escapeAttributeCharacter :: Char -> String
-escapeAttributeCharacter '"' = """
-escapeAttributeCharacter '\t' = " "
-escapeAttributeCharacter '\n' = "
"
-escapeAttributeCharacter '\r' = "
"
-escapeAttributeCharacter x = escapeContentCharacter x
-
--- | Escapes a character for inclusion into the XML data content.
-escapeContentCharacter :: Char -> String
-escapeContentCharacter '<' = "<"
-escapeContentCharacter '&' = "&"
-escapeContentCharacter x = [x]
+data XMLToken = StartTag | EndTag | EmptyTag
+ | ElementName | AttributeName | AttributeValue
+ | EntityReferenceToken | EntityName
+ | ProcessingInstruction | ProcessingInstructionText
+ | Comment | CommentText
+ | StartMarkedSectionCDATA | EndMarkedSection
+ | ErrorToken String
+ deriving (Eq, Show)
--- | Converts an XML entity name into the text value it represents: @expandEntity \"lt\" = \"<\"@.
-expandEntity :: String -> String
-expandEntity "lt" = "<"
-expandEntity "gt" = ">"
-expandEntity "quot" = "\""
-expandEntity "apos" = "'"
-expandEntity "amp" = "&"
-expandEntity ('#' : 'x' : codePoint) = [chr (fst $ head $ readHex codePoint)]
-expandEntity ('#' : codePoint) = [chr (fst $ head $ readDec codePoint)]
+-- | Converts an XML entity name into the text value it represents: @expandXMLEntity \"lt\" = \"<\"@.
+expandXMLEntity :: String -> String
+expandXMLEntity "lt" = "<"
+expandXMLEntity "gt" = ">"
+expandXMLEntity "quot" = "\""
+expandXMLEntity "apos" = "'"
+expandXMLEntity "amp" = "&"
+expandXMLEntity ('#' : 'x' : codePoint) = [chr (fst $ head $ readHex codePoint)]
+expandXMLEntity ('#' : codePoint) = [chr (fst $ head $ readDec codePoint)]
isNameStart x = isLetter x || x == '_'
isNameChar x = isAlphaNum x || x == '_' || x == '-'
--- | The 'tokens' splitter distinguishes XML markup from data content. It is used by 'parseTokens'.
-tokens :: Monad m => Splitter m Char (Boundary Token)
-tokens = Splitter $
- \source true false edge->
- let getContent = getWith content source
- content '<' = getWith (\x-> tag x >> getWith content source) source
- content '&' = entity >> getWith content source
- content x = put false x
- >> getContent
- tag '?' = do put edge (Start ProcessingInstruction)
- putList " put edge (Point (errorBadDeclarationType other)))
- [("--",
- \match-> do put edge (Start Comment)
- putList match true
- put edge (Start CommentText)
- comment),
- ("[CDATA[",
- \match-> do put edge (Start StartMarkedSectionCDATA)
- putList match true
- put edge (End StartMarkedSectionCDATA)
- markedSection)]
- tag '/' = {-# SCC "EndTag" #-}
- do put edge (Start EndTag)
- put true '<'
- put true '/'
- next errorInputEndInEndTag
- (\x-> name ElementName x
- >>= maybe
- (put edge (Point errorInputEndInEndTag))
- (\x-> do put true x
- when (x /= '>') (put edge (Point (errorBadEndTag x)))))
- put edge (End EndTag)
- tag x | isNameStart x = {-# SCC "StartTag" #-}
- put edge (Start StartTag)
- >> put true '<'
- >> name ElementName x
- >>= maybe
- (put edge (Point errorInputEndInStartTag))
- (\y-> attributes y
- >>= maybe
- (put edge (Point errorInputEndInStartTag))
- startTagEnd)
- >> put edge (End StartTag)
- tag x = put edge (Point errorUnescapedContentLT)
- >> put false '<'
- >> put false x
- startTagEnd '/' = put true '/'
- >> put edge (Point EmptyTag)
- >> next errorInputEndInStartTag
- (\x-> put true x >> when (x /= '>') (put edge (Point (errorBadStartTag x))))
- startTagEnd '>' = put true '>'
- startTagEnd x = put true x
- >> put edge (Point (errorBadStartTag x))
- attributes x | isSpace x = put true x >> get source >>= mapJoinM attributes
- attributes x | isNameStart x
- = name AttributeName x
- >>= mapJoinM
- (\y-> do when (y /= '=') (put edge (Point (errorBadAttribute y)))
- q <- if y == '"' || y == '\''
- then return y
- else put true y >> get source
- >>= maybe
- (put edge (Point errorInputEndInAttributeValue)
- >> return '"')
- return
- when (q /= '"' && q /= '\'') (put edge (Point (errorBadQuoteCharacter q)))
- put true q
- put edge (Start AttributeValue)
- get source
- >>= maybe
- (put edge (Point errorInputEndInAttributeValue)
- >> put edge (End AttributeValue))
- (attributeValue q)
- get source >>= mapJoinM attributes)
- attributes x = return (Just x)
- attributeValue q x | q == x = do put edge (End AttributeValue)
- put true x
- attributeValue q '<' = do put edge (Start errorUnescapedAttributeLT)
- put true '<'
- put edge (End errorUnescapedAttributeLT)
- next errorInputEndInAttributeValue (attributeValue q)
- attributeValue q '&' = entity >> next errorInputEndInAttributeValue (attributeValue q)
- attributeValue q x = put true x >> next errorInputEndInAttributeValue (attributeValue q)
- processingInstruction = {-# SCC "PI" #-}
- dispatchOnString source
- (\other-> if null other
- then put edge (Point errorInputEndInProcessingInstruction)
- else putList other true >> processingInstruction)
- [("?>",
- \match-> do put edge (End ProcessingInstructionText)
- putList match true
- put edge (End ProcessingInstruction)
- getContent)]
- comment = {-# SCC "comment" #-}
- dispatchOnString source
- (\other-> if null other
- then put edge (Point errorInputEndInComment)
- else putList other true >> comment)
- [("-->",
- \match-> do put edge (End CommentText)
- putList match true
- put edge (End Comment)
- getContent)]
- markedSection = {-# SCC " if null other
- then put edge (Point errorInputEndInMarkedSection)
- else putList other true >> markedSection)
- [("]]>",
- \match-> do put edge (Start EndMarkedSection)
- putList match true
- put edge (End EndMarkedSection)
- getContent)]
- entity = put edge (Start EntityReferenceToken)
- >> put true '&'
- >> next errorInputEndInEntityReference
- (\x-> name EntityName x
- >>= maybe
- (put edge (Point errorInputEndInEntityReference))
- (\x-> do when (x /= ';') (put edge (Point (errorBadEntityReference x)))
- put true x))
- >> put edge (End EntityReferenceToken)
- name token x | isNameStart x = {-# SCC "name" #-}
- put edge (Start token)
- >> put true x
- >> get source
- >>= maybe
- (put edge (End token) >> return Nothing)
- (nameTail token)
- name _ x = return (Just x)
- nameTail token x = if isNameChar x || x == ':'
- then put true x
- >> get source
- >>= maybe
- (put edge (End token) >> return Nothing)
- (nameTail token)
- else put edge (End token) >> return (Just x)
- next error f = get source
- >>= maybe (put edge (Point error)) f
- in getContent
+-- | This splitter splits XML markup from data content. It is used by 'parseXMLTokens'.
+xmlTokens :: Monad m => Splitter m Char (Boundary XMLToken)
+xmlTokens = Splitter $
+ \source true false edge->
+ let getContent = pourWhile (\x-> x /= '<' && x /= '&') source false
+ >> getWith contentEnd source
+ contentEnd '<' = get source
+ >>= maybe
+ (put edge (Point errorUnescapedContentLT) >> put false '<')
+ (\x-> tag x >> getContent)
+ contentEnd '&' = entity >> getContent
+ tag '?' = do put edge (Start ProcessingInstruction)
+ putList " put edge (Point (errorBadDeclarationType other)))
+ [("--",
+ \match-> do put edge (Start Comment)
+ putList match true
+ put edge (Start CommentText)
+ comment),
+ ("[CDATA[",
+ \match-> do put edge (Start StartMarkedSectionCDATA)
+ putList match true
+ put edge (End StartMarkedSectionCDATA)
+ markedSection)]
+ tag '/' = {-# SCC "EndTag" #-}
+ do put edge (Start EndTag)
+ putList " isNameChar x || x == ':') source
+ if null name
+ then put edge (Point errorNamelessEndTag)
+ else put edge (Start ElementName)
+ >> putList name true
+ >> put edge (End ElementName)
+ pourUntil (not . isSpace) source true
+ >>= maybe
+ (put edge (Point errorInputEndInEndTag))
+ (\x-> if x == '>'
+ then getWith (put true) source
+ else put edge (Point (errorBadEndTag x)))
+ put edge (End EndTag)
+ tag x | isNameStart x = {-# SCC "StartTag" #-}
+ put edge (Start StartTag)
+ >> put true '<'
+ >> name ElementName x
+ >> attributes
+ >> put edge (End StartTag)
+ tag x = put edge (Point errorUnescapedContentLT)
+ >> put false '<'
+ >> put false x
+ startTagEnd '/' = get source
+ >> put edge (Point EmptyTag)
+ >> next errorInputEndInStartTag
+ (\x-> do when (x /= '>' ) (put edge (Point (errorBadStartTag x)))
+ putList ['/', x] true
+ return ())
+ startTagEnd '>' = getWith (put true) source
+ startTagEnd x = put edge (Point (errorBadStartTag x))
+ attributes= pourUntil (not . isSpace) source true
+ >>= maybe
+ (put edge (Point errorInputEndInStartTag))
+ (\x-> if isNameStart x then attribute >> attributes else startTagEnd x)
+ attribute= do put edge (Start AttributeName)
+ pourWhile (\x-> isNameChar x || x == ':') source true
+ put edge (End AttributeName)
+ next errorInputEndInStartTag
+ (\y-> do when (y /= '=') (put edge (Point (errorBadAttribute y)))
+ q <- if y == '"' || y == '\''
+ then return y
+ else put true y
+ >> get source
+ >>= maybe
+ (put edge (Point errorInputEndInAttributeValue)
+ >> return '"')
+ return
+ when (q /= '"' && q /= '\'') (put edge (Point (errorBadQuoteCharacter q)))
+ put true q
+ put edge (Start AttributeValue)
+ attributeValue q
+ put edge (End AttributeValue)
+ put true q)
+ attributeValue q = pourWhile (\x-> (x /= q && x/= '<' && x /= '&')) source true
+ >> next errorInputEndInAttributeValue
+ (\x-> case x
+ of '<' -> do put edge (Start errorUnescapedAttributeLT)
+ put true '<'
+ put edge (End errorUnescapedAttributeLT)
+ attributeValue q
+ '&' -> entity >> attributeValue q
+ _ -> return ())
+ processingInstruction = {-# SCC "PI" #-}
+ dispatchOnString source
+ (\other-> if null other
+ then put edge (Point errorInputEndInProcessingInstruction)
+ else putList other true >> processingInstruction)
+ [("?>",
+ \match-> do put edge (End ProcessingInstructionText)
+ putList match true
+ put edge (End ProcessingInstruction)
+ getContent)]
+ comment = {-# SCC "comment" #-}
+ dispatchOnString source
+ (\other-> if null other
+ then put edge (Point errorInputEndInComment)
+ else putList other true >> comment)
+ [("-->",
+ \match-> do put edge (End CommentText)
+ putList match true
+ put edge (End Comment)
+ getContent)]
+ markedSection = {-# SCC " if null other
+ then put edge (Point errorInputEndInMarkedSection)
+ else putList other true >> markedSection)
+ [("]]>",
+ \match-> do put edge (Start EndMarkedSection)
+ putList match true
+ put edge (End EndMarkedSection)
+ getContent)]
+ entity = put edge (Start EntityReferenceToken)
+ >> put true '&'
+ >> next errorInputEndInEntityReference
+ (\x-> name EntityName x
+ >> next errorInputEndInEntityReference
+ (\x-> do when (x /= ';') (put edge (Point (errorBadEntityReference x)))
+ put true x))
+ >> put edge (End EntityReferenceToken)
+ name token x = {-# SCC "name" #-}
+ put edge (Start token)
+ >> nameTail x
+ >> put edge (End token)
+ nameTail x = getWhile (\x-> isNameChar x || x == ':') source
+ >>= \tail-> putList (x:tail) true
+ next error f = get source
+ >>= maybe (put edge (Point error)) f
+ in getContent
errorInputEndInComment = ErrorToken "Unterminated comment"
errorInputEndInMarkedSection = ErrorToken "Unterminated marked section"
@@ -250,13 +231,14 @@
errorBadAttributeValue x = ErrorToken ("Invalid character " ++ show x ++ " in attribute value.")
errorBadEntityReference x = ErrorToken ("Invalid character " ++ show x ++ " ends entity name.")
errorBadDeclarationType other = ErrorToken ("Expecting Parser m Char Token
-parseTokens = parseNestedRegions tokens
+parseXMLTokens :: MonadParallel m => Transducer m Char (Markup XMLToken Text)
+parseXMLTokens = parseEachNestedRegion sequentialBinder xmlTokens coerce
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)]
@@ -275,8 +257,8 @@
| otherwise = Nothing
getElementName :: forall m a d. (Monad m, AncestorFunctor a d) =>
- Source m a (Markup Token Char) -> ([Markup Token Char] -> [Markup Token Char])
- -> Coroutine d m ([Markup Token Char], Maybe String)
+ 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
(return (f [], Nothing))
@@ -287,51 +269,57 @@
_ -> error ("Expected an ElementName, received " ++ show x))
getRestOfRegion :: forall m a d. (Monad m, AncestorFunctor a d) =>
- Token -> Source m a (Markup Token Char)
- -> ([Markup Token Char] -> [Markup Token Char]) -> (String -> String)
- -> Coroutine d m ([Markup Token Char], Maybe String)
-getRestOfRegion token source f g = get source
- >>= maybe
- (return (f [], Nothing))
- (\x-> case x
- of Markup (End token) -> return (f [x], Just (g ""))
- Content y -> getRestOfRegion token source (f . (x:)) (g . (y:))
- _ -> error ("Expected rest of " ++ show token
- ++ ", received " ++ show x))
+ 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
+ >>= \content-> get source
+ >>= \x-> case x
+ of Just y@(Markup (End token))
+ -> return (f (content ++ [y]),
+ Just (g $ Text.concat $ map fromContent content))
+ _ -> 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) =>
- Token -> Source m a1 (Markup Token Char)
- -> Sink m a2 (Markup Token Char) -> Sink m a3 (Markup Token Char)
+ 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
- = get source
- >>= maybe
- (return False)
- (\x-> case x
- of Markup (End token') | token == token' -> put endSink x
- >> return True
- Content y -> put sink x
- >> pourRestOfRegion token source sink endSink
- _ -> error ("Expected rest of " ++ show token ++ ", received " ++ show x))
+pourRestOfRegion token source sink endSink = pourWhile isContent source sink
+ >> get source
+ >>= maybe
+ (return False)
+ (\x-> case x
+ of Markup (End token') | token == token' -> put endSink x
+ >> return True
+ _ -> error ("Expected rest of " ++ show token
+ ++ ", received " ++ show x))
pourRestOfTag :: forall m a1 a2 d. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d) =>
- Source m a1 (Markup Token Char) -> Sink m a2 (Markup Token Char) -> Coroutine d m Bool
-pourRestOfTag source sink = get source
- >>= maybe
+ Source m a1 (Markup XMLToken Text) -> Sink m a2 (Markup XMLToken Text) -> Coroutine d m Bool
+pourRestOfTag source sink = pourUntil isEndTag source sink
+ >>= maybe
(return True)
(\x-> put sink x
+ >> get source
>> case x of Markup (End StartTag) -> return True
Markup (End EndTag) -> return True
Markup (Point EmptyTag) -> pourRestOfTag source sink
- >> return False
- _ -> pourRestOfTag source sink)
+ >> return False)
+ where isEndTag (Markup (End StartTag)) = True
+ isEndTag (Markup (End EndTag)) = True
+ isEndTag (Markup (Point EmptyTag)) = True
+ isEndTag _ = False
findEndTag :: forall m a1 a2 a3 d. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d) =>
- Source m a1 (Markup Token Char) -> Sink m a2 (Markup Token Char) -> Sink m a3 (Markup Token Char)
- -> String
+ 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 = find where
- find = getWith consumeOne source
+ find = pourUntil isTagStart source sink
+ >>= maybe (return ()) (\x-> get source >> consumeOne x)
+ isTagStart (Markup (Start StartTag)) = True
+ isTagStart (Markup (Start EndTag)) = True
+ isTagStart _ = False
consumeOne x@(Markup (Start EndTag)) = do (tokens, mn) <- getElementName source (x :)
maybe
(return ())
@@ -354,120 +342,116 @@
else pourRestOfTag source sink
>> find)
mn
- consumeOne x = put sink x >> find
findStartTag :: forall m a1 a2 d. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d) =>
- Source m a1 (Markup Token Char) -> Sink m a2 (Markup Token Char)
- -> Coroutine d m (Maybe (Markup Token Char))
-findStartTag source sink = get source
- >>= maybe
- (return Nothing)
- (\x-> case x of Markup (Start StartTag) -> return $ Just x
- _ -> put sink x
- >> findStartTag source sink)
+ Source m a1 (Markup XMLToken Text) -> Sink m a2 (Markup XMLToken Text)
+ -> Coroutine d m (Maybe (Markup XMLToken Text))
+findStartTag source sink = pourUntil isStartTag source sink >> get source
+ where isStartTag (Markup (Start StartTag)) = True
+ isStartTag _ = False
-- | Splits all top-level elements with all their content to /true/, all other input to /false/.
-element :: Monad m => Splitter m (Markup Token Char) ()
-element = Splitter $
- \source true false edge->
- let split0 = findStartTag source false
- >>= maybe (return ())
- (\x-> do put edge ()
- put true x
- (tokens, mn) <- getElementName source id
- maybe
- (putList tokens true)
- (\name-> putList tokens true
- >> pourRestOfTag source true
- >>= cond
- (split1 name)
- split0)
- mn)
- split1 name = findEndTag source true true name
- >> split0
- in split0
+xmlElement :: Monad m => Splitter m (Markup XMLToken Text) ()
+xmlElement = Splitter $
+ \source true false edge->
+ let split0 = findStartTag source false
+ >>= maybe (return [])
+ (\x-> do put edge ()
+ put true x
+ (tokens, mn) <- getElementName source id
+ maybe
+ (putList tokens true)
+ (\name-> do putList tokens true
+ hasContent <- pourRestOfTag source true
+ if hasContent
+ then split1 name
+ else split0)
+ mn)
+ split1 name = findEndTag source true true name
+ >> split0
+ in split0 >> return ()
-- | Splits the content of all top-level elements to /true/, their tags and intervening input to /false/.
-elementContent :: Monad m => Splitter m (Markup Token Char) ()
-elementContent = Splitter $
- \source true false edge->
- let split0 = findStartTag source false
- >>= maybe (return ())
- (\x-> do put false x
- (tokens, mn) <- getElementName source id
- maybe
- (putList tokens false)
- (\name-> putList tokens false
- >> pourRestOfTag source false
- >>= cond
- (put edge ()
- >> split1 name)
- split0)
- mn)
- split1 name = findEndTag source true false name
- >> split0
- in split0
+xmlElementContent :: Monad m => Splitter m (Markup XMLToken Text) ()
+xmlElementContent = Splitter $
+ \source true false edge->
+ let split0 = findStartTag source false
+ >>= maybe (return [])
+ (\x-> do put false x
+ (tokens, mn) <- getElementName source id
+ maybe
+ (putList tokens false)
+ (\name-> do putList tokens false
+ hasContent <- pourRestOfTag source false
+ if hasContent
+ then put edge () >> split1 name
+ else split0)
+ mn)
+ split1 name = findEndTag source true false name
+ >> split0
+ in split0 >> return ()
-- | Similiar to @('Control.Concurrent.SCC.Combinators.having' 'element')@, except it runs the argument splitter
-- only on each element's start tag, not on the entire element with its content.
-elementHavingTag :: forall m b. MonadParallel m =>
- Splitter m (Markup Token Char) b -> Splitter m (Markup Token Char) b
-elementHavingTag test =
- isolateSplitter $ \ source true false edge ->
- let split0 = findStartTag source false
- >>= maybe (return ())
- (\x-> do (tokens, mn) <- getElementName source (x :)
- maybe
- (return ())
- (\name-> do (hasContent, rest) <- pipe
- (pourRestOfTag source)
- getList
- 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)
- mn)
- split1 hasContent sink name = when hasContent (findEndTag source sink sink name)
- >> split0
- in split0
+xmlElementHavingTagWith :: forall m b. MonadParallel m =>
+ Splitter m (Markup XMLToken Text) b -> Splitter m (Markup XMLToken Text) b
+xmlElementHavingTagWith test =
+ isolateSplitter $ \ source true false edge ->
+ let split0 = findStartTag source false
+ >>= maybe (return ())
+ (\x-> do (tokens, mn) <- getElementName source (x :)
+ maybe
+ (return ())
+ (\name-> do (hasContent, rest) <- pipe
+ (pourRestOfTag source)
+ getList
+ 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)
+ 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/.
-attribute :: Monad m => Splitter m (Markup Token Char) ()
-attribute = Splitter $
- \source true false edge->
- let split0 = getWith
- (\x-> case x
- of Markup (Start AttributeName) -> do put edge ()
- put true x
- pourRestOfRegion AttributeName source true true
- >>= flip when split1
- _ -> put false x >> split0)
- source
- split1 = getWith
- (\x-> case x
- of Markup (Start AttributeValue)
- -> put true x
- >> pourRestOfRegion AttributeValue source true true
- >>= flip when split0
- _ -> put true x >> split1)
- source
- in split0
+xmlAttribute :: Monad m => Splitter m (Markup XMLToken Text) ()
+xmlAttribute = Splitter $
+ \source true false edge->
+ let split0 = getWith
+ (\x-> case x
+ of Markup (Start AttributeName) ->
+ do put edge ()
+ put true x
+ pourRestOfRegion AttributeName source true true
+ >>= flip when split1
+ _ -> put false x >> split0)
+ source
+ split1 = getWith
+ (\x-> case x
+ of Markup (Start AttributeValue)
+ -> put true x
+ >> pourRestOfRegion AttributeValue source true true
+ >>= flip when split0
+ _ -> put true x >> split1)
+ source
+ in split0
-- | Splits every element name, including the names of nested elements and names in end tags, to /true/, all the rest of
-- input to /false/.
-elementName :: Monad m => Splitter m (Markup Token Char) ()
-elementName = Splitter (splitSimpleRegions ElementName)
+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/.
-attributeName :: Monad m => Splitter m (Markup Token Char) ()
-attributeName = Splitter (splitSimpleRegions AttributeName)
+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/.
-attributeValue :: Monad m => Splitter m (Markup Token Char) ()
-attributeValue = Splitter (splitSimpleRegions AttributeValue)
+xmlAttributeValue :: Monad m => Splitter m (Markup XMLToken Text) ()
+xmlAttributeValue = Splitter (splitSimpleRegions AttributeValue)
splitSimpleRegions token source true false edge = split
where split = getWith consumeOne source
@@ -477,45 +461,13 @@
>>= flip when split
consumeOne x = put false x >> split
--- | Behaves like 'Control.Concurrent.SCC.Combinators.having', but the right-hand splitter works on plain instead of
--- marked-up text. This allows regular 'Char' splitters to be applied to parsed XML.
-havingText :: forall m b1 b2. MonadParallel m =>
- Bool -> Splitter m (Markup Token Char) b1 -> Splitter m Char b2 -> Splitter m (Markup Token Char) b1
-havingText parallel chunker tester = isolateSplitter havingText' where
- havingText' source true false edge =
- let test Nothing chunk = pour chunk false
- test (Just mb) chunk = teeConsumers False getList (findsTrueIn tester . mapMaybeSource justContent) chunk
- >>= \(chunk, found)->
- if isJust found
- then maybe (return ()) (put edge) mb
- >> putList chunk true
- else putList chunk false
- in liftM fst $
- pipePS parallel
- (transduce (splitterToMarker chunker) source)
- (flip groupMarks test)
-
--- | Behaves like 'Control.Concurrent.SCC.Combinators.havingOnly', but the right-hand splitter works on plain instead of
--- marked-up text. This allows regular 'Char' splitters to be applied to parsed XML.
-havingOnlyText :: forall m b1 b2. MonadParallel m =>
- Bool -> Splitter m (Markup Token Char) b1 -> Splitter m Char b2 -> Splitter m (Markup Token Char) b1
-havingOnlyText parallel chunker tester = isolateSplitter havingOnlyText' where
- havingOnlyText' source true false edge =
- let test Nothing chunk = pour chunk false
- test (Just mb) chunk = teeConsumers False getList (findsFalseIn tester . mapMaybeSource justContent) chunk
- >>= \(chunk, found)->
- if found
- then putList chunk false
- else maybe (return ()) (put edge) mb
- >> putList chunk true
- in liftM fst $
- pipePS parallel
- (transduce (splitterToMarker chunker) source)
- (flip groupMarks test)
-
justContent (Content x) = Just x
justContent _ = Nothing
+isContent (Content x) = True
+isContent _ = False
+
+fromContent (Content x) = x
+
mapJoinM :: (Monad m, Monad t, Traversable t) => (a -> m (t b)) -> t a -> m (t b)
mapJoinM f ta = mapM f ta >>= return . join
-
diff --git a/Makefile b/Makefile
--- a/Makefile
+++ b/Makefile
@@ -1,10 +1,18 @@
-Executables=test test-prof test-coroutine test-parallel shsh shsh-prof
-LibraryFiles=$(addprefix Control/Concurrent/SCC/, \
- Streams.hs Types.hs Primitives.hs Combinators.hs Components.hs XML.hs) \
- Control/Monad/Parallel.hs Control/Monad/Coroutine.hs \
- Control/Monad/Coroutine/SuspensionFunctors.hs Control/Monad/Coroutine/Nested.hs \
- Control/Concurrent/Configuration.hs
-DocumentationFiles=$(LibraryFiles)
+Executables=test test-prof test-coroutine test-enumerator test-enumerator-scc test-parallel shsh shsh-prof
+CoroutineLibraryFiles=Control/Cofunctor/Ticker.hs \
+ $(addprefix Control/Monad/, \
+ Parallel.hs Coroutine.hs Coroutine/SuspensionFunctors.hs Coroutine/Nested.hs)
+SCCCommonFiles=$(CoroutineLibraryFiles) \
+ Control/Concurrent/Configuration.hs \
+ $(addprefix Control/Concurrent/SCC/, \
+ Streams.hs Types.hs Coercions.hs Primitives.hs Configurable.hs XML.hs)
+AllLibraryFiles=$(SCCCommonFiles) Control/Monad/Coroutine/Enumerator.hs \
+ Control/Concurrent/SCC/Combinators.hs \
+ Control/Concurrent/SCC/Combinators/Parallel.hs Control/Concurrent/SCC/Combinators/Sequential.hs \
+ Control/Concurrent/SCC/Parallel.hs Control/Concurrent/SCC/Sequential.hs
+DocumentationFiles=$(SCCCommonFiles) Control/Monad/Coroutine/Enumerator.hs \
+ Control/Concurrent/SCC/Combinators/Parallel.hs Control/Concurrent/SCC/Combinators/Sequential.hs \
+ Control/Concurrent/SCC/Parallel.hs Control/Concurrent/SCC/Sequential.hs
OptimizingOptions=-O -threaded -hidir obj -odir obj
ProfilingOptions=-prof -auto-all -hidir prof -odir prof
@@ -12,31 +20,43 @@
docs: doc/index.html
-test: Test.hs $(LibraryFiles) | obj
+test: Test.hs $(AllLibraryFiles) | obj
ghc --make $< -o $@ $(OptimizingOptions)
-test-prof: Test.hs $(LibraryFiles) | prof
+test-prof: Test.hs $(AllLibraryFiles) | prof
ghc --make $< -o $@ $(ProfilingOptions)
-test-coroutine: TestCoroutine.hs Control/Monad/Coroutine.hs Control/Monad/Coroutine/*.hs | obj
- ghc --make $< -o $@ $(OptimizingOptions)
+test-coroutine: TestCoroutine.hs $(CoroutineLibraryFiles) | obj
+ ghc --make $< -o $@ $(OptimizingOptions) -threaded -eventlog
+test-enumerator: TestEnumerator.hs $(CoroutineLibraryFiles) Control/Monad/Coroutine/Enumerator.hs | obj
+ ghc --make $< -o $@ $(OptimizingOptions) -threaded -eventlog
+
+test-enumerator-scc: TestEnumeratorSCC.hs $(SCCCommonFiles) \
+ Control/Monad/Coroutine/Enumerator.hs \
+ Control/Concurrent/SCC/Combinators/Sequential.hs Control/Concurrent/SCC/Sequential.hs | obj
+ ghc --make $< -o $@ $(OptimizingOptions) -threaded -eventlog
+
test-parallel: TestParallel.hs Control/Monad/Parallel.hs | obj
- ghc --make $< -o $@ $(OptimizingOptions)
+ ghc --make $< -o $@ $(OptimizingOptions) -threaded -eventlog
-shsh: Shell.hs $(LibraryFiles) | obj
+shsh: Shell.hs $(AllLibraryFiles) | obj
ghc --make $< -o $@ $(OptimizingOptions)
-shsh-prof: Shell.hs $(LibraryFiles) | prof
+shsh-prof: Shell.hs $(AllLibraryFiles) | prof
ghc --make $< -o $@ $(ProfilingOptions)
doc/index.html: $(DocumentationFiles)
- haddock -v -h -o doc \
- -i http://www.haskell.org/ghc/docs/latest/html/libraries/base,/usr/share/doc/ghc/libraries/base/base.haddock \
+ haddock -hU -o doc \
+ -i http://www.haskell.org/ghc/docs/latest/html/libraries/base,base.haddock \
+ -i $(lastword $(wildcard ~/.cabal/share/doc/enumerator-*/html/)),$(lastword $(wildcard ~/.cabal/share/doc/enumerator-*/html/enumerator.haddock)) \
+ -i $(lastword $(wildcard ~/.cabal/share/doc/transformers-*/html/)),$(lastword $(wildcard ~/.cabal/share/doc/transformers-*/html/transformers.haddock)) \
+ -i $(lastword $(wildcard ~/.cabal/share/doc/text-*/html/)),$(lastword $(wildcard ~/.cabal/share/doc/text-*/html/text.haddock)) \
$^
obj prof:
mkdir -p $@
clean:
- rm -r obj/* prof/* doc/* dist/* $(Executables)
+ rm -rf obj/* prof/* doc/* dist/* $(Executables)
+ rm -f $(foreach SourceFile,$(LibraryFiles),$(SourceFile:%.hs=%.o) $(SourceFile:%.hs=%.hi))
diff --git a/Shell.hs b/Shell.hs
--- a/Shell.hs
+++ b/Shell.hs
@@ -14,7 +14,7 @@
.
-}
-{-# LANGUAGE ScopedTypeVariables, Rank2Types, GADTs, FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables, Rank2Types, GADTs, FlexibleContexts, PatternGuards #-}
module Main where
@@ -22,6 +22,7 @@
import Data.List (intersperse, partition)
import Data.Char (isAlphaNum)
import Data.Maybe (fromJust)
+import Data.Text (Text)
import Control.Concurrent (forkIO)
import Control.Exception (evaluate)
import Control.Monad (liftM, when)
@@ -44,13 +45,14 @@
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 Control.Concurrent.SCC.Streams
import Control.Concurrent.SCC.Types
-import Control.Concurrent.SCC.Components hiding ((&&), (||))
-import Control.Concurrent.SCC.Combinators (JoinableComponentPair)
-import qualified Control.Concurrent.SCC.Components as Combinators
-import qualified Control.Concurrent.SCC.XML as XML
+import qualified Control.Concurrent.SCC.Coercions as Coercions
+import Control.Concurrent.SCC.Configurable hiding ((&&), (||))
+import Control.Concurrent.SCC.Combinators (JoinableComponentPair, compose)
+import qualified Control.Concurrent.SCC.Configurable as Combinators ((&&), (||))
data Expression where
-- Compiled expressions
@@ -123,8 +125,6 @@
XMLElementContent :: Expression
XMLElementName :: Expression
XMLElementHavingTag :: Expression -> Expression
- XMLHavingText :: Expression -> Expression -> Expression
- XMLHavingOnlyText :: Expression -> Expression -> Expression
instance Show Expression where
showsPrec _ (Compiled tag c) rest = "compiled " ++ shows tag rest
@@ -155,7 +155,7 @@
showsPrec p (ZipWithOr s1 s2) rest | p < 4 = showsPrec 4 s1 (" || " ++ showsPrec 4 s2 rest)
showsPrec p (FollowedBy s1 s2) rest | p < 4 = showsPrec 4 s1 (", " ++ showsPrec 4 s2 rest)
showsPrec p (Not s) rest | p < 4 = ">! " ++ showsPrec 4 s rest
- showsPrec p (Nested s1 s2) rest | p < 4 = showsPrec 4 s1 (" nested in " ++ showsPrec 4 s2 rest)
+ showsPrec p (Nested s1 s2) rest | p < 4 = "nested " ++ showsPrec 4 s1 (" in " ++ showsPrec 4 s2 (" end nested" ++ rest))
showsPrec p (Having s1 s2) rest | p < 4 = showsPrec 4 s1 (" having " ++ showsPrec 4 s2 rest)
showsPrec p (HavingOnly s1 s2) rest | p < 4 = showsPrec 4 s1 (" having-only " ++ showsPrec 4 s2 rest)
showsPrec p (Between s1 s2) rest | p < 4 = showsPrec 4 s1 (" ... " ++ showsPrec 4 s2 rest)
@@ -193,8 +193,6 @@
showsPrec _ XMLElementContent rest = "XML.element-content" ++ rest
showsPrec _ XMLElementName rest = "XML.element-name" ++ rest
showsPrec p (XMLElementHavingTag s) rest = "XML.element-having-tag " ++ showsPrec 4 s (' ' : rest)
- showsPrec p (XMLHavingText s1 s2) rest = showsPrec 4 s1 (" XML.having-text " ++ showsPrec 4 s2 rest)
- showsPrec p (XMLHavingOnlyText s1 s2) rest = showsPrec 4 s1 (" XML.having-only-text " ++ showsPrec 4 s2 rest)
showsPrec _ (TypeError tag1 tag2 e) rest = ("Type error: expecting " ++ show tag2 ++ ", received " ++ show tag1
++ "\nin expression " ++ showsPrec 9 e rest)
showsPrec p e rest | p > 0 = "(" ++ showsPrec 0 e (')' : rest)
@@ -205,8 +203,9 @@
UnitTag :: TypeTag ()
ShowableTag :: Show x => TypeTag x
CharTag :: TypeTag Char
+ TextTag :: TypeTag Text
IntTag :: TypeTag Integer
- XMLTokenTag :: TypeTag XML.Token
+ XMLTokenTag :: TypeTag XMLToken
EitherTag :: TypeTag x -> TypeTag y -> TypeTag (Either x y)
ListTag :: TypeTag x -> TypeTag [x]
MaybeTag :: TypeTag x -> TypeTag (Maybe x)
@@ -226,6 +225,7 @@
show AnyTag = "Any"
show UnitTag = "()"
show CharTag = "Char"
+ show TextTag = "Text"
show IntTag = "Int"
show XMLTokenTag = "XML.Token"
show (ListTag x) = '[' : shows x "]"
@@ -247,6 +247,9 @@
data CProducer c x = CProducer (c (Producer IO x ()))
data CComponent c x = CComponent (c (Component x))
+instance Functor c => Functor (CComponent c) where
+ fmap f (CComponent c) = CComponent (fmap (fmap f) c)
+
data CList c a = CList (c [a])
data CMaybe c a = CMaybe (c (Maybe a))
data CFlip c b a = CFlip (c a b)
@@ -264,6 +267,7 @@
typecast :: forall a b c. TypeTag a -> TypeTag b -> c a -> Maybe (c b)
typecast UnitTag UnitTag x = Just x
typecast CharTag CharTag x = Just x
+typecast TextTag TextTag x = Just x
typecast IntTag IntTag x = Just x
typecast XMLTokenTag XMLTokenTag x = Just x
typecast (ListTag a) (ListTag b) x = fmap (\(CList y)-> y) (typecast a b (CList x))
@@ -306,10 +310,57 @@
of Just (Just y) -> constructor y
Nothing -> TypeError tag1 tag2 e
+typecoerce :: forall a b c. Functor c => TypeTag a -> TypeTag b -> c a -> Maybe (c b)
+typecoerce (ComponentTag (ProducerTag TextTag)) (ComponentTag (ProducerTag CharTag)) x = Just (fmap (>-> coerce) x)
+typecoerce (ComponentTag (ProducerTag CharTag)) (ComponentTag (ProducerTag TextTag)) x = Just (fmap (>-> coerce) x)
+typecoerce (ComponentTag (ConsumerTag TextTag)) (ComponentTag (ConsumerTag CharTag)) x = Just (fmap (coerce >->) x)
+typecoerce (ComponentTag (ConsumerTag CharTag)) (ComponentTag (ConsumerTag TextTag)) x = Just (fmap (coerce >->) x)
+typecoerce (ComponentTag (TransducerTag TextTag t1)) t2@(ComponentTag (TransducerTag CharTag _)) x =
+ typecast (ComponentTag (TransducerTag CharTag t1)) t2 (fmap (coerce >->) x)
+typecoerce (ComponentTag (TransducerTag CharTag t1)) t2@(ComponentTag (TransducerTag TextTag _)) x =
+ typecast (ComponentTag (TransducerTag TextTag t1)) t2 (fmap (coerce >->) x)
+typecoerce (ComponentTag (TransducerTag t1 TextTag)) t2@(ComponentTag (TransducerTag _ CharTag)) x =
+ typecast (ComponentTag (TransducerTag t1 CharTag)) t2 (fmap (>-> coerce) x)
+typecoerce (ComponentTag (TransducerTag t1 CharTag)) t2@(ComponentTag (TransducerTag _ TextTag)) x =
+ typecast (ComponentTag (TransducerTag t1 TextTag)) t2 (fmap (>-> coerce) x)
+typecoerce (ComponentTag (SplitterTag TextTag b1)) t2@(ComponentTag (SplitterTag CharTag _)) x =
+ typecast (ComponentTag (SplitterTag CharTag b1)) t2 (fmap adaptSplitter x)
+typecoerce (ComponentTag (SplitterTag CharTag b1)) t2@(ComponentTag (SplitterTag TextTag _)) x =
+ typecast (ComponentTag (SplitterTag TextTag b1)) t2 (fmap adaptSplitter x)
+
+typecoerce (ComponentTag a) (ComponentTag b) x = fmap (\(CComponent y)-> y) (typecoerce a b (CComponent x))
+
+typecoerce (ProducerTag TextTag) (ProducerTag CharTag) x =
+ Just (fmap (\x-> compose sequentialBinder x Coercions.coerce) x)
+typecoerce (ProducerTag CharTag) (ProducerTag TextTag) x =
+ Just (fmap (\x-> compose sequentialBinder x Coercions.coerce) x)
+typecoerce tag1 tag2 x = typecast tag1 tag2 x
+
+trycoerce :: forall a b. TypeTag a -> TypeTag b -> a -> Expression -> (b -> Expression) -> Expression
+trycoerce tag1 tag2 x e constructor = case typecoerce tag1 tag2 (Just x)
+ of Just (Just y) -> constructor y
+ Nothing -> TypeError tag1 tag2 e
+
tryComponentCast :: forall a b. TypeTag a -> TypeTag b -> Component a -> Expression -> (Component b -> Expression)
-> Expression
-tryComponentCast tag1 tag2 = trycast (ComponentTag tag1) (ComponentTag tag2)
+tryComponentCast tag1 tag2 = trycoerce (ComponentTag tag1) (ComponentTag tag2)
+data RelationTag = CoercibleRelationTag
+
+data TypeTagRelation c1 c2 where
+ CoercibleRelation :: Coercions.Coercible x y => TypeTag x -> TypeTag y -> c1 x -> c2 y -> TypeTagRelation c1 c2
+ NoRelation :: TypeTagRelation c1 c2
+
+typecastRelatedPair :: forall a b c1 c2. TypeTag a -> TypeTag b -> RelationTag -> c1 a -> c2 b -> TypeTagRelation c1 c2
+typecastRelatedPair tag1 tag2 CoercibleRelationTag x y
+ | Just y' <- typecast tag2 tag1 y = CoercibleRelation tag1 tag1 x y'
+typecastRelatedPair TextTag CharTag CoercibleRelationTag x y = CoercibleRelation TextTag CharTag x y
+typecastRelatedPair (MarkupTag tag1b tag1) tag2 CoercibleRelationTag x y =
+ case typecastRelatedPair tag1 tag2 CoercibleRelationTag (CMR x) y
+ of CoercibleRelation tag1' tag2' (CMR x') y' -> CoercibleRelation (MarkupTag tag1b tag1') tag2' x' y'
+ NoRelation -> NoRelation
+typecastRelatedPair _ _ _ _ _ = NoRelation
+
data Flag = Command | Help | Interactive | PrettyPrint | ScriptFile String | StandardInput | Threads String
deriving Eq
@@ -386,12 +437,14 @@
execute :: Flags -> Expression -> IO ()
execute options (Compiled CommandTag command) = perform $ with $ adjust options command
-execute options (Compiled (ProducerTag CharTag) producer) =
- liftM fst (runCoroutine (pipe
- (produce $ with $ adjust options producer)
- (consume $ with toStdOut)))
- >> hFlush stdout
-execute options (Compiled tag _) = hPutStrLn stderr ("Expecting a command or a ProducerComponent Char, received a " ++ show tag)
+execute options e@(Compiled t@ProducerTag{} p) =
+ case typecoerce t (ProducerTag CharTag) p
+ of Just producer-> runCoroutine (pipe
+ (produce $ with $ adjust options producer)
+ (consume $ with toStdOut))
+ >> hFlush stdout
+ Nothing -> print (TypeError t (ProducerTag 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
adjust _ component = component
@@ -408,6 +461,7 @@
Compiled (TransducerTag tag2 tag3) t -> tryComponentCast tag (ProducerTag tag2) p left $
\p'-> Compiled (ProducerTag tag3) (p' >-> t)
e@TypeError{} -> e
+ Compiled tag _ -> TypeError tag (TransducerTag tag1 AnyTag) right
Compiled (TransducerTag tag1 tag2) t
-> case compile tag2 right
of Compiled tag3@ConsumerTag{} c -> tryComponentCast tag3 (ConsumerTag tag2) c right $
@@ -423,11 +477,12 @@
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 True) sink
+ produce (with $ fromHandle stdout) sink
+ lift (hClose stdout)
compile UnitTag (FileProducer path) = Compiled (ProducerTag CharTag) (fromFile path)
compile UnitTag StdInProducer = Compiled (ProducerTag CharTag) fromStdIn
compile inputTag (FromList string) = Compiled (ProducerTag CharTag) (atomic "putList" 1 $ Producer $
- \sink-> putList string sink)
+ \sink-> putList string sink >> return ())
compile inputTag (FileConsumer path) = Compiled (ConsumerTag CharTag) (toFile path)
compile inputTag (FileAppend path) = Compiled (ConsumerTag CharTag) (appendFile path)
compile inputTag Suppress = Compiled (ConsumerTag inputTag) suppress
@@ -438,7 +493,8 @@
compile inputTag (If splitter true false) = combineSplitterAndBranches ifs inputTag splitter true false
compile inputTag (NativeCommand command) = Compiled (TransducerTag CharTag CharTag)
(atomic command ioCost $ Transducer f)
- where f source sink = do (Just stdin, Just stdout, Nothing, pid)
+ where f :: forall a1 a2 d. OpenTransducer IO a1 a2 d Char Char ()
+ f source sink = do (Just stdin, Just stdout, Nothing, pid)
<- lift (Process.createProcess
(Process.shell command){Process.std_in= Process.CreatePipe,
Process.std_out= Process.CreatePipe})
@@ -460,12 +516,12 @@
>>= flip when (lift (hGetChar stdout)
>>= put sink)
>> interleave1
- interleaveEnd = lift (hIsEOF stdout)
- >>= cond
- (lift $ hClose stdout)
- (lift (hGetChar stdout)
- >>= put sink
- >> interleaveEnd)
+ interleaveEnd = do eof <- lift (hIsEOF stdout)
+ if eof
+ then lift $ hClose stdout
+ 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
@@ -481,8 +537,8 @@
compile inputTag (ZipWithAnd left right) = combineSplitters (Combinators.&&) inputTag PairTag left right
compile inputTag (ZipWithOr left right) = combineSplitters (Combinators.||) inputTag EitherTag left right
compile inputTag (Nested left right) = combineSplittersOfSameType nestedIn inputTag left right
-compile inputTag (Having left right) = combineSplittersOfSameType having inputTag left right
-compile inputTag (HavingOnly left right) = combineSplittersOfSameType havingOnly inputTag left right
+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
@@ -502,7 +558,8 @@
(Nothing, Just stdout, Nothing, pid)
<- lift (Process.createProcess
(Process.shell command){Process.std_out= Process.CreatePipe})
- produce (with $ fromHandle stdout True) sink
+ produce (with $ fromHandle stdout) sink
+ lift (hClose stdout)
compile inputTag IdentityTransducer = Compiled (TransducerTag inputTag inputTag) id
compile inputTag Count = Compiled (TransducerTag inputTag IntTag) count
@@ -533,26 +590,22 @@
compile inputTag DigitSplitter = Compiled (SplitterTag CharTag UnitTag) digits
compile inputTag MarkedSplitter = Compiled (SplitterTag (MarkupTag AnyTag AnyTag) UnitTag) marked
compile inputTag OneSplitter = Compiled (SplitterTag inputTag UnitTag) one
-compile CharTag (SubstringSplitter part) = Compiled (SplitterTag CharTag UnitTag) (substring part)
-compile inputTag e@SubstringSplitter{} = TypeError (SplitterTag CharTag UnitTag) (SplitterTag inputTag UnitTag) e
-compile CharTag XMLTokenParser = Compiled (TransducerTag CharTag (MarkupTag XMLTokenTag CharTag)) xmlParseTokens
-compile t@(MarkupTag XMLTokenTag CharTag) XMLElement = Compiled (SplitterTag t UnitTag) xmlElement
-compile t@(MarkupTag XMLTokenTag CharTag) XMLAttribute = Compiled (SplitterTag t UnitTag) xmlAttribute
-compile t@(MarkupTag XMLTokenTag CharTag) XMLAttributeName = Compiled (SplitterTag t UnitTag) xmlAttributeName
-compile t@(MarkupTag XMLTokenTag CharTag) XMLAttributeValue = Compiled (SplitterTag t UnitTag) xmlAttributeValue
-compile t@(MarkupTag XMLTokenTag CharTag) XMLElementContent = Compiled (SplitterTag t UnitTag) xmlElementContent
-compile t@(MarkupTag XMLTokenTag CharTag) XMLElementName = Compiled (SplitterTag t UnitTag) xmlElementName
-compile t@(MarkupTag XMLTokenTag CharTag) (XMLElementHavingTag s) = wrapConcreteSplitter xmlElementHavingTag t s
-compile t@(MarkupTag XMLTokenTag CharTag) (XMLHavingText left right)
- = combineSplittersOfDifferentTypes xmlHavingText t CharTag left right
-compile t@(MarkupTag XMLTokenTag CharTag) (XMLHavingOnlyText left right)
- = combineSplittersOfDifferentTypes xmlHavingOnlyText t CharTag left right
+compile inputTag (SubstringSplitter part) = Compiled (SplitterTag CharTag UnitTag) (substring part)
+compile CharTag XMLTokenParser = Compiled (TransducerTag CharTag (MarkupTag XMLTokenTag TextTag)) xmlParseTokens
+compile t@(MarkupTag XMLTokenTag TextTag) XMLElement = Compiled (SplitterTag t UnitTag) xmlElement
+compile t@(MarkupTag XMLTokenTag TextTag) XMLAttribute = Compiled (SplitterTag t UnitTag) xmlAttribute
+compile t@(MarkupTag XMLTokenTag TextTag) XMLAttributeName = Compiled (SplitterTag t UnitTag) xmlAttributeName
+compile t@(MarkupTag XMLTokenTag TextTag) XMLAttributeValue = Compiled (SplitterTag t UnitTag) xmlAttributeValue
+compile t@(MarkupTag XMLTokenTag TextTag) XMLElementContent = Compiled (SplitterTag t UnitTag) xmlElementContent
+compile t@(MarkupTag XMLTokenTag TextTag) XMLElementName = Compiled (SplitterTag t UnitTag) xmlElementName
+compile t@(MarkupTag XMLTokenTag TextTag) (XMLElementHavingTag s) = wrapConcreteSplitter xmlElementHavingTagWith t s
compile inputTag expression = error ("Cannot compile " ++ show expression ++ " with input " ++ show inputTag)
compileJoin :: forall t.
- (forall t1 t2 t3 m x y c1 c2 c3. JoinableComponentPair t1 t2 t3 m x y c1 c2 c3 => Component c1 -> Component c2 -> Component c3)
- -> TypeTag t -> Expression -> Expression -> Expression
+ (forall t1 t2 t3 m x y c1 c2 c3. (MonadParallel m, JoinableComponentPair t1 t2 t3 m x y c1 c2 c3) =>
+ Component c1 -> Component c2 -> Component c3)
+ -> TypeTag t -> Expression -> Expression -> Expression
compileJoin combinator inputTag e1 e2
= case (compile inputTag e1, compile inputTag e2)
of (Compiled CommandTag c1, Compiled CommandTag c2) -> Compiled CommandTag (combinator c1 c2)
@@ -674,6 +727,22 @@
(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
+ = case (compile inputTag left, compile inputTag right)
+ of (Compiled ts1@(SplitterTag tag1 tag1b) s1, Compiled ts2@(SplitterTag tag2 _) s2)
+ -> case typecastRelatedPair tag1 tag2 CoercibleRelationTag (CSL s1) (CSL s2)
+ of CoercibleRelation tag1' tag2' (CSL s1') (CSL s2')
+ -> 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
@@ -688,6 +757,21 @@
(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')
+ (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
@@ -764,8 +848,7 @@
"select", "show", "stdin", "substitute", "substring", "suffix", "suppress",
"then", "unparse", "uppercase", "while", "whitespace",
"XML.parse-tags", "XML.serialize-tags",
- "XML.element", "XML.element-content", "XML.element-having-tag",
- "XML.element-name", "XML.having-text"]}
+ "XML.element", "XML.element-content", "XML.element-having-tag", "XML.element-name"]}
reservedTokens = reservedOpNames language ++ reservedNames language
@@ -811,13 +894,9 @@
<|>
liftM (Between first) (try (symbol lexer "..." >> prefixTermParser))
<|>
- liftM (Having first) (try (symbol lexer "having" >> prefixTermParser))
- <|>
liftM (HavingOnly first) (try (symbol lexer "having-only" >> prefixTermParser))
<|>
- liftM (XMLHavingOnlyText first) (try (symbol lexer "XML.having-only-text" >> prefixTermParser))
- <|>
- liftM (XMLHavingText first) (try (symbol lexer "XML.having-text" >> prefixTermParser))
+ liftM (Having first) (try (symbol lexer "having" >> prefixTermParser))
)
prefixTermParser :: Parsec.Parser Expression
@@ -833,7 +912,7 @@
<|> try (symbol lexer "start-of" >> liftM StartOf prefixTermParser)
<|> try (symbol lexer "end-of" >> liftM EndOf prefixTermParser)
<|> try (symbol lexer "select" >> liftM Select prefixTermParser)
- <|> try (symbol lexer "XML.element-having-tag" >> liftM XMLElementHavingTag prefixTermParser)
+ <|> try (symbol lexer "XML.element-having-tag-with" >> liftM XMLElementHavingTag prefixTermParser)
<|> primaryParser
primaryParser :: Parsec.Parser Expression
diff --git a/Test.hs b/Test.hs
--- a/Test.hs
+++ b/Test.hs
@@ -23,9 +23,9 @@
import Control.Concurrent.SCC.Streams
import Control.Concurrent.SCC.Types
import qualified Control.Concurrent.SCC.Combinators as Combinator
-import Control.Concurrent.SCC.Components hiding ((&&), (||))
+import Control.Concurrent.SCC.Configurable hiding ((&&), (||))
import qualified Control.Concurrent.SCC.XML as XML
-import qualified Control.Concurrent.SCC.Components as C
+import qualified Control.Concurrent.SCC.Configurable as C
import Control.Monad (liftM, when)
import Data.Char (ord, isLetter, isSpace, toUpper)
@@ -41,8 +41,10 @@
import Debug.Trace (trace)
import Prelude hiding (even, id, last)
import qualified Prelude
-import Test.QuickCheck (Arbitrary, Gen, Property, -- CoArbitrary, Positive(Positive),
- arbitrary, coarbitrary, label, classify, choose, oneof, sized, quickCheck, variant, (==>))
+import Test.QuickCheck (Arbitrary, Gen, Property, CoArbitrary,
+ Positive(Positive), NonNegative(NonNegative), NonEmptyList(NonEmpty),
+ arbitrary, coarbitrary, label, classify, choose, mapSize, oneof, resize, sized,
+ quickCheck, variant, (==>))
sublists [] _ = []
@@ -60,7 +62,7 @@
main = mapM_ quickCheck tests
-tests = [label "pipe" $ \(input :: [Int])-> runCoroutine (pipe (putList input) getList) == Just ((), input),
+tests = [label "pipe" $ \(input :: [Int])-> runCoroutine (pipe (putList input) getList) == Just ([], input),
label "pour" prop_pour,
label "id" prop_id,
label "suppress" prop_suppress,
@@ -77,12 +79,12 @@
(putList s)
(consume $ with $
uppercase >-> atomic "getList" 1 (Consumer getList)))
- == Just ((), map toUpper s),
+ == Just ([], map toUpper s),
label "uppercase <<-" $ \s-> runCoroutine (pipe
(produce $ with $
atomic "putList" 1 (Producer (putList s)) >-> uppercase)
getList)
- == Just ((), map toUpper s),
+ == 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
@@ -198,13 +200,13 @@
label "XML.tokens with attributes" prop_XMLtokens2,
label "XML.parseTokens >-> select elementContent >-> unparse" prop_XMLtokens3,
label "XML.parseTokens >-> unparse" prop_XMLtokens4,
- label "nestedIn XML.elementContent" prop_nestedInXMLcontent,
- label "select XML.elementContent while XML.element" prop_whileXMLelement]
+ label "nestedIn XML.elementContent" $ mapSize (min 40) prop_nestedInXMLcontent,
+ label "select XML.elementContent while XML.element" $ mapSize (min 50) prop_whileXMLelement]
prop_pour :: [Int] -> Bool
prop_pour input = runCoroutine (pipe (putList input) (\source-> pipe (\sink-> pour source sink) getList))
- == Just ((), ((), input))
+ == Just ([], ((), input))
prop_id :: [Int] -> Bool
prop_id input = transducerOutput id input == input
@@ -274,27 +276,27 @@
s2 = splitterFromTrace st2
s3 = splitterFromTrace st3
-prop_DeMorgan1 :: SplitterComponent Identity Int () -> SplitterComponent Identity Int () -> [Int] -> Int -> Int -> Property
-prop_DeMorgan1 s1 s2 input t1 t2
- = t1 > 0 && t2 > 0
- ==> splitterOutputs (usingThreads (snot (s1 C.&& s2)) t1) input
- == splitterOutputs (usingThreads (snot s1 C.|| snot s2) t2) input
+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] -> Int -> Int -> Property
-prop_DeMorgan2 s1 s2 input t1 t2
- = t1 > 0 && t2 > 0
- ==> splitterOutputs (usingThreads (snot (s1 C.|| s2)) t1) input
- == splitterOutputs (usingThreads (snot s1 C.&& snot s2) t2) input
+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 () -> Int -> Bool
-prop_and s1 s2 n = fst (splitterOutputs (s1 C.&& s2) l)
- == fst (splitterOutputs s1 l) `intersect` fst (splitterOutputs s2 l)
- where l = [1 .. abs n]
+prop_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 () -> Int -> Bool
-prop_or s1 s2 n = fst (splitterOutputs (s1 C.|| s2) l)
- == sort (fst (splitterOutputs s1 l) `union` fst (splitterOutputs s2 l))
- where l = [1 .. abs n]
+prop_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 splitter input = let splitOddEven [] = ([], [])
@@ -366,13 +368,14 @@
(suffix, False):[] -> last1 == [] && rest1 == suffix
[] -> last1 ++ rest1 == []
-prop_followedBy1 :: SplitterComponent Identity Int () -> SplitterComponent Identity Int () -> Int -> Bool
-prop_followedBy1 s1 s2 n = splitterOutputs (s1 `followedBy` s2) l == splitterOutputs (s1 `followedBy` prefix s2) l
- where l = [1 .. abs n]
+prop_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 s n = splitterOutputs (s `followedBy` startOf everything) l == splitterOutputs s l
- where l = [1 .. abs n]
+ where l = [1 .. n `mod` 300]
prop_followedBy3 :: [TestEnum] -> [TestEnum] -> [TestEnum] -> Property
prop_followedBy3 l1 l2 l3 = classify (not (isInfixOf l1 l3)) "trivial" $
@@ -384,42 +387,43 @@
==> classify (not (isInfixOf (l1 ++ l2) l3)) "trivial" $
fst (splitterOutputs (substring l1 `followedBy` substring l2) l3) == sublists (l1 ++ l2) l3
-prop_followedBy5 :: Int -> Int -> Int -> Int -> Bool
-prop_followedBy5 i1 i2 i3 i4 = let n1 = abs i1
- n2 = n1 + abs i2
- n3 = n2 + abs i3 + 1
- n4 = n3 + abs i4
- in splitterOutputs (substring [n1 .. n2] `followedBy` substring [n2 + 1 .. n3]) [0 .. n4]
- == ([n1 .. n3], [0 .. n1 - 1] ++ [n3 + 1 .. n4])
+prop_followedBy5 :: Positive Int -> NonNegative Int -> Positive Int -> NonNegative Int -> Bool
+prop_followedBy5 (Positive i1) (NonNegative i2) (Positive i3) (NonNegative i4) =
+ let n1 = i1 `mod` 1000
+ n2 = n1 + i2 `mod` 100
+ n3 = n2 + i3 `mod` 100
+ n4 = n3 + i4 `mod` 100
+ 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 () -> Int -> Bool
-prop_followedBy6 s1 s2 n = sort (fst (splitterOutputs (endOf s1 `followedBy` s2) l)
- `union` fst (splitterOutputs (s1 `followedBy` startOf s2) l))
- == fst (splitterOutputs (s1 `followedBy` s2) l)
- where l = [1 .. abs n]
+prop_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)
+ where l = [1 .. n `mod` 500]
-prop_followedByBetween :: Int -> Int -> Int -> Int -> Bool
-prop_followedByBetween i1 i2 i3 i4 = let n1 = abs i1
- n2 = n1 + abs i2
- n3 = n2 + abs i3 + 1
- n4 = n3 + abs i4
- in splitterOutputs
- ((substring [n1] ... substring [n2])
- `followedBy` (substring [n2 + 1] ... substring [n3]))
- [0 .. n4]
-
- == ([n1 .. n3], [0 .. n1 - 1] ++ [n3 + 1 .. n4])
+prop_followedByBetween :: Positive Int -> NonNegative Int -> Positive Int -> NonNegative Int -> Bool
+prop_followedByBetween (Positive i1) (NonNegative i2) (Positive i3) (NonNegative i4) =
+ let n1 = i1 `mod` 500
+ n2 = n1 + i2 `mod` 500
+ n3 = n2 + i3 `mod` 500 + 1
+ n4 = n3 + i4 `mod` 500
+ in splitterOutputs
+ ((substring [n1] ... substring [n2]) `followedBy` (substring [n2 + 1] ... substring [n3]))
+ [0 .. n4]
+ == ([n1 .. n3], [0 .. n1 - 1] ++ [n3 + 1 .. n4])
-prop_between1 :: SplitterComponent Identity Int () -> Int -> Bool
-prop_between1 splitter n = splitterOutputs (startOf splitter ... endOf splitter) input == splitterOutputs splitter input
- && splitterOutputs (endOf splitter ... startOf splitter) input == ([], input)
- where input = [1 .. abs n]
+prop_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 () -> Int -> Bool
-prop_between2 splitter n = splitterOutputs (startOf everything ... endOf splitter) input
- == splitterOutputs (uptoFirst splitter) input
- || null (fst $ splitterOutputs splitter input)
- where input = [1 .. abs n]
+prop_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)
+ where input = [1 .. n `mod` 500]
prop_XMLtokens1 :: [LowercaseLetter] -> String -> Property
prop_XMLtokens1 name content = name /= [] && intersect content "<&" == []
@@ -428,7 +432,7 @@
start = "<" ++ name' ++ ">"
end = ""
-prop_XMLtokens2 :: [LowercaseLetter] -> [([LowercaseLetter], String)] -> String -> Property
+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)
@@ -436,52 +440,66 @@
start = "<" ++ name' ++ concatMap attribute attrs ++ ">"
end = ""
-prop_XMLtokens3 :: [LowercaseLetter] -> [([LowercaseLetter], String)] -> String -> Property
-prop_XMLtokens3 name attrs content = name /= [] && all validAttribute attrs && intersect content "<&" == []
- ==> transducerOutput
- (xmlParseTokens >-> select xmlElementContent >-> unparse)
- (start ++ content ++ end)
- == content
- where name' = map letterChar name
- start = "<" ++ name' ++ concatMap attribute attrs ++ ">"
+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
+ where name' = map letterChar name ++ spaces
+ spaces = if ws then "\n\t " else ""
+ start = "<" ++ name' ++ List.intercalate spaces (map attribute attrs) ++ ">"
end = ""
-prop_XMLtokens4 :: [LowercaseLetter] -> [([LowercaseLetter], String)] -> String -> Property
-prop_XMLtokens4 name attrs content = name /= [] && all ((/= []) . fst) attrs
- ==> transducerOutput (xmlParseTokens >-> unparse) input == input
+prop_XMLtokens4 :: NonEmptyList LowercaseLetter -> [(Identifier, String)] -> String -> Bool
+prop_XMLtokens4 (NonEmpty name) attrs content =
+ transducerOutput (xmlParseTokens >-> unparse >-> coerce) input == input
where name' = map letterChar name
start = "<" ++ name' ++ concatMap attribute attrs ++ ">"
end = ""
- content' = concatMap XML.escapeContentCharacter content
+ content' = concatMap escapeContentCharacter content
input = start ++ content' ++ end
-prop_nestedInXMLcontent :: [Either ([LowercaseLetter], [([LowercaseLetter], String)]) String] -> Bool
+prop_nestedInXMLcontent :: [Either (Identifier, [(Identifier, String)]) String] -> Bool
prop_nestedInXMLcontent startTagsAndContent = transducerOutput
(xmlParseTokens
>-> select (snot xmlElement `nestedIn` xmlElementContent)
- >-> unparse)
+ >-> unparse >-> coerce)
(nestXMLelements startTagsAndContent)
- == concatMap
- XML.escapeContentCharacter
- (concat (rights startTagsAndContent))
+ == concatMap escapeContentCharacter (concat (rights startTagsAndContent))
-prop_whileXMLelement :: [Either ([LowercaseLetter], [([LowercaseLetter], String)]) String] -> Bool
+prop_whileXMLelement :: [Either (Identifier, [(Identifier, String)]) String] -> Bool
prop_whileXMLelement startTagsAndContent = transducerOutput
(xmlParseTokens
- >-> (select xmlElementContent `while` xmlElement) >-> unparse)
+ >-> (select xmlElementContent `while` xmlElement)
+ >-> unparse >-> coerce)
(nestXMLelements startTagsAndContent)
- == concatMap XML.escapeContentCharacter (concat (rights startTagsAndContent))
--- == nest (map (either (Left . id) (Right . map toUpper)) startTagsAndContent)
+ == concatMap escapeContentCharacter (concat (rights startTagsAndContent))
nestXMLelements [] = []
-nestXMLelements (Left (name, attrs) : rest) = "<" ++ name' ++ concatMap attribute attrs ++ ">"
- ++ nestXMLelements rest ++ ""
- where name' = 'a' : map letterChar name
-nestXMLelements (Right content : rest) = concatMap XML.escapeContentCharacter content ++ nestXMLelements rest
+nestXMLelements (Left (Identifier (NonEmpty name), attrs) : rest) = "<" ++ name' ++ concatMap attribute attrs ++ ">"
+ ++ nestXMLelements rest ++ ""
+ where name' = map letterChar name
+nestXMLelements (Right content : rest) = concatMap escapeContentCharacter content ++ nestXMLelements rest
-attribute (name, value) = " b" ++ map letterChar name ++ "=\"" ++ concatMap XML.escapeAttributeCharacter value ++ "\""
-validAttribute (name, value) = name /= [] && intersect value "<&\"" == []
+attribute (Identifier (NonEmpty name), value) =
+ " " ++ map letterChar name ++ "=\"" ++ concatMap escapeAttributeCharacter value ++ "\""
+validAttribute (Identifier (NonEmpty name), value) = name /= [] && intersect value "<&\"" == []
+-- | Escapes a character for inclusion into an XML attribute value.
+escapeAttributeCharacter :: Char -> String
+escapeAttributeCharacter '"' = """
+escapeAttributeCharacter '\t' = " "
+escapeAttributeCharacter '\n' = "
"
+escapeAttributeCharacter '\r' = "
"
+escapeAttributeCharacter x = escapeContentCharacter x
+
+-- | Escapes a character for inclusion into the XML data content.
+escapeContentCharacter :: Char -> String
+escapeContentCharacter '<' = "<"
+escapeContentCharacter '&' = "&"
+escapeContentCharacter x = [x]
+
uppercaseContent :: (Functor f, Monad m) => TransducerComponent m (f Char) (f Char)
uppercaseContent = atomic "uppercase" 1 (oneToOneTransducer $ fmap toUpper)
@@ -494,16 +512,23 @@
(\source-> pipe
(\sink-> transduce t source sink)
getList))
- of Identity ((), ((), output)) -> output
+ of Identity (_, (_, output)) -> output
splitterOutputs :: SplitterComponent Identity x b -> [x] -> ([x], [x])
-splitterOutputs s input = case runCoroutine (pipe
- (putList input)
- (\source-> splitToConsumers (with s) source
- getList
- getList
- (mapMStream_ (const $ return ()))))
- of Identity ((), ((), true, false, ())) -> (true, false)
+splitterOutputs s input =
+ case runCoroutine (pipe
+ (putList input)
+ (\source->
+ pipe
+ (\true->
+ pipe
+ (\false->
+ pipe
+ (\edge-> split (with s) source true false edge)
+ (mapMStream_ (const $ return ())))
+ getList)
+ getList))
+ of Identity (_, ((_, false), true)) -> (true, false)
splitterUnifiedOutput :: forall x b. SplitterComponent Identity x b -> [x] -> [Either (x, Bool) b]
splitterUnifiedOutput s input =
@@ -553,7 +578,8 @@
then do when (not previous) (put edge ())
putList (Foldable.toList (Seq.viewl q)) true
else putList (Foldable.toList (Seq.viewl q)) false
- in follow False (cycle (fst trace1 ++ [Just (Just $ snd trace1)])) Seq.empty
+ in follow False (cycle (fst trace1 ++ [Just (Just $ snd trace1)])) Seq.empty
+ >> return ()
swap :: (x, y) -> (y, x)
swap (x, y) = (y, x)
@@ -567,30 +593,36 @@
data TestEnum = One | Two | Three | Four | Five deriving (Enum, Eq, Show)
+newtype Identifier = Identifier (NonEmptyList LowercaseLetter) deriving (Eq, Show)
+
newtype LowercaseLetter = LowercaseLetter{letterChar:: Char} deriving (Eq, Show)
instance Arbitrary TestEnum where
arbitrary = oneof (map return [One, Two, Three, Four, Five])
---instance CoArbitrary TestEnum where
+instance CoArbitrary TestEnum where
coarbitrary enum = variant (case enum of {One -> 0; Two -> 1; Three -> 2; Four -> 3; Five -> 4})
-instance Arbitrary Char where
- arbitrary = choose ('\32', '\128')
- coarbitrary c = variant ((ord c - 32) `rem` 128)
+-- instance Arbitrary Char where
+-- arbitrary = choose ('\32', '\128')
+-- coarbitrary c = variant ((ord c - 32) `rem` 128)
+instance Arbitrary Identifier where
+ arbitrary = sized (\size-> fmap Identifier $ resize (size `mod` 50) arbitrary)
+
instance Arbitrary LowercaseLetter where
arbitrary = fmap LowercaseLetter (choose ('a', 'z'))
+instance CoArbitrary LowercaseLetter where
coarbitrary (LowercaseLetter c) = variant ((ord c - 65) `rem` 26)
instance Arbitrary c => Arbitrary (Component c) where
arbitrary = fmap (atomic "Arbitrary" 1) arbitrary
---instance CoArbitrary c => CoArbitrary (Component c) where
+instance CoArbitrary c => CoArbitrary (Component c) where
coarbitrary c = coarbitrary (with c)
instance Arbitrary (Splitter Identity Int ()) where
arbitrary = fmap splitterFromTrace' arbitrary
---instance CoArbitrary (Splitter Identity Int ()) where
- coarbitrary s gen = sized (\n-> coarbitrary (transducerOutput' (Combinator.ifs False s
+instance CoArbitrary (Splitter Identity Int ()) where
+ coarbitrary s gen = sized (\n-> coarbitrary (transducerOutput' (Combinator.ifs sequentialBinder s
(oneToOneTransducer $ const True)
(oneToOneTransducer $ const False))
[1..n]) gen)
diff --git a/grammar.bnf b/grammar.bnf
--- a/grammar.bnf
+++ b/grammar.bnf
@@ -14,13 +14,11 @@
| {">," PrefixTerm}
| "having" PrefixTerm
| "having-only" PrefixTerm
- | "XML.having-text" PrefixTerm
- | "XML.having-only-text" PrefixTerm
| "..." PrefixTerm].
PrefixTerm ::=
Primary
- | "XML.element-having-tag" PrefixTerm
+ | "XML.element-having-tag-with" PrefixTerm
| "first" PrefixTerm
| "last" PrefixTerm
| "prefix" PrefixTerm
diff --git a/scc.cabal b/scc.cabal
--- a/scc.cabal
+++ b/scc.cabal
@@ -1,10 +1,10 @@
Name: scc
-Version: 0.5.1
+Version: 0.6
Cabal-Version: >= 1.2
Build-Type: Simple
Synopsis: Streaming component combinators
Category: Control, Combinators, Concurrency
-Tested-with: GHC
+Tested-with: GHC == 6.12.3, GHC == 7.0
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
@@ -28,18 +28,21 @@
Executable shsh
Main-is: Shell.hs
- Other-Modules: Control.Concurrent.SCC.Streams, Control.Concurrent.SCC.Types,
+ 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.Components
- Build-Depends: base < 5, containers, transformers >= 0.2 && < 0.3, monad-parallel, monad-coroutine,
+ Control.Concurrent.Configuration, Control.Concurrent.SCC.Configurable
+ Build-Depends: base < 5, containers, transformers >= 0.2 && < 0.3, monad-parallel,
+ monad-coroutine >= 0.6 && < 0.7, bytestring < 1.0, text < 1.0,
process, readline, parsec >= 3.0 && < 4.0
GHC-options: -threaded
Library
- Exposed-Modules: Control.Concurrent.SCC.Streams, Control.Concurrent.SCC.Types,
- Control.Concurrent.SCC.Combinators, Control.Concurrent.SCC.Primitives,
- Control.Concurrent.SCC.XML,
- Control.Concurrent.Configuration, Control.Concurrent.SCC.Components
- Build-Depends: base < 5, containers, transformers >= 0.2 && < 0.3, monad-parallel, monad-coroutine
+ Exposed-Modules: Control.Concurrent.SCC.Streams, Control.Concurrent.SCC.Types, Control.Concurrent.SCC.Coercions,
+ Control.Concurrent.SCC.Combinators.Parallel, Control.Concurrent.SCC.Combinators.Sequential,
+ Control.Concurrent.SCC.Primitives, Control.Concurrent.SCC.XML,
+ Control.Concurrent.Configuration, Control.Concurrent.SCC.Configurable,
+ Control.Concurrent.SCC.Parallel, Control.Concurrent.SCC.Sequential
+ Build-Depends: base < 5, containers, transformers >= 0.2 && < 0.3, monad-parallel,
+ monad-coroutine >= 0.6 && < 0.7, bytestring < 1.0, text < 1.0
GHC-prof-options: -auto-all