packages feed

scc 0.5.1 → 0.6

raw patch · 18 files changed

+2525/−1801 lines, 18 filesdep +bytestringdep +textdep ~monad-coroutine

Dependencies added: bytestring, text

Dependency ranges changed: monad-coroutine

Files

Control/Concurrent/Configuration.hs view
@@ -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
+ Control/Concurrent/SCC/Coercions.hs view
@@ -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+    <http://www.gnu.org/licenses/>.+-}++-- | 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 ()
Control/Concurrent/SCC/Combinators.hs view
@@ -14,82 +14,82 @@     <http://www.gnu.org/licenses/>. -} -{-# 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
+ Control/Concurrent/SCC/Combinators/Parallel.hs view
@@ -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+    <http://www.gnu.org/licenses/>.+-}++{-# 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
+ Control/Concurrent/SCC/Combinators/Sequential.hs view
@@ -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+    <http://www.gnu.org/licenses/>.+-}++{-# 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
− Control/Concurrent/SCC/Components.hs 
@@ -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-    <http://www.gnu.org/licenses/>.--}--{-# 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
+ Control/Concurrent/SCC/Configurable.hs view
@@ -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+    <http://www.gnu.org/licenses/>.+-}++{-# 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)
+ Control/Concurrent/SCC/Parallel.hs view
@@ -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+    <http://www.gnu.org/licenses/>.+-}++-- | 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
Control/Concurrent/SCC/Primitives.hs view
@@ -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
+ Control/Concurrent/SCC/Sequential.hs view
@@ -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+    <http://www.gnu.org/licenses/>.+-}++-- | 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
Control/Concurrent/SCC/Streams.hs view
@@ -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
Control/Concurrent/SCC/Types.hs view
@@ -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
Control/Concurrent/SCC/XML.hs view
@@ -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 '"' = "&quot;"-escapeAttributeCharacter '\t' = "&#9;"-escapeAttributeCharacter '\n' = "&#10;"-escapeAttributeCharacter '\r' = "&#13;"-escapeAttributeCharacter x = escapeContentCharacter x---- | Escapes a character for inclusion into the XML data content.-escapeContentCharacter :: Char -> String-escapeContentCharacter '<' = "&lt;"-escapeContentCharacter '&' = "&amp;"-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 "<?" true-                          put edge (Start ProcessingInstructionText)-                          processingInstruction-             tag '!' = dispatchOnString source-                          (\other-> 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 "<![CDATA[" #-}-                             dispatchOnString source-                                (\other-> 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 "<?" true+                             put edge (Start ProcessingInstructionText)+                             processingInstruction+                tag '!' = dispatchOnString source+                             (\other-> 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 "</" true+                             name <- getWhile (\x-> 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 "<![CDATA[" #-}+                                dispatchOnString source+                                   (\other-> 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 <![CDATA[ or <!--, received " ++ show ("<![" ++ other))+errorNamelessEndTag = ErrorToken "Missing element name in end tag" errorUnescapedContentLT = ErrorToken "Unescaped character '<' in content" errorUnescapedAttributeLT = ErrorToken "Invalid character '<' in attribute value."  -- | The XML token parser. This parser converts plain text to parsed text, which is a precondition for using the -- remaining XML components.-parseTokens :: Monad m => 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-
Makefile view
@@ -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))
Shell.hs view
@@ -14,7 +14,7 @@     <http://www.gnu.org/licenses/>. -} -{-# 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
Test.hs view
@@ -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 = "</" ++ name' ++ ">" -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 = "</" ++ name' ++ ">" -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 = "</" ++ name' ++ ">" -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 = "</" ++ name' ++ ">"-         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 ++ "</" ++ name' ++ ">"-   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 ++ "</" ++ name' ++ ">"+   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 '"' = "&quot;"+escapeAttributeCharacter '\t' = "&#9;"+escapeAttributeCharacter '\n' = "&#10;"+escapeAttributeCharacter '\r' = "&#13;"+escapeAttributeCharacter x = escapeContentCharacter x++-- | Escapes a character for inclusion into the XML data content.+escapeContentCharacter :: Char -> String+escapeContentCharacter '<' = "&lt;"+escapeContentCharacter '&' = "&amp;"+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)
grammar.bnf view
@@ -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
scc.cabal view
@@ -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