diff --git a/Control/Concurrent/Configuration.hs b/Control/Concurrent/Configuration.hs
new file mode 100644
--- /dev/null
+++ b/Control/Concurrent/Configuration.hs
@@ -0,0 +1,187 @@
+{-
+ Copyright 2008-2009 Mario Blazevic
+
+ This file is part of the Streaming Component Combinators (SCC) project.
+
+ The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public
+ License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later
+ version.
+
+ SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty
+ of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License along with SCC. If not, see
+ .
+-}
+
+{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, FlexibleContexts, FlexibleInstances #-}
+
+-- | This module can be used to optimize any complex computation that can be broken down into parallelizable
+-- sub-computations. The computations in question may be pure values, monadic values, list or stream transformations or
+-- anything else provided that it's parallelizable and has a relatively predictable computation cost. Each elementary
+-- sub-computation needs to be packaged as a 'Component' using the constructor 'atomic'. Sub-computations can then be
+-- combined into larger computations using the other constructors.
+
+module Control.Concurrent.Configuration
+ (-- * The Component type
+ Component (..),
+ -- * Utility functions
+ showComponentTree,
+ -- * Constructors
+ atomic, lift, liftParallelPair, liftSequentialPair, parallelRouterAndBranches, recursiveComponentTree
+ )
+where
+
+import Data.List (minimumBy)
+
+-- | 'AnyComponent' is an existential type wrapper around a 'Component'.
+data AnyComponent = forall a. AnyComponent {component :: Component a}
+
+-- | A 'Component' carries a value and metadata about the value. It can be configured to use a specific number of
+-- threads.
+data Component c = Component {
+ -- | Readable component name.
+ name :: String,
+ -- | Returns the list of all children components.
+ subComponents :: [AnyComponent],
+ -- | Returns the maximum number of threads that can be used by the component.
+ maxUsableThreads :: Int,
+ -- | Configures the component to use the specified number of threads. This function affects 'usedThreads', 'cost',
+ -- and 'subComponents' methods of the result, while 'name' and 'maxUsableThreads' remain the same.
+ usingThreads :: Int -> Component c,
+ -- | The number of threads that the component is configured to use. The default number is usually 1.
+ usedThreads :: Int,
+ -- | The cost of using the component as configured. The cost is a rough approximation of time it would take to do the
+ -- job given the 'usedThreads'.
+ cost :: Int,
+ -- | The content.
+ with :: c
+ }
+
+-- | Show details of the given component's configuration.
+showComponentTree :: forall c. Component c -> String
+showComponentTree c = showIndentedComponent 1 c
+
+showIndentedComponent :: forall c. Int -> Component c -> String
+showIndentedComponent depth c = showRightAligned 4 (cost c) ++ showRightAligned 3 (usedThreads c) ++ replicate depth ' '
+ ++ name c ++ "\n"
+ ++ concatMap (showIndentedAnyComponent (succ depth)) (subComponents c)
+
+showIndentedAnyComponent :: Int -> AnyComponent -> String
+showIndentedAnyComponent depth (AnyComponent c) = showIndentedComponent depth c
+
+showRightAligned :: Show x => Int -> x -> String
+showRightAligned width x = let str = show x
+ in replicate (width - length str) ' ' ++ str
+
+data ComponentConfiguration = ComponentConfiguration {componentChildren :: [AnyComponent],
+ componentThreads :: Int,
+ componentCost :: Int}
+
+-- | Function 'toComponent' takes a component name, maximum number of threads it can use, and its 'usingThreads'
+-- method, and returns a 'Component'.
+toComponent :: String -> Int -> (Int -> (ComponentConfiguration, c)) -> Component c
+toComponent name maxThreads usingThreads = usingThreads' 1
+ where usingThreads' n = let (configuration, c') = usingThreads n
+ in Component name (componentChildren configuration) maxThreads usingThreads'
+ (componentThreads configuration) (componentCost configuration) c'
+
+-- | Function 'atomic' takes the component name and its cost creates a single-threaded component with no subcomponents.
+atomic :: String -> Int -> c -> Component c
+atomic name cost x = toComponent name 1 (\_threads-> (ComponentConfiguration [] 1 cost, x))
+
+-- | Function 'optimalTwoAlternatingConfigurations' configures two components that are meant to alternate in processing
+-- of the data stream.
+optimalTwoAlternatingConfigurations :: Int -> Component c1 -> Component c2
+ -> (ComponentConfiguration, Component c1, Component c2)
+optimalTwoAlternatingConfigurations threads c1 c2 = (cfg{componentCost= componentCost cfg `div` 2}, c1', c2')
+ where (cfg, c1', c2') = optimalTwoSequentialConfigurations threads c1 c2
+
+
+-- | Function 'optimalTwoParallelConfigurations' configures two components, both of them with the full thread count, and
+-- returns the components and a 'ComponentConfiguration' that can be used to build a new component from them.
+optimalTwoSequentialConfigurations :: Int -> Component c1 -> Component c2
+ -> (ComponentConfiguration, Component c1, Component c2)
+optimalTwoSequentialConfigurations threads c1 c2 = (configuration, c1', c2')
+ where configuration = ComponentConfiguration
+ [AnyComponent c1', AnyComponent c2']
+ (usedThreads c1' `max` usedThreads c2')
+ (cost c1' + cost c2')
+ c1' = c1 `usingThreads` threads
+ c2' = c2 `usingThreads` threads
+
+-- | Function 'optimalTwoParallelConfigurations' configures two components assuming they can be run in parallel,
+-- splitting the given thread count between them, and returns the configured components, a 'ComponentConfiguration' that
+-- can be used to build a new component from them, and a flag that indicates if they should be run in parallel or
+-- sequentially for optimal resource usage.
+optimalTwoParallelConfigurations :: Int -> Component c1 -> Component c2
+ -> (ComponentConfiguration, Component c1, Component c2, Bool)
+optimalTwoParallelConfigurations threads c1 c2 = (configuration, c1', c2', parallelize)
+ where parallelize = threads > 1 && parallelCost + 1 < sequentialCost
+ configuration = ComponentConfiguration
+ [AnyComponent c1', AnyComponent c2']
+ (if parallelize then usedThreads c1' + usedThreads c2' else usedThreads c1' `max` usedThreads c2')
+ (if parallelize then parallelCost + 1 else sequentialCost)
+ (c1', c2') = if parallelize then (c1p, c2p) else (c1s, c2s)
+ (c1p, c2p, parallelCost) = minimumBy
+ (\(_, _, cost1) (_, _, cost2)-> compare cost1 cost2)
+ [let c2threads = threads - c1threads `min` maxUsableThreads c2
+ c1i = usingThreads c1 c1threads
+ c2i = usingThreads c2 c2threads
+ in (c1i, c2i, cost c1i `max` cost c2i)
+ | c1threads <- [1 .. threads - 1 `min` maxUsableThreads c1]]
+ c1s = usingThreads c1 threads
+ c2s = usingThreads c2 threads
+ sequentialCost = cost c1s + cost c2s
+
+-- | Applies a unary /combinator/ to the component payload. The resulting component has the original one as its
+-- 'subComponents', and its 'cost' is the sum of the original component's cost and the /combinator cost/.
+lift :: Int {- ^ combinator cost -} -> String {- ^ name -} -> (c1 -> c2) {- ^ combinator -} -> Component c1 -> Component c2
+lift wrapperCost name combinator c =
+ toComponent name (maxUsableThreads c) $
+ \threads-> let c' = usingThreads c threads
+ in (ComponentConfiguration [AnyComponent c'] (usedThreads c') (cost c' + wrapperCost),
+ combinator (with c'))
+
+-- | Combines two components into one, applying /combinator/ to their contents. The 'cost' and 'usingThreads' of the
+-- result assume the sequential execution of the argument components.
+liftSequentialPair :: String -> (c1 -> c2 -> c3) -> Component c1 -> Component c2 -> Component c3
+liftSequentialPair name combinator c1 c2 =
+ toComponent name (maxUsableThreads c1 `max` maxUsableThreads c2) $
+ \threads-> let (configuration, c1', c2') = optimalTwoSequentialConfigurations threads c1 c2
+ in (configuration, combinator (with c1') (with c2'))
+
+-- | Combines two components into one, applying /combinator/ to their contents. The /combinator/ takes a flag denoting
+-- if its arguments should run in parallel. The 'cost' and 'usingThreads' of the result assume the parallel execution of
+-- the argument components.
+liftParallelPair :: String -> (Bool -> c1 -> c2 -> c3) -> Component c1 -> Component c2 -> Component c3
+liftParallelPair name combinator c1 c2 =
+ toComponent name (maxUsableThreads c1 + maxUsableThreads c2) $
+ \threads-> let (configuration, c1', c2', parallel) = optimalTwoParallelConfigurations threads c1 c2
+ in (configuration, combinator parallel (with c1') (with c2'))
+
+-- | Combines three components into one. The first component runs in parallel with the latter two, which are considered
+-- alternative to each other.
+parallelRouterAndBranches :: String -> (Bool -> c1 -> c2 -> c3 -> c4) -> Component c1 -> Component c2 -> Component c3
+ -> Component c4
+parallelRouterAndBranches name combinator router c1 c2 =
+ toComponent name (maxUsableThreads router + maxUsableThreads c1 + maxUsableThreads c2) $
+ \threads-> let (cfg, router', c'', parallel) = optimalTwoParallelConfigurations threads router c'
+ (c1'', c2'') = with c''
+ c' = toComponent "branches" (maxUsableThreads c1 `max` maxUsableThreads c2) $
+ \threads-> let (cfg, c1', c2') = optimalTwoAlternatingConfigurations threads c1 c2
+ in (cfg, (c1', c2'))
+ in (cfg, combinator parallel (with router') (with c1'') (with c2''))
+
+-- | 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 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)
diff --git a/Control/Concurrent/Coroutine.hs b/Control/Concurrent/Coroutine.hs
new file mode 100644
--- /dev/null
+++ b/Control/Concurrent/Coroutine.hs
@@ -0,0 +1,318 @@
+{-
+ Copyright 2009-2010 Mario Blazevic
+
+ This file is part of the Streaming Component Combinators (SCC) project.
+
+ The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public
+ License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later
+ version.
+
+ SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty
+ of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License along with SCC. If not, see
+ .
+-}
+
+-- | This module defines the 'Coroutine' monad transformer.
+--
+-- A 'Coroutine' monadic computation can 'suspend' its execution at any time, returning to its invoker. The returned
+-- coroutine suspension contains the continuation of the coroutine embedded in a functor. Here is an example of a
+-- coroutine that suspends computation in the 'IO' monad using the functor 'Yield':
+--
+-- @
+-- producer = do yield 1
+-- lift (putStrLn \"Produced one, next is four.\")
+-- yield 4
+-- return \"Finished\"
+-- @
+--
+-- A suspended 'Coroutine' computation can be resumed. The easiest way to run a coroutine is by using the 'pogoStick'
+-- function, which keeps resuming the coroutine in trampolined style until it completes. Here is an example of
+-- 'pogoStick' applied to the /producer/ above:
+--
+-- @
+-- printProduce :: Show x => Coroutine (Yield x) IO r -> IO r
+-- printProduce producer = pogoStick (\\(Yield x cont) -> lift (print x) >> cont) producer
+-- @
+--
+-- Multiple concurrent coroutines can be run as well, and this module provides two different ways. The function 'seesaw'
+-- can be used to run two interleaved computations. Another possible way is to weave together steps of different
+-- coroutines into a single coroutine using the function 'couple', which can then be executed by 'pogoStick'.
+--
+-- Coroutines can be run from within another coroutine. In this case, the nested coroutines would normally suspend to
+-- their invoker. Another option is to allow a nested coroutine to suspend both itself and its invoker at once. In this
+-- case, the two suspension functors should be grouped into an 'EitherFunctor'. To run nested coroutines of this kind,
+-- use functions 'pogoStickNested', 'seesawNested', and 'coupleNested'.
+--
+-- For other uses of trampoline-style coroutines, see
+--
+-- > Trampolined Style - Ganz, S. E. Friedman, D. P. Wand, M, ACM SIGPLAN NOTICES, 1999, VOL 34; NUMBER 9, pages 18-27
+--
+-- and
+--
+-- > The Essence of Multitasking - William L. Harrison, Proceedings of the 11th International Conference on Algebraic
+-- > Methodology and Software Technology, volume 4019 of Lecture Notes in Computer Science, 2006
+
+{-# LANGUAGE ScopedTypeVariables, Rank2Types, MultiParamTypeClasses, TypeFamilies, EmptyDataDecls,
+ FlexibleInstances, OverlappingInstances, UndecidableInstances
+ #-}
+
+module Control.Concurrent.Coroutine
+ (
+ -- * Coroutine definition
+ Coroutine,
+ suspend,
+ -- * Useful classes
+ ParallelizableMonad(..), AncestorFunctor,
+ -- * Running Coroutine computations
+ runCoroutine, pogoStick, pogoStickNested, seesaw, seesawNested, SeesawResolver(..),
+ -- * Suspension functors
+ Yield(Yield), Await(Await), Naught,
+ yield, await,
+ -- * Nested and coupled Coroutine computations
+ nest, couple, coupleNested,
+ local, out, liftOut,
+ EitherFunctor(LeftF, RightF), NestedFunctor (NestedFunctor), SomeFunctor(..)
+ )
+where
+
+import Control.Concurrent (forkIO)
+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
+import Control.Monad (liftM, liftM2, when)
+import Control.Monad.Identity
+import Control.Monad.Trans (MonadTrans(..), MonadIO(..))
+import Control.Parallel (par, pseq)
+
+-- | Class of monads that can perform two computations in parallel.
+class Monad m => ParallelizableMonad m where
+ -- | Perform two monadic computations in parallel and pass the results.
+ bindM2 :: (a -> b -> m c) -> m a -> m b -> m c
+ bindM2 f ma mb = do {a <- ma; b <- mb; f a b}
+
+-- | Any monad that allows the result value to be extracted, such as `Identity` or `Maybe` monad, can implement
+-- `bindM2` by using `par`.
+instance ParallelizableMonad Identity where
+ bindM2 f ma mb = let a = runIdentity ma
+ b = runIdentity mb
+ in a `par` (b `pseq` a `pseq` f a b)
+
+instance ParallelizableMonad Maybe where
+ bindM2 f ma mb = case ma `par` (mb `pseq` (ma, mb))
+ of (Just a, Just b) -> f a b
+ _ -> Nothing
+
+-- | IO is parallelizable by `forkIO`.
+instance ParallelizableMonad IO where
+ bindM2 f ma mb = do va <- newEmptyMVar
+ vb <- newEmptyMVar
+ forkIO (ma >>= putMVar va)
+ forkIO (mb >>= putMVar vb)
+ a <- takeMVar va
+ b <- takeMVar vb
+ f a b
+
+-- | Suspending, resumable monadic computations.
+newtype Coroutine s m r = Coroutine {
+ -- | Run the next step of a `Coroutine` computation.
+ resume :: m (CoroutineState s m r)
+ }
+
+data CoroutineState s m r =
+ -- | Coroutine computation is finished with final value /r/.
+ Done r
+ -- | Computation is suspended, its remainder is embedded in the functor /s/.
+ | Suspend! (s (Coroutine s m r))
+
+instance (Functor s, Monad m) => Monad (Coroutine s m) where
+ return x = Coroutine (return (Done x))
+ t >>= f = Coroutine (resume t >>= apply f)
+ where apply f (Done x) = resume (f x)
+ apply f (Suspend s) = return (Suspend (fmap (>>= f) s))
+
+instance (Functor s, ParallelizableMonad m) => ParallelizableMonad (Coroutine s m) where
+ bindM2 f t1 t2 = Coroutine (bindM2 combine (resume t1) (resume t2)) where
+ combine (Done x) (Done y) = resume (f x y)
+ combine (Suspend s) (Done y) = return $ Suspend (fmap (flip f y =<<) s)
+ combine (Done x) (Suspend s) = return $ Suspend (fmap (f x =<<) s)
+ combine (Suspend s1) (Suspend s2) = return $ Suspend (fmap (bindM2 f $ suspend s1) s2)
+
+instance Functor s => MonadTrans (Coroutine s) where
+ lift = Coroutine . liftM Done
+
+instance (Functor s, MonadIO m) => MonadIO (Coroutine s m) where
+ liftIO = lift . liftIO
+
+-- | The 'Yield' functor instance is equivalent to (,) but more descriptive.
+data Yield x y = Yield x y
+instance Functor (Yield x) where
+ fmap f (Yield x y) = Yield x (f y)
+
+-- | The 'Await' functor instance is equivalent to (->) but more descriptive.
+data Await x y = Await! (x -> y)
+instance Functor (Await x) where
+ fmap f (Await g) = Await (f . g)
+
+-- | The 'Naught' functor instance doesn't contain anything and cannot be constructed. Used for building non-suspendable
+-- coroutines.
+data Naught x
+instance Functor Naught where
+ fmap f _ = undefined
+
+-- | Combines two alternative functors into one, applying one or the other. Used for nested coroutines.
+data EitherFunctor l r x = LeftF (l x) | RightF (r x)
+instance (Functor l, Functor r) => Functor (EitherFunctor l r) where
+ fmap f (LeftF l) = LeftF (fmap f l)
+ fmap f (RightF r) = RightF (fmap f r)
+
+-- | Combines two functors into one, applying both.
+newtype NestedFunctor l r x = NestedFunctor (l (r x))
+instance (Functor l, Functor r) => Functor (NestedFunctor l r) where
+ fmap f (NestedFunctor lr) = NestedFunctor ((fmap . fmap) f lr)
+
+-- | Combines two functors into one, applying either or both of them. Used for coupled coroutines.
+data SomeFunctor l r x = LeftSome (l x) | RightSome (r x) | Both (NestedFunctor l r x)
+instance (Functor l, Functor r) => Functor (SomeFunctor l r) where
+ fmap f (LeftSome l) = LeftSome (fmap f l)
+ fmap f (RightSome r) = RightSome (fmap f r)
+ fmap f (Both lr) = Both (fmap f lr)
+
+-- | Suspend the current 'Coroutine'.
+suspend :: (Monad m, Functor s) => s (Coroutine s m x) -> Coroutine s m x
+suspend s = Coroutine (return (Suspend s))
+
+-- | Suspend yielding a value.
+yield :: forall m x. Monad m => x -> Coroutine (Yield x) m ()
+yield x = suspend (Yield x (return ()))
+
+-- | Suspend until a value is provided.
+await :: forall m x. Monad m => Coroutine (Await x) m x
+await = suspend (Await return)
+
+-- | Convert a non-suspending 'Coroutine' to the base monad.
+runCoroutine :: Monad m => Coroutine Naught m x -> m x
+runCoroutine = pogoStick (error "runCoroutine can run only a non-suspending coroutine!")
+
+-- | Run a 'Coroutine', using a function that converts suspension to the resumption it wraps.
+pogoStick :: (Functor s, Monad m) => (s (Coroutine s m x) -> Coroutine s m x) -> Coroutine s m x -> m x
+pogoStick reveal t = resume t
+ >>= \s-> case s
+ of Done result -> return result
+ Suspend c -> pogoStick reveal (reveal c)
+
+-- | Run a nested 'Coroutine' that can suspend both itself and the current 'Coroutine'.
+pogoStickNested :: (Functor s1, Functor s2, Monad m) =>
+ (s2 (Coroutine (EitherFunctor s1 s2) m x) -> Coroutine (EitherFunctor s1 s2) m x)
+ -> Coroutine (EitherFunctor s1 s2) m x -> Coroutine s1 m x
+pogoStickNested reveal t =
+ Coroutine{resume= resume t
+ >>= \s-> case s
+ of Done result -> return (Done result)
+ Suspend (LeftF s) -> return (Suspend (fmap (pogoStickNested reveal) s))
+ Suspend (RightF c) -> resume (pogoStickNested reveal (reveal c))
+ }
+
+-- | Combines two values under two functors into a pair of values under a single 'NestedFunctor'.
+nest :: (Functor a, Functor b) => a x -> b y -> NestedFunctor a b (x, y)
+nest a b = NestedFunctor $ fmap (\x-> fmap ((,) x) b) a
+
+-- | Weaves two coroutines into one.
+couple :: (Monad m, Functor s1, Functor s2) =>
+ (forall x y r. (x -> y -> m r) -> m x -> m y -> m r)
+ -> Coroutine s1 m x -> Coroutine s2 m y -> Coroutine (SomeFunctor s1 s2) m (x, y)
+couple runPair t1 t2 = Coroutine{resume= runPair proceed (resume t1) (resume t2)} where
+ proceed (Done x) (Done y) = return $ Done (x, y)
+ proceed (Suspend s1) (Suspend s2) = return $ Suspend $ fmap (uncurry (couple runPair)) (Both $ nest s1 s2)
+ proceed (Done x) (Suspend s2) = return $ Suspend $ fmap (couple runPair (return x)) (RightSome s2)
+ proceed (Suspend s1) (Done y) = return $ Suspend $ fmap (flip (couple runPair) (return y)) (LeftSome s1)
+
+-- | Weaves two nested coroutines into one.
+coupleNested :: (Monad m, Functor s0, Functor s1, Functor s2) =>
+ (forall x y r. (x -> y -> m r) -> m x -> m y -> m r)
+ -> Coroutine (EitherFunctor s0 s1) m x -> Coroutine (EitherFunctor s0 s2) m y
+ -> Coroutine (EitherFunctor s0 (SomeFunctor s1 s2)) m (x, y)
+coupleNested runPair = coupleNested' where
+ coupleNested' t1 t2 = Coroutine{resume= runPair (\ st1 st2 -> return (proceed st1 st2)) (resume t1) (resume t2)}
+ proceed (Done x) (Done y) = Done (x, y)
+ proceed (Suspend (RightF s)) (Done y) = Suspend $ RightF $ fmap (flip coupleNested' (return y)) (LeftSome s)
+ proceed (Done x) (Suspend (RightF s)) = Suspend $ RightF $ fmap (coupleNested' (return x)) (RightSome s)
+ proceed (Suspend (RightF s1)) (Suspend (RightF s2)) =
+ Suspend $ RightF $ fmap (uncurry coupleNested') (Both $ nest s1 s2)
+ proceed (Suspend (LeftF s)) (Done y) = Suspend $ LeftF $ fmap (flip coupleNested' (return y)) s
+ proceed (Done x) (Suspend (LeftF s)) = Suspend $ LeftF $ fmap (coupleNested' (return x)) s
+ proceed (Suspend (LeftF s1)) (Suspend (LeftF s2)) = Suspend $ LeftF $ fmap (coupleNested' $ suspend $ LeftF s1) s2
+
+-- | A simple record containing the resolver functions for all possible coroutine pair suspensions.
+data SeesawResolver s1 s2 = SeesawResolver {
+ resumeLeft :: forall t. s1 t -> t, -- ^ resolves the left suspension functor into the resumption it contains
+ resumeRight :: forall t. s2 t -> t, -- ^ resolves the right suspension into its resumption
+ -- | invoked when both coroutines are suspended, resolves both suspensions or either one
+ resumeAny :: forall t1 t2 r.
+ (t1 -> r) -- ^ continuation to resume only the left suspended coroutine
+ -> (t2 -> r) -- ^ continuation to resume the right coroutine only
+ -> (t1 -> t2 -> r) -- ^ continuation to resume both coroutines
+ -> s1 t1 -- ^ left suspension
+ -> s2 t2 -- ^ right suspension
+ -> r
+}
+
+-- | Runs two coroutines concurrently. The first argument is used to run the next step of each coroutine, the next to
+-- convert the left, right, or both suspensions into the corresponding resumptions.
+seesaw :: (Monad m, Functor s1, Functor s2) =>
+ (forall x y r. (x -> y -> m r) -> m x -> m y -> m r)
+ -> SeesawResolver s1 s2
+ -> Coroutine s1 m x -> Coroutine s2 m y -> m (x, y)
+seesaw runPair resolver t1 t2 = seesaw' t1 t2 where
+ seesaw' t1 t2 = runPair proceed (resume t1) (resume t2)
+ proceed (Done x) (Done y) = return (x, y)
+ proceed (Done x) (Suspend s2) = seesaw' (return x) (resumeRight resolver s2)
+ proceed (Suspend s1) (Done y) = seesaw' (resumeLeft resolver s1) (return y)
+ proceed (Suspend s1) (Suspend s2) =
+ resumeAny resolver (flip seesaw' (suspend s2)) (seesaw' (suspend s1)) seesaw' s1 s2
+
+-- | Like 'seesaw', but for nested coroutines that are allowed to suspend the current coroutine as well as themselves.
+seesawNested :: (Monad m, Functor s0, Functor s1, Functor s2) =>
+ (forall x y r. (x -> y -> m r) -> m x -> m y -> m r)
+ -> SeesawResolver s1 s2
+ -> Coroutine (EitherFunctor s0 s1) m x -> Coroutine (EitherFunctor s0 s2) m y -> Coroutine s0 m (x, y)
+seesawNested runPair resolver t1 t2 = seesaw' t1 t2 where
+ seesaw' t1 t2 = Coroutine{resume= bouncePair t1 t2}
+ bouncePair t1 t2 = runPair proceed (resume t1) (resume t2)
+ proceed (Suspend (LeftF s1)) state2 = return $ Suspend $ fmap ((flip seesaw' (Coroutine $ return state2))) s1
+ proceed state1 (Suspend (LeftF s2)) = return $ Suspend $ fmap (seesaw' (Coroutine $ return state1)) s2
+ proceed (Done x) (Done y) = return $ Done (x, y)
+ proceed state1@(Done x) (Suspend (RightF s2)) = proceed state1 =<< resume (resumeRight resolver s2)
+ proceed (Suspend (RightF s1)) state2@(Done y) = flip proceed state2 =<< resume (resumeLeft resolver s1)
+ proceed state1@(Suspend (RightF s1)) state2@(Suspend (RightF s2)) =
+ resumeAny resolver ((flip proceed state2 =<<) . resume) ((proceed state1 =<<) . resume) bouncePair s1 s2
+
+-- | Converts a coroutine into a nested one.
+local :: forall m l r x. (Functor r, Monad m) => Coroutine r m x -> Coroutine (EitherFunctor l r) m x
+local (Coroutine mr) = Coroutine (liftM inject mr)
+ where inject :: CoroutineState r m x -> CoroutineState (EitherFunctor l r) m x
+ inject (Done x) = Done x
+ inject (Suspend r) = Suspend (RightF $ fmap local r)
+
+-- | Converts a coroutine into one that can contain nested coroutines.
+out :: forall m l r x. (Functor l, Monad m) => Coroutine l m x -> Coroutine (EitherFunctor l r) m x
+out (Coroutine ml) = Coroutine (liftM inject ml)
+ where inject :: CoroutineState l m x -> CoroutineState (EitherFunctor l r) m x
+ inject (Done x) = Done x
+ inject (Suspend l) = Suspend (LeftF $ fmap out l)
+
+-- | Class of functors that can be lifted.
+class (Functor a, Functor d) => AncestorFunctor a d where
+ -- | Convert the ancestor functor into its descendant. The descendant functor typically contains the ancestor.
+ liftFunctor :: a x -> d x
+
+instance Functor a => AncestorFunctor a a where
+ liftFunctor = id
+instance (Functor a, Functor d', Functor d, d ~ EitherFunctor d' s, AncestorFunctor a d') => AncestorFunctor a d where
+ liftFunctor = LeftF . (liftFunctor :: a x -> d' x)
+
+-- | Like 'out', working over multiple functors.
+liftOut :: forall m a d x. (Monad m, Functor a, AncestorFunctor a d) => Coroutine a m x -> Coroutine d m x
+liftOut (Coroutine ma) = Coroutine (liftM inject ma)
+ where inject :: CoroutineState a m x -> CoroutineState d m x
+ inject (Done x) = Done x
+ inject (Suspend a) = Suspend (liftFunctor $ fmap liftOut a)
diff --git a/Control/Concurrent/SCC/Combinators.hs b/Control/Concurrent/SCC/Combinators.hs
--- a/Control/Concurrent/SCC/Combinators.hs
+++ b/Control/Concurrent/SCC/Combinators.hs
@@ -14,1200 +14,1088 @@
.
-}
-{-# LANGUAGE ScopedTypeVariables, Rank2Types, ImpredicativeTypes, KindSignatures, EmptyDataDecls,
- MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, FlexibleInstances #-}
-
--- | The "Combinators" module defines combinators applicable to 'Transducer' and 'Splitter' components defined in the
--- "Control.Concurrent.SCC.ComponentTypes" module.
-
-module Control.Concurrent.SCC.Combinators
- (-- * Consumer, producer, and transducer combinators
- splitterToMarker,
- consumeBy, prepend, append, substitute,
- PipeableComponentPair ((>->)), JoinableComponentPair (join, sequence),
- -- * Pseudo-logic splitter combinators
- -- | Combinators '>&' and '>|' are only /pseudo/-logic. While the laws of double negation and De Morgan's laws hold,
- -- '>&' and '>|' are in general not commutative, associative, nor idempotent. In the special case when all argument
- -- splitters are stateless, such as those produced by 'Components.liftStatelessSplitter', these combinators do satisfy
- -- all laws of Boolean algebra.
- snot, (>&), (>|),
- -- ** Zipping logic combinators
- -- | The '&&' and '||' combinators run the argument splitters in parallel and combine their logical outputs using
- -- the corresponding logical operation on each output pair, in a manner similar to 'Prelude.zipWith'. They fully
- -- satisfy the laws of Boolean algebra.
- (&&), (||),
- -- * Flow-control combinators
- -- | The following combinators resemble the common flow-control programming language constructs. Combinators
- -- 'wherever', 'unless', and 'select' are just the special cases of the combinator 'ifs'.
- --
- -- * /transducer/ ``wherever`` /splitter/ = 'ifs' /splitter/ /transducer/ 'Components.asis'
- --
- -- * /transducer/ ``unless`` /splitter/ = 'ifs' /splitter/ 'Components.asis' /transducer/
- --
- -- * 'select' /splitter/ = 'ifs' /splitter/ 'Components.asis' 'Components.suppress'
- --
- ifs, wherever, unless, select,
- -- ** Recursive
- while, nestedIn,
- -- * Section-based combinators
- -- | All combinators in this section use their 'Splitter' argument to determine the
- -- structure of the input. Every contiguous portion of the input that gets passed to one or the other sink of the
- -- splitter is treated as one section in the logical structure of the input stream. What is done with the section
- -- depends on the combinator, but the sections, and therefore the logical structure of the input stream, are
- -- determined by the argument splitter alone.
- foreach, having, havingOnly, followedBy, even,
- -- ** first and its variants
- first, uptoFirst, prefix,
- -- ** last and its variants
- last, lastAndAfter, suffix,
- -- ** positional splitters
- startOf, endOf,
- -- ** input ranges
- (...),
- -- * parser support
- parseRegions, parseNestedRegions,
- -- * grouping helpers
- groupMarks)
-where
-
-import Control.Concurrent.SCC.Foundation
-import Control.Concurrent.SCC.ComponentTypes
-
-import Prelude hiding (even, last, sequence, (||), (&&))
-import qualified Prelude
-import Control.Exception (assert)
-import Control.Monad (liftM, when)
-import qualified Control.Monad as Monad
-import Data.Maybe (isJust, isNothing, fromJust)
-import Data.Typeable (Typeable)
-import qualified Data.Foldable as Foldable
-import qualified Data.Sequence as Seq
-import Data.Sequence (Seq, (|>), (><), ViewL (EmptyL, (:<)))
-
-import Debug.Trace (trace)
-
--- | Converts a 'Consumer' into a 'Transducer' with no output.
-consumeBy :: forall m x y r. (Monad m, Typeable x) => Consumer m x r -> Transducer m x y
-consumeBy c = liftTransducer "consumeBy" (maxUsableThreads c) $
- \threads-> let c' = usingThreads threads c
- in (ComponentConfiguration [AnyComponent c'] (usedThreads c') (cost c'),
- \ source _sink -> consume c' source >> return [])
-
--- | Class 'PipeableComponentPair' applies to any two components that can be combined into a third component with the
--- following properties:
---
--- * The input of the result, if any, becomes the input of the first component.
---
--- * The output produced by the first child component is consumed by the second child component.
---
--- * The result output, if any, is the output of the second component.
-class PipeableComponentPair (m :: * -> *) w c1 c2 c3 | c1 c2 -> c3, c1 c3 -> c2, c2 c3 -> c2,
- c1 -> m w, c2 -> m w, c3 -> m
- where (>->) :: c1 -> c2 -> c3
-
-instance (ParallelizableMonad m, Typeable x)
- => PipeableComponentPair m x (Producer m x ()) (Consumer m x ()) (Performer m ())
- where p >-> c = liftPerformer ">->" (maxUsableThreads p `max` maxUsableThreads c) $
- \threads-> let (configuration, p', c', parallel) = optimalTwoParallelConfigurations threads p c
- performPipe = (if parallel then pipeP else pipe) (produce p') (consume c') >> return ()
- in (configuration, performPipe)
-
-instance (ParallelizableMonad m, Typeable x, Typeable y)
- => PipeableComponentPair m y (Transducer m x y) (Consumer m y r) (Consumer m x r)
- where t >-> c = liftConsumer ">->" (maxUsableThreads t `max` maxUsableThreads c) $
- \threads-> let (configuration, t', c', parallel) = optimalTwoParallelConfigurations threads t c
- consumePipe source = liftM snd $ (if parallel then pipeP else pipe)
- (transduce t' source)
- (consume c')
- in (configuration, consumePipe)
-
-instance (ParallelizableMonad m, Typeable x, Typeable y)
- => PipeableComponentPair m x (Producer m x r) (Transducer m x y) (Producer m y r)
- where p >-> t = liftProducer ">->" (maxUsableThreads t `max` maxUsableThreads p) $
- \threads-> let (configuration, p', t', parallel) = optimalTwoParallelConfigurations threads p t
- producePipe sink = liftM fst $ (if parallel then pipeP else pipe)
- (produce p')
- (\source-> transduce t' source sink)
- in (configuration, producePipe)
-
-instance ParallelizableMonad m => PipeableComponentPair m y (Transducer m x y) (Transducer m y z) (Transducer m x z)
- where t1 >-> t2 = liftTransducer ">->" (maxUsableThreads t1 + maxUsableThreads t2) $
- \threads-> let (configuration, t1', t2', parallel) = optimalTwoParallelConfigurations threads t1 t2
- transducePipe source sink = liftM fst $ (if parallel then pipeP else pipe)
- (transduce t1' source)
- (\source-> transduce t2' source sink)
- in (configuration, transducePipe)
-
-class Component c => CompatibleSignature c cons (m :: * -> *) input output | c -> cons m
-
-class AnyListOrUnit c
-
-instance AnyListOrUnit [x]
-instance AnyListOrUnit ()
-
-instance (AnyListOrUnit x, AnyListOrUnit y) => CompatibleSignature (Performer m r) (PerformerType r) m x y
-instance AnyListOrUnit y => CompatibleSignature (Consumer m x r) (ConsumerType r) m [x] y
-instance AnyListOrUnit y => CompatibleSignature (Producer m x r) (ProducerType r) m y [x]
-instance CompatibleSignature (Transducer m x y) TransducerType m [x] [y]
-
-data PerformerType r
-data ConsumerType r
-data ProducerType r
-data TransducerType
-
--- | Class 'JoinableComponentPair' applies to any two components that can be combined into a third component with the
--- following properties:
---
--- * if both argument components consume input, the input of the combined component gets distributed to both
--- components in parallel,
---
--- * if both argument components produce output, the output of the combined component is a concatenation of the
--- complete output from the first component followed by the complete output of the second component, and
---
--- * the 'join' method may apply the components in any order, the 'sequence' method makes sure its first argument
--- has completed before using the second one.
-class (Monad m, CompatibleSignature c1 t1 m x y, CompatibleSignature c2 t2 m x y, CompatibleSignature c3 t3 m x y)
- => JoinableComponentPair t1 t2 t3 m x y c1 c2 c3 | c1 c2 -> c3, c1 -> t1 m, c2 -> t2 m, c3 -> t3 m x y,
- t1 m x y -> c1, t2 m x y -> c2, t3 m x y -> c3
- where join :: c1 -> c2 -> c3
- sequence :: c1 -> c2 -> c3
- join = sequence
-
-instance forall m x any r1 r2. (Monad m, Typeable x)
- => JoinableComponentPair (ProducerType r1) (ProducerType r2) (ProducerType r2) m () [x] (Producer m x r1) (Producer m x r2) (Producer m x r2)
- where sequence p1 p2 = liftProducer "sequence" (maxUsableThreads p1 `max` maxUsableThreads p2) $
- \threads-> let (configuration, p1', p2') = optimalTwoSequentialConfigurations threads p1 p2
- produceJoin sink = produce p1' sink >> produce p2' sink
- in (configuration, produceJoin)
-
-instance forall m x any. (ParallelizableMonad m, Typeable x)
- => JoinableComponentPair (ConsumerType ()) (ConsumerType ()) (ConsumerType ()) m [x] () (Consumer m x ()) (Consumer m x ()) (Consumer m x ())
- where join c1 c2 = liftConsumer "join" (maxUsableThreads c1 + maxUsableThreads c2) $
- \threads-> let (configuration, c1', c2', parallel) = optimalTwoParallelConfigurations threads c1 c2
- consumeJoin source = do (if parallel then pipeP else pipe)
- (\sink1-> pipe (tee source sink1) (consume c2'))
- (consume c1')
- return ()
- in (configuration, consumeJoin)
- sequence c1 c2 = liftConsumer "sequence" (maxUsableThreads c1 `max` maxUsableThreads c2) $
- \threads-> let (configuration, c1', c2') = optimalTwoSequentialConfigurations threads c1 c2
- consumeJoin source = pipe
- (\buffer-> pipe (tee source buffer) (consume c1'))
- getList
- >>= \(_, list)-> pipe (putList list) (consume c2')
- >> return ()
- in (configuration, consumeJoin)
-
-instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)
- => JoinableComponentPair TransducerType TransducerType TransducerType m [x] [y] (Transducer m x y) (Transducer m x y) (Transducer m x y)
- where join t1 t2 = liftTransducer "join" (maxUsableThreads t1 + maxUsableThreads t2) $
- \threads-> let (configuration, t1', t2', parallel) = optimalTwoParallelConfigurations threads t1 t2
- transduce' source sink = pipe
- (\buffer-> (if parallel then pipeP else pipe)
- (\sink1-> pipe
- (\sink2-> tee source sink1 sink2)
- (\src-> transduce t2' src buffer))
- (\source-> transduce t1' source sink))
- getList
- >>= \(_, list)-> putList list sink
- >> getList source
- in (configuration, transduce')
- sequence t1 t2 = liftTransducer "sequence" (maxUsableThreads t1 `max` maxUsableThreads t2) $
- \threads-> let (configuration, t1', t2') = optimalTwoSequentialConfigurations threads t1 t2
- transduce' source sink = pipe
- (\buffer-> pipe
- (tee source buffer)
- (\source-> transduce t1 source sink))
- getList
- >>= \(_, list)-> pipe
- (\sink-> putList list sink
- >>= whenNull
- (pour source sink
- >> return []))
- (\source-> transduce t2 source sink)
- >>= return . fst
- in (configuration, transduce')
-
-
-instance forall m r1 r2. ParallelizableMonad m
- => JoinableComponentPair (PerformerType r1) (PerformerType r2) (PerformerType r2) m () () (Performer m r1) (Performer m r2) (Performer m r2)
- where join p1 p2 = liftPerformer "join" (maxUsableThreads p1 + maxUsableThreads p2) $
- \threads-> let (configuration, p1', p2', parallel) = optimalTwoParallelConfigurations threads p1 p2
- in (configuration, if parallel then liftM snd $ perform p1' `parallelize` perform p2'
- else perform p1' >> perform p2')
- sequence p1 p2 = liftPerformer "sequence" (maxUsableThreads p1 `max` maxUsableThreads p2) $
- \threads-> let (configuration, p1', p2') = optimalTwoSequentialConfigurations threads p1 p2
- in (configuration, perform p1' >> perform p2')
-
-instance forall m x r1 r2. (ParallelizableMonad m, Typeable x)
- => JoinableComponentPair (PerformerType r1) (ProducerType r2) (ProducerType r2) m () [x] (Performer m r1) (Producer m x r2) (Producer m x r2)
- where join pe pr = liftProducer "join" (maxUsableThreads pe + maxUsableThreads pr) $
- \threads-> let (configuration, pe', pr', parallel) = optimalTwoParallelConfigurations threads pe pr
- produceJoin sink = if parallel then liftM snd (perform pe' `parallelize` produce pr' sink)
- else perform pe' >> produce pr' sink
- in (configuration, produceJoin)
- sequence pe pr = liftProducer "sequence" (maxUsableThreads pe `max` maxUsableThreads pr) $
- \threads-> let (configuration, pe', pr') = optimalTwoSequentialConfigurations threads pe pr
- produceJoin sink = perform pe' >> produce pr' sink
- in (configuration, produceJoin)
-
-instance forall m x r1 r2. (ParallelizableMonad m, Typeable x)
- => JoinableComponentPair (ProducerType r1) (PerformerType r2) (ProducerType r2) m () [x] (Producer m x r1) (Performer m r2) (Producer m x r2)
- where join pr pe = liftProducer "join" (maxUsableThreads pr + maxUsableThreads pe) $
- \threads-> let (configuration, pr', pe', parallel) = optimalTwoParallelConfigurations threads pr pe
- produceJoin sink = if parallel then liftM snd (produce pr' sink `parallelize` perform pe')
- else produce pr' sink >> perform pe'
- in (configuration, produceJoin)
- sequence pr pe = liftProducer "sequence" (maxUsableThreads pr `max` maxUsableThreads pe) $
- \threads-> let (configuration, pr', pe') = optimalTwoSequentialConfigurations threads pr pe
- produceJoin sink = produce pr' sink >> perform pe'
- in (configuration, produceJoin)
-
-instance forall m x r1 r2. (ParallelizableMonad m, Typeable x)
- => JoinableComponentPair (PerformerType r1) (ConsumerType r2) (ConsumerType r2) m [x] () (Performer m r1) (Consumer m x r2) (Consumer m x r2)
- where join p c = liftConsumer "join" (maxUsableThreads p + maxUsableThreads c) $
- \threads-> let (configuration, p', c', parallel) = optimalTwoParallelConfigurations threads p c
- consumeJoin source = if parallel then liftM snd (perform p' `parallelize` consume c' source)
- else perform p' >> consume c' source
- in (configuration, consumeJoin)
- sequence p c = liftConsumer "sequence" (maxUsableThreads p `max` maxUsableThreads c) $
- \threads-> let (configuration, p', c') = optimalTwoSequentialConfigurations threads p c
- consumeJoin source = perform p' >> consume c' source
- in (configuration, consumeJoin)
-
-instance forall m x r1 r2. (ParallelizableMonad m, Typeable x)
- => JoinableComponentPair (ConsumerType r1) (PerformerType r2) (ConsumerType r2) m [x] () (Consumer m x r1) (Performer m r2) (Consumer m x r2)
- where join c p = liftConsumer "join" (maxUsableThreads c + maxUsableThreads p) $
- \threads-> let (configuration, c', p', parallel) = optimalTwoParallelConfigurations threads c p
- consumeJoin source = if parallel then liftM snd (consume c' source `parallelize` perform p')
- else consume c' source >> perform p'
- in (configuration, consumeJoin)
- sequence c p = liftConsumer "sequence" (maxUsableThreads c `max` maxUsableThreads p) $
- \threads-> let (configuration, c', p') = optimalTwoSequentialConfigurations threads c p
- consumeJoin source = consume c' source >> perform p'
- in (configuration, consumeJoin)
-
-instance forall m x y r. (ParallelizableMonad m, Typeable x, Typeable y)
- => JoinableComponentPair (PerformerType r) TransducerType TransducerType m [x] [y] (Performer m r) (Transducer m x y) (Transducer m x y)
- where join p t = liftTransducer "join" (maxUsableThreads p + maxUsableThreads t) $
- \threads-> let (configuration, p', t', parallel) = optimalTwoParallelConfigurations threads p t
- join' source sink = if parallel then liftM snd (perform p'
- `parallelize` transduce t' source sink)
- else perform p' >> transduce t' source sink
- in (configuration, join')
- sequence p t = liftTransducer "sequence" (maxUsableThreads p `max` maxUsableThreads t) $
- \threads-> let (configuration, p', t') = optimalTwoSequentialConfigurations threads p t
- join' source sink = perform p' >> transduce t' source sink
- in (configuration, join')
-
-instance forall m x y r. (ParallelizableMonad m, Typeable x, Typeable y)
- => JoinableComponentPair TransducerType (PerformerType r) TransducerType m [x] [y] (Transducer m x y) (Performer m r) (Transducer m x y)
- where join t p = liftTransducer "join" (maxUsableThreads t + maxUsableThreads p) $
- \threads-> let (configuration, t', p', parallel) = optimalTwoParallelConfigurations threads t p
- join' source sink = if parallel then liftM fst (transduce t' source sink
- `parallelize` perform p')
- else do result <- transduce t' source sink
- perform p'
- return result
- in (configuration, join')
- sequence t p = liftTransducer "sequence" (maxUsableThreads t `max` maxUsableThreads p) $
- \threads-> let (configuration, t', p') = optimalTwoSequentialConfigurations threads t p
- join' source sink = do result <- transduce t' source sink
- perform p'
- return result
- in (configuration, join')
-
-instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)
- => JoinableComponentPair (ProducerType ()) TransducerType TransducerType m [x] [y] (Producer m y ()) (Transducer m x y) (Transducer m x y)
- where join p t = liftTransducer "join" (maxUsableThreads p + maxUsableThreads t) $
- \threads-> let (configuration, p', t', parallel) = optimalTwoParallelConfigurations threads p t
- join' source sink = if parallel
- then do ((_, rest), out) <- pipe
- (\buffer-> produce p' sink `parallelize`
- transduce t' source buffer)
- getList
- putList out sink
- return rest
- else produce p' sink >> transduce t' source sink
- in (configuration, join')
- sequence p t = liftTransducer "sequence" (maxUsableThreads p `max` maxUsableThreads t) $
- \threads-> let (configuration, p', t') = optimalTwoSequentialConfigurations threads p t
- join' source sink = produce p' sink >> transduce t' source sink
- in (configuration, join')
-
-instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)
- => JoinableComponentPair TransducerType (ProducerType ()) TransducerType m [x] [y] (Transducer m x y) (Producer m y ()) (Transducer m x y)
- where join t p = liftTransducer "join" (maxUsableThreads t `max` maxUsableThreads p) $
- \threads-> let (configuration, t', p', parallel) = optimalTwoParallelConfigurations threads t p
- join' source sink = if parallel
- then do ((rest, ()), out) <- pipe
- (\buffer-> transduce t' source sink
- `parallelize` produce p' buffer)
- getList
- putList out sink
- return rest
- else do result <- transduce t' source sink
- produce p' sink
- return result
- in (configuration, join')
- sequence t p = liftTransducer "sequence" (maxUsableThreads t `max` maxUsableThreads p) $
- \threads-> let (configuration, t', p') = optimalTwoSequentialConfigurations threads t p
- join' source sink = do result <- transduce t' source sink
- produce p' sink
- return result
- in (configuration, join')
-
-instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)
- => JoinableComponentPair (ConsumerType ()) TransducerType TransducerType m [x] [y] (Consumer m x ()) (Transducer m x y) (Transducer m x y)
- where join c t = liftTransducer "join" (maxUsableThreads c + maxUsableThreads t) $
- \threads-> let (configuration, c', t', parallel) = optimalTwoParallelConfigurations threads c t
- join' source sink = liftM (snd . fst) $
- (if parallel then pipeP else pipe)
- (\sink1-> pipe
- (tee source sink1)
- (\source-> transduce t' source sink))
- (consume c')
- in (configuration, join')
- sequence c t = liftTransducer "sequence" (maxUsableThreads c `max` maxUsableThreads t) $
- \threads-> let (configuration, c', t') = optimalTwoSequentialConfigurations threads c t
- sequence' source sink = pipe
- (\buffer-> pipe
- (tee source buffer)
- (consume c'))
- getList
- >>= \(_, list)-> pipe
- (\sink-> putList list sink
- >>= whenNull (pour source sink
- >> return []))
- (\source-> transduce t' source sink)
- >>= return . fst
- in (configuration, sequence')
-
-instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)
- => JoinableComponentPair TransducerType (ConsumerType ()) TransducerType m [x] [y] (Transducer m x y) (Consumer m x ()) (Transducer m x y)
- where join t c = join c t
- sequence t c = liftTransducer "sequence" (maxUsableThreads t `max` maxUsableThreads c) $
- \threads-> let (configuration, t', c') = optimalTwoSequentialConfigurations threads t c
- sequence' source sink = pipe
- (\buffer-> pipe
- (tee source buffer)
- (\source-> transduce t' source sink))
- getList
- >>= \(_, list)-> pipe
- (\sink-> putList list sink
- >>= whenNull (pour source sink
- >> return []))
- (consume c')
- >>= return . fst
- in (configuration, sequence')
-
-instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)
- => JoinableComponentPair (ProducerType ()) (ConsumerType ()) TransducerType m [x] [y] (Producer m y ()) (Consumer m x ()) (Transducer m x y)
- where join p c = liftTransducer "sequence" (maxUsableThreads p + maxUsableThreads c) $
- \threads-> let (configuration, p', c', parallel) = optimalTwoParallelConfigurations threads p c
- join' source sink = if parallel then produce p' sink >> consume c' source >> return []
- else parallelize (produce p' sink) (consume c' source) >> return []
- in (configuration, join')
- sequence p c = liftTransducer "sequence" (maxUsableThreads p `max` maxUsableThreads c) $
- \threads-> let (configuration, p', c') = optimalTwoSequentialConfigurations threads p c
- join' source sink = produce p' sink >> consume c' source >> return []
- in (configuration, join')
-
-instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)
- => JoinableComponentPair (ConsumerType ()) (ProducerType ()) TransducerType m [x] [y] (Consumer m x ()) (Producer m y ()) (Transducer m x y)
- where join c p = join p c
- sequence c p = liftTransducer "sequence" (maxUsableThreads c `max` maxUsableThreads p) $
- \threads-> let (configuration, c', p') = optimalTwoSequentialConfigurations threads c p
- join' source sink = consume c' source >> produce p' sink >> return []
- in (configuration, join')
-
--- | Combinator 'prepend' converts the given producer to transducer that passes all its input through unmodified, except
--- | for prepending the output of the argument producer to it.
--- | 'prepend' /prefix/ = 'join' ('substitute' /prefix/) 'asis'
-prepend :: forall m x r. (Monad m, Typeable x) => Producer m x r -> Transducer m x x
-prepend prefix = liftTransducer "prepend" (maxUsableThreads prefix) $
- \threads-> let prefix' = usingThreads threads prefix
- prepend' source sink = produce prefix' sink >> pour source sink >> return []
- in (ComponentConfiguration [AnyComponent prefix] threads (cost prefix'), prepend')
-
--- | Combinator 'append' converts the given producer to transducer that passes all its input through unmodified, finally
--- | appending to it the output of the argument producer.
--- | 'append' /suffix/ = 'join' 'asis' ('substitute' /suffix/)
-append :: forall m x r. (Monad m, Typeable x) => Producer m x r -> Transducer m x x
-append suffix = liftTransducer "append" (maxUsableThreads suffix) $
- \threads-> let suffix' = usingThreads threads suffix
- append' source sink = pour source sink >> produce suffix' sink >> return []
- in (ComponentConfiguration [AnyComponent suffix] threads (cost suffix'), append')
-
--- | The 'substitute' combinator converts its argument producer to a transducer that produces the same output, while
--- | consuming its entire input and ignoring it.
-substitute :: forall m x y r. (Monad m, Typeable x, Typeable y) => Producer m y r -> Transducer m x y
-substitute feed = liftTransducer "substitute" (maxUsableThreads feed) $
- \threads-> let feed' = usingThreads threads feed
- substitute' source sink = consumeAndSuppress source >> produce feed' sink >> return []
- in (ComponentConfiguration [AnyComponent feed] threads (cost feed'), substitute')
-
--- | The 'snot' (streaming not) combinator simply reverses the outputs of the argument splitter.
--- In other words, data that the argument splitter sends to its /true/ sink goes to the /false/ sink of the result, and vice versa.
-snot :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x b
-snot splitter = liftSplitter "not" (maxUsableThreads splitter) $
- \threads-> let splitter' = usingThreads threads splitter
- not source true false edge = liftM fst $
- pipe
- (split splitter source false true)
- consumeAndSuppress
- in (ComponentConfiguration [AnyComponent splitter'] threads (cost splitter'), not)
-
--- | The '>&' combinator sends the /true/ sink output of its left operand to the input of its right operand for further
--- splitting. Both operands' /false/ sinks are connected to the /false/ sink of the combined splitter, but any input
--- value to reach the /true/ sink of the combined component data must be deemed true by both splitters.
-(>&) :: (ParallelizableMonad m, Typeable x, Typeable b1, Typeable b2) => Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)
-s1 >& s2 = liftSplitter ">&" (maxUsableThreads s1 + maxUsableThreads s2) $
- \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2
- s source true false edge = liftM (fst . fst . fst . fst) $
- pipe
- (\edges->
- pipe
- (\edge1-> pipe
- (\edge2-> (if parallel then pipeP else pipe)
- (\true-> split s1' source true false edge1)
- (\source-> split s2' source true false edge2))
- (flip (pourMap Right) edges))
- (flip (pourMap Left) edges))
- (flip intersectRegions edge)
- in (configuration, s)
-
-intersectRegions source sink = next Nothing Nothing
- where next lastLeft lastRight = get source
- >>= maybe
- (return ())
- (either
- (flip pair lastRight . Just)
- (pair lastLeft . Just))
- pair l@(Just x) r@(Just y) = put sink (x, y)
- >>= flip when (next Nothing Nothing)
- pair l r = next l r
-
--- | A '>|' combinator's input value can reach its /false/ sink only by going through both argument splitters' /false/
--- sinks.
-(>|) :: forall m x b1 b2. (ParallelizableMonad m, Typeable x, Typeable b1, Typeable b2)
- => Splitter m x b1 -> Splitter m x b2 -> Splitter m x (Either b1 b2)
-s1 >| s2 = liftSplitter ">|" (maxUsableThreads s1 + maxUsableThreads s2) $
- \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2
- s source true false edge = liftM (fst . fst . fst) $
- pipe
- (\edge1-> pipe
- (\edge2-> (if parallel then pipeP else pipe)
- (\false-> split s1' source true false edge1)
- (\source-> split s2' source true false edge2))
- (flip (pourMap Right) edge))
- (flip (pourMap Left) edge)
- in (configuration, s)
-
--- | Combinator '&&' is a pairwise logical conjunction of two splitters run in parallel on the same input.
-(&&) :: (ParallelizableMonad m, Typeable x, Typeable b1, Typeable b2) => Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)
-s1 && s2 = liftSplitter "&&" (maxUsableThreads s1 + maxUsableThreads s2) $
- \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2
- s source true false edge = liftM (\(x, y)-> y ++ x) $
- (if parallel then pipeP else pipe)
- (transduce (splittersToPairMarker s1' s2') source)
- (\source-> let split l r = get source
- >>= maybe
- (return [])
- (test l r)
- test l r (Left (x, t1, t2))
- = put (if t1 Prelude.&& t2 then true else false) x
- >>= cond
- (split
- (if t1 then l else Nothing)
- (if t2 then r else Nothing))
- (return [x])
- test _ Nothing (Right (Left l)) = split (Just l) Nothing
- test _ (Just r) (Right (Left l))
- = put edge (l, r) >> split (Just l) (Just r)
- test Nothing _ (Right (Right r)) = split Nothing (Just r)
- test (Just l) _ (Right (Right r))
- = put edge (l, r) >> split (Just l) (Just r)
- in split Nothing Nothing)
- in (configuration, s)
-
--- | Combinator '||' is a pairwise logical disjunction of two splitters run in parallel on the same input.
-(||) :: (ParallelizableMonad m, Typeable x, Typeable b1, Typeable b2)
- => Splitter m x b1 -> Splitter m x b2 -> Splitter m x (Either b1 b2)
-(||) = zipSplittersWith (Prelude.||) pour
-
-ifs :: (ParallelizableMonad m, Typeable x, Typeable b, BranchComponent cc m x [x]) => Splitter m x b -> cc -> cc -> cc
-ifs s = combineBranches "if" (cost s) (\ parallel c1 c2 -> \source-> splitInputToConsumers parallel s source c1 c2)
-
-wherever :: (ParallelizableMonad m, Typeable x, Typeable b) => Transducer m x x -> Splitter m x b -> Transducer m x x
-wherever t s = liftTransducer "wherever" (maxUsableThreads s + maxUsableThreads t) $
- \threads-> let (configuration, s', t', parallel) = optimalTwoParallelConfigurations threads s t
- wherever' source sink = splitInputToConsumers parallel s source
- (\source-> transduce t source sink)
- (\source-> pour source sink >> return [])
- in (configuration, wherever')
-
-unless :: (ParallelizableMonad m, Typeable x, Typeable b) => Transducer m x x -> Splitter m x b -> Transducer m x x
-unless t s = liftTransducer "unless" (maxUsableThreads s + maxUsableThreads t) $
- \threads-> let (configuration, s', t', parallel) = optimalTwoParallelConfigurations threads s t
- unless' source sink = splitInputToConsumers parallel s source
- (\source-> pour source sink >> return [])
- (\source-> transduce t source sink)
- in (configuration, unless')
-
-select :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Transducer m x x
-select s = liftTransducer "select" (maxUsableThreads s) $
- \threads-> let s' = usingThreads threads s
- transduce' source sink = splitInputToConsumers False s' source
- (\source-> pour source sink >> return [])
- (\source-> consumeAndSuppress source >> return [])
- in (ComponentConfiguration [AnyComponent s'] threads (cost s' + 1), transduce')
-
--- | Converts a splitter into a parser.
-parseRegions :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Parser m x b
-parseRegions s = liftTransducer "parseRegions" (maxUsableThreads s) $
- \threads-> let s' = usingThreads threads s
- transduce' source sink = liftM (\(x, y)-> y ++ x) $
- pipe
- (transduce (splitterToMarker s') source)
- (\source-> wrapRegions source sink)
- wrapRegions source sink = let wrap0 mb = get source
- >>= maybe
- (maybe (return True) flush mb >> return [])
- (wrap1 mb)
- wrap1 Nothing (Left (x, _)) = put sink (Content x)
- >>= cond (wrap0 Nothing) (return [x])
- wrap1 (Just p) (Left (x, False)) = flush p
- >> put sink (Content x)
- >>= cond
- (wrap0 Nothing)
- (return [x])
- wrap1 (Just (b, t)) (Left (x, True))
- = (if t then return True else put sink (Markup (Start b)))
- >> put sink (Content x)
- >>= cond (wrap0 (Just (b, True))) (return [x])
- wrap1 (Just p) (Right b') = flush p >> wrap0 (Just (b', False))
- wrap1 Nothing (Right b) = wrap0 (Just (b, False))
- flush (b, t) = put sink $ Markup $ (if t then End else Point) b
- in wrap0 Nothing
- in (ComponentConfiguration [AnyComponent s'] threads (cost s' + 1), transduce')
-
--- | Converts a boundary-marking splitter into a parser.
-parseNestedRegions :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x (Boundary b) -> Parser m x b
-parseNestedRegions s = liftTransducer "parseNestedRegions" (maxUsableThreads s) $
- \threads-> let s' = usingThreads threads s
- transduce' source sink = liftM (\(w, (), (), _)-> w) $
- splitToConsumers s' source
- (flip (pourMap Content) sink)
- (flip (pourMap Content) sink)
- (flip (pourMap Markup) sink)
- in (ComponentConfiguration [AnyComponent s'] threads (cost s' + 1), transduce')
-
--- | The recursive combinator 'while' feeds the true sink of the argument splitter back to itself, modified by the
--- argument transducer. Data fed to the splitter's false sink is passed on unmodified.
-while :: (ParallelizableMonad m, Typeable x, Typeable b) => Transducer m x x -> Splitter m x b -> Transducer m x x
-while t s = liftTransducer "while" (maxUsableThreads t + maxUsableThreads s) $
- \threads-> let (configuration, s', while'', parallel) = optimalTwoParallelConfigurations threads s while'
- transduce' source sink = splitInputToConsumers parallel s' source
- (\source-> transduce while' source sink)
- (\source-> pour source sink >> return [])
- while' = t >-> while t s
- in (configuration, transduce')
-
--- | The recursive combinator 'nestedIn' combines two splitters into a mutually recursive loop acting as a single splitter.
--- The true sink of one of the argument splitters and false sink of the other become the true and false sinks of the loop.
--- The other two sinks are bound to the other splitter's source.
--- The use of 'nestedIn' makes sense only on hierarchically structured streams. If we gave it some input containing
--- a flat sequence of values, and assuming both component splitters are deterministic and stateless,
--- an input value would either not loop at all or it would loop forever.
-nestedIn :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x b -> Splitter m x b
-nestedIn s1 s2 = liftSplitter "nestedIn" (maxUsableThreads s1 + maxUsableThreads s2) $
- \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2
- s source true false edge
- = liftM fst $
- (if parallel then pipeP else pipe)
- (\false-> split s1' source true false edge)
- (\source-> pipe
- (\true-> pipe (split s2' source true false) consumeAndSuppress)
- (\source-> get source
- >>= maybe
- (return ([], []))
- (\x-> pipe
- (\sink-> put sink x
- >>= cond
- (pour source sink
- >> return [])
- (return [x]))
- (\source-> split
- (nestedIn s1' s2')
- source true false edge))))
- in (configuration,s)
-
--- | The 'foreach' combinator is similar to the combinator 'ifs' in that it combines a splitter and two transducers into
--- another transducer. However, in this case the transducers are re-instantiated for each consecutive portion of the
--- input as the splitter chunks it up. Each contiguous portion of the input that the splitter sends to one of its two
--- sinks gets transducered through the appropriate argument transducer as that transducer's whole input. As soon as the
--- contiguous portion is finished, the transducer gets terminated.
-foreach :: (ParallelizableMonad m, Typeable x, Typeable b, BranchComponent cc m x [x]) => Splitter m x b -> cc -> cc -> cc
-foreach s = combineBranches "foreach" (cost s)
- (\ parallel c1 c2 source-> liftM fst $ (if parallel then pipeP else pipe)
- (transduce (splitterToMarker s) source)
- (\source-> groupMarks source (maybe c2 (const c1))))
-
--- | The 'having' combinator combines two pure splitters into a pure splitter. One splitter is used to chunk the input
--- into contiguous portions. Its /false/ sink is routed directly to the /false/ sink of the combined splitter. The
--- second splitter is instantiated and run on each portion of the input that goes to first splitter's /true/ sink. If
--- the second splitter sends any output at all to its /true/ sink, the whole input portion is passed on to the /true/
--- sink of the combined splitter, otherwise it goes to its /false/ sink.
-having :: (ParallelizableMonad m, Typeable x, Typeable b1, Typeable b2)
- => Splitter m x b1 -> Splitter m x b2 -> Splitter m x b1
-having s1 s2 = liftSplitter "having" (maxUsableThreads s1 + maxUsableThreads s2) $
- \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2
- s source true false edge = liftM fst $
- (if parallel then pipeP else pipe)
- (transduce (splitterToMarker s1') source)
- (flip groupMarks test)
- where test Nothing chunk = pour chunk false >> return []
- test (Just mb) chunk = pipe
- (\sink1-> pipe (tee chunk sink1) getList)
- (\chunk-> splitToConsumers s2' chunk
- (liftM isJust . get)
- consumeAndSuppress
- (liftM isJust . get))
- >>= \(((), prefix), (_, anyTrue, (), anyEdge))->
- if anyTrue Prelude.|| anyEdge
- then maybe (return True) (put edge) mb
- >> putList prefix true
- >>= whenNull (pour chunk true >> return [])
- else putList prefix false
- >>= whenNull (pour chunk false >> return [])
- in (configuration, s)
-
--- | The 'havingOnly' combinator is analogous to the 'having' combinator, but it succeeds and passes each chunk of the
--- input to its /true/ sink only if the second splitter sends no part of it to its /false/ sink.
-havingOnly :: (ParallelizableMonad m, Typeable x, Typeable b1, Typeable b2)
- => Splitter m x b1 -> Splitter m x b2 -> Splitter m x b1
-havingOnly s1 s2 = liftSplitter "havingOnly" (maxUsableThreads s1 + maxUsableThreads s2) $
- \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2
- s source true false edge = liftM fst $
- (if parallel then pipeP else pipe)
- (transduce (splitterToMarker s1') source)
- (flip groupMarks test)
- where test Nothing chunk = pour chunk false >> return []
- test (Just mb) chunk = pipe
- (\sink1-> pipe (tee chunk sink1) getList)
- (\chunk-> splitToConsumers s2' chunk
- consumeAndSuppress
- (liftM isJust . get)
- consumeAndSuppress)
- >>= \(((), prefix), (_, (), anyFalse, ()))->
- if anyFalse
- then putList prefix false
- >>= whenNull (pour chunk false >> return [])
- else maybe (return True) (put edge) mb
- >> putList prefix true
- >>= whenNull (pour chunk true >> return [])
- in (configuration, s)
-
--- | The result of combinator 'first' behaves the same as the argument splitter up to and including the first portion of
--- the input which goes into the argument's /true/ sink. All input following the first true portion goes into the
--- /false/ sink.
-first :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x b
-first splitter = liftSplitter "first" (maxUsableThreads splitter) $
- \threads-> let splitter' = usingThreads threads splitter
- configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)
- s source true false edge
- = liftM (\(x, y)-> y ++ x) $
- pipeD "first" (transduce (splitterToMarker splitter') source)
- (\source-> let get1 (Left (x, False)) = pass false x get1
- get1 (Left (x, True)) = pass true x get2
- get1 (Right b) = put edge b
- >> get source
- >>= maybe (return []) get2
- get2 b@Right{} = get3 b
- get2 (Left (x, True)) = pass true x get2
- get2 (Left (x, False)) = pass false x get3
- get3 (Left (x, _)) = pass false x get3
- get3 (Right _) = get source >>= maybe (return []) get3
- pass sink x next = put sink x
- >>= cond
- (get source >>= maybe (return []) next)
- (return [x])
- in get source >>= maybe (return []) get1)
- in (configuration, s)
-
--- | The result of combinator 'uptoFirst' takes all input up to and including the first portion of the input which goes
--- into the argument's /true/ sink and feeds it to the result splitter's /true/ sink. All the rest of the input goes
--- into the /false/ sink. The only difference between 'first' and 'uptoFirst' combinators is in where they direct the
--- /false/ portion of the input preceding the first /true/ part.
-uptoFirst :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x b
-uptoFirst splitter = liftSplitter "uptoFirst" (maxUsableThreads splitter) $
- \threads-> let splitter' = usingThreads threads splitter
- configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)
- s source true false edge
- = liftM (\(x, y)-> y ++ x) $
- pipeD "uptoFirst" (transduce (splitterToMarker splitter') source)
- (\source-> let get1 q (Left (x, False)) = let q' = q |> x
- in get source
- >>= maybe
- (putQueue q' false)
- (get1 q')
- get1 q p@(Left (_, True)) = putQueue q true
- >>= whenNull (get2 p)
- get1 q (Right b) = putQueue q true
- >>= whenNull (put edge b
- >> get source
- >>= maybe (return []) get2)
- get2 b@Right{} = get3 b
- get2 (Left (x, True)) = pass true x get2
- get2 (Left (x, False)) = pass false x get3
- get3 (Left (x, _)) = pass false x get3
- get3 (Right _) = get source >>= maybe (return []) get3
- pass sink x next = put sink x
- >>= cond
- (get source >>= maybe (return []) next)
- (return [x])
- in get source >>= maybe (return []) (get1 Seq.empty))
- in (configuration, s)
-
--- | The result of the combinator 'last' is a splitter which directs all input to its /false/ sink, up to the last
--- portion of the input which goes to its argument's /true/ sink. That portion of the input is the only one that goes to
--- the resulting component's /true/ sink. The splitter returned by the combinator 'last' has to buffer the previous two
--- portions of its input, because it cannot know if a true portion of the input is the last one until it sees the end of
--- the input or another portion succeeding the previous one.
-last :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x b
-last splitter = liftSplitter "last" (maxUsableThreads splitter) $
- \threads-> let splitter' = usingThreads threads splitter
- configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)
- s source true false edge
- = liftM (\(x, y)-> y ++ x) $
- pipeD "last" (transduce (splitterToMarker splitter') source)
- (\source-> let get1 (Left (x, False)) = put false x
- >>= cond (get source
- >>= maybe (return []) get1)
- (return [x])
- get1 p@(Left (x, True)) = get2 Nothing Seq.empty p
- get1 (Right b) = pass (get2 (Just b) Seq.empty)
- get2 mb q (Left (x, True)) = let q' = q |> x
- in get source
- >>= maybe
- (flush mb q')
- (get2 mb q')
- get2 mb q p = get3 mb q Seq.empty p
- get3 mb qt qf (Left (x, False)) = let qf' = qf |> x
- in get source
- >>= maybe
- (flush mb qt >> putQueue qf' false)
- (get3 mb qt qf')
- get3 mb qt qf p = do rest1 <- putQueue qt false
- rest2 <- putQueue qf false
- if null rest1 Prelude.&& null rest2
- then get1 p
- else return (rest1 ++ rest2)
- flush mb q = maybe (return True) (put edge) mb
- >> putQueue q true
- pass succeed = get source >>= maybe (return []) succeed
- in pass get1)
- in (configuration, s)
-
--- | The result of the combinator 'lastAndAfter' is a splitter which directs all input to its /false/ sink, up to the
--- last portion of the input which goes to its argument's /true/ sink. That portion and the remainder of the input is fed
--- to the resulting component's /true/ sink. The difference between 'last' and 'lastAndAfter' combinators is where they
--- feed the /false/ portion of the input, if any, remaining after the last /true/ part.
-lastAndAfter :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x b
-lastAndAfter splitter = liftSplitter "lastAndAfter" (maxUsableThreads splitter) $
- \threads-> let splitter' = usingThreads threads splitter
- configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)
- s source true false edge
- = liftM (\(x, y)-> y ++ x) $
- pipe
- (transduce (splitterToMarker splitter') source)
- (\source-> let get1 (Left (x, False)) = put false x
- >>= cond (pass get1) (return [x])
- get1 p@(Left (x, True)) = get2 Nothing Seq.empty p
- get1 (Right b) = pass (get2 (Just b) Seq.empty)
- get2 mb q (Left (x, True)) = let q' = q |> x
- in get source
- >>= maybe
- (flush mb q')
- (get2 mb q')
- get2 mb q p = get3 mb q p
- get3 mb q (Left (x, False)) = let q' = q |> x
- in get source
- >>= maybe
- (flush mb q')
- (get3 mb q')
- get3 _ q p@(Left (x, True)) = putQueue q false
- >>= whenNull (get1 p)
- get3 _ q b'@Right{} = putQueue q false
- >>= whenNull (get1 b')
- flush mb q = maybe (return True) (put edge) mb
- >> putQueue q true
- pass succeed = get source >>= maybe (return []) succeed
- in pass get1)
- in (configuration, s)
-
--- | The 'prefix' combinator feeds its /true/ sink only the prefix of the input that its argument feeds to its /true/ sink.
--- All the rest of the input is dumped into the /false/ sink of the result.
-prefix :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x b
-prefix splitter = liftSplitter "prefix" (maxUsableThreads splitter) $
- \threads-> let splitter' = usingThreads threads splitter
- configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)
- s source true false edge
- = liftM (\(x, y)-> y ++ x) $
- pipeD "prefix" (transduce (splitterToMarker splitter') source)
- (\source-> let get0 p@Left{} = get1 p
- get0 (Right b) = put edge b >> get source >>= maybe (return []) get1
- get1 (Left (x, False)) = pass false x get2
- get1 (Left (x, True)) = pass true x get1
- get1 (Right b) = get source >>= maybe (return []) get2
- get2 (Left (x, _)) = pass false x get2
- get2 Right{} = get source >>= maybe (return []) get2
- pass sink x next = put sink x
- >>= cond
- (get source >>= maybe (return []) next)
- (return [x])
- in get source >>= maybe (return []) get0)
- in (configuration, s)
-
--- | The 'suffix' combinator feeds its /true/ sink only the suffix of the input that its argument feeds to its /true/ sink.
--- All the rest of the input is dumped into the /false/ sink of the result.
-suffix :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x b
-suffix splitter = liftSplitter "suffix" (maxUsableThreads splitter) $
- \threads-> let splitter' = usingThreads threads splitter
- configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)
- s source true false edge
- = liftM (\(x, y)-> y ++ x) $
- pipeD "suffix" (transduce (splitterToMarker splitter') source)
- (\source-> let get1 (Left (x, False)) = put false x >>= cond (p get1) (return [x])
- get1 (Left (x, True)) = get2 Nothing (Seq.singleton x)
- get1 (Right b) = get2 (Just b) Seq.empty
- get2 mb q = get source
- >>= maybe
- (maybe (return True) (put edge) mb >> putQueue q true)
- (get3 mb q)
- get3 mb q (Left (x, True)) = get2 mb (q |> x)
- get3 mb q p@(Left (x, False)) = putQueue q false
- >>= \rest-> if null rest
- then get1 p
- else return (rest ++ [x])
- get3 mb q (Right b) = putQueue q false
- >>= whenNull (get2 (Just b) Seq.empty)
- p succeed = get source >>= maybe (return []) succeed
- in p get1)
- in (configuration, s)
-
--- | The 'even' combinator takes every input section that its argument /splitter/ deems /true/, and feeds even ones into
--- its /true/ sink. The odd sections and parts of input that are /false/ according to its argument splitter are fed to
--- 'even' splitter's /false/ sink.
-even :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x b
-even splitter = liftSplitter "even" (maxUsableThreads splitter) $
- \threads-> let splitter' = usingThreads threads splitter
- configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)
- s source true false edge
- = liftM (\(x, y)-> y ++ x) $
- pipeD "even"
- (transduce (splitterToMarker splitter') source)
- (\source-> let get1 (Left (x, False)) = put false x
- >>= cond (next get1) (return [x])
- get1 p@(Left (x, True)) = get2 p
- get1 (Right b) = next get2
- get2 (Left (x, True)) = put false x
- >>= cond (next get2) (return [x])
- get2 p@(Left (x, False)) = get3 p
- get2 (Right b) = put edge b >> next get4
- get3 (Left (x, False)) = put false x
- >>= cond (next get3) (return [x])
- get3 p@(Left (x, True)) = get4 p
- get3 (Right b) = put edge b >> next get4
- get4 (Left (x, True)) = put true x
- >>= cond (next get4) (return [x])
- get4 p@(Left (x, False)) = get1 p
- get4 (Right b) = next get2
- next g = get source >>= maybe (return []) g
- in next get1)
- in (configuration, s)
-
--- | Splitter 'startOf' issues an empty /true/ section at the beginning of every section considered /true/ by its
--- | argument splitter, otherwise the entire input goes into its /false/ sink.
-startOf :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x (Maybe b)
-startOf splitter = liftSplitter "startOf" (maxUsableThreads splitter) $
- \threads-> let splitter' = usingThreads threads splitter
- configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)
- s source true false edge = liftM (\(x, y)-> y ++ x) $
- pipeD "startOf"
- (transduce (splitterToMarker splitter') source)
- (\source-> let get1 (Left (x, False)) = put false x
- >>= cond
- (next get1)
- (return [x])
- get1 p@(Left (x, True)) = put edge Nothing >> get2 p
- get1 (Right b) = put edge (Just b)
- >> next get2
- get2 (Left (x, True)) = put false x
- >>= cond
- (next get2)
- (return [x])
- get2 p = get1 p
- next g = get source >>= maybe (return []) g
- in next get1)
- in (configuration, s)
-
--- | Splitter 'endOf' issues an empty /true/ section at the end of every section considered /true/ by its argument
--- | splitter, otherwise the entire input goes into its /false/ sink.
-endOf :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x (Maybe b)
-endOf splitter = liftSplitter "endOf" (maxUsableThreads splitter) $
- \threads-> let splitter' = usingThreads threads splitter
- configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)
- s source true false edge = liftM (\(x, y)-> y ++ x) $
- pipeD "endOf"
- (transduce (splitterToMarker splitter') source)
- (\source-> let get1 (Left (x, False)) = put false x
- >>= cond
- (next get1)
- (return [x])
- get1 p@(Left (x, True)) = get2 Nothing p
- get1 (Right b) = next (get2 $ Just b)
- get2 mb (Left (x, True))
- = put false x
- >>= cond (next $ get2 mb) (return [x])
- get2 mb p@(Left (x, False)) = put edge mb >> get1 p
- get2 mb (Right b) = put edge mb >> next (get2 $ Just b)
- next g = get source >>= maybe (return []) g
- in next get1)
- in (configuration, s)
-
--- | Combinator 'followedBy' treats its argument 'Splitter's as patterns components and returns a 'Splitter' that
--- matches their concatenation. A section of input is considered /true/ by the result iff its prefix is considered
--- /true/ by argument /s1/ and the rest of the section is considered /true/ by /s2/. The splitter /s2/ is started anew
--- after every section split to /true/ sink by /s1/.
-followedBy :: forall m x b1 b2. (ParallelizableMonad m, Typeable x, Typeable b1, Typeable b2)
- => Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)
-followedBy s1 s2 = liftSplitter "followedBy" (maxUsableThreads s1 + maxUsableThreads s2) $
- \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2
- in (configuration, followedBy' parallel s1' s2')
- where followedBy' parallel s1 s2 source true false edge
- = liftM (\(x, y)-> y ++ x) $
- (if parallel then pipeP else pipe)
- (transduce (splitterToMarker s1) source)
- (\source-> let get0 q = case Seq.viewl q
- of Seq.EmptyL -> get source >>= maybe (return []) get1
- (Left (x, False)) :< rest -> put false x
- >>= cond
- (get0 rest)
- (return
- $ concatMap (either ((:[]) . fst) (const []))
- $ Foldable.toList $ Seq.viewl q)
- (Left (x, True)) :< rest -> get2 Nothing Seq.empty q
- (Right b) :< rest -> get2 (Just b) Seq.empty rest
- get1 (Left (x, False)) = put false x
- >>= cond (get source >>= maybe (return []) get1)
- (return [x])
- get1 p@(Left (x, True)) = get2 Nothing Seq.empty (Seq.singleton p)
- get1 (Right b) = get2 (Just b) Seq.empty Seq.empty
- get2 mb q q' = case Seq.viewl q'
- of Seq.EmptyL -> get source
- >>= maybe (testEnd mb q) (get2 mb q . Seq.singleton)
- (Left (x, True)) :< rest -> get2 mb (q |> x) rest
- (Left (x, False)) :< rest -> get3 mb q q'
- Right{} :< rest -> get3 mb q q'
- get3 mb q q' = do ((q1, q2), n) <- pipe (get7 Seq.empty q') (test mb q)
- case n of Nothing -> putQueue q false
- >>= whenNull (get0 (q1 >< q2))
- Just 0 -> get0 (q1 >< q2)
- Just n -> get8 (Just mb) n (q1 >< q2)
- get7 q1 q2 sink = canPut sink
- >>= cond (case Seq.viewl q2
- of Seq.EmptyL -> get source
- >>= maybe (return (q1, q2))
- (\p-> either
- (put sink . fst)
- (const $ return True)
- p
- >> get7 (q1 |> p) q2 sink)
- p :< rest -> either (put sink . fst) (const $ return True) p
- >> get7 (q1 |> p) rest sink)
- (return (q1, q2))
- testEnd mb q = do ((), n) <- pipeD "testEnd" (const $ return ()) (test mb q)
- case n of Nothing -> putQueue q false
- _ -> return []
- test mb q source = liftM snd $
- pipeD "follower"
- (transduce (splitterToMarker s2) source)
- (\source-> let get4 (Left (_, False)) = return Nothing
- get4 p@(Left (_, True)) = putQueue q true
- >> get5 0 p
- get4 p@(Right b) = maybe
- (return True) (\b1-> put edge (b1, b)) mb
- >> putQueue q true
- >> get6 0
- get5 n (Left (x, True)) = put true x >> get6 (succ n)
- get5 n _ = return (Just n)
- get6 n = get source
- >>= maybe
- (return $ Just n)
- (get5 n)
- in get source >>= maybe (return Nothing) get4)
- get8 Nothing 0 q = get0 q
- get8 (Just mb) 0 q = get2 mb Seq.empty q
- get8 mmb n q = case Seq.viewl q of Left (x, False) :< rest -> get8 Nothing (pred n) rest
- Left (x, True) :< rest
- -> get8 (maybe (Just Nothing) Just mmb) (pred n) rest
- Right b :< rest -> get8 (Just (Just b)) n rest
- in get0 Seq.empty)
-
--- | Combinator '...' tracks the running balance of difference between the number of preceding starts of sections
--- considered /true/ according to its first argument and the ones according to its second argument. The combinator
--- passes to /true/ all input values for which the difference balance is positive. This combinator is typically used
--- with 'startOf' and 'endOf' in order to count entire input sections and ignore their lengths.
-(...) :: forall m x b1 b2. (ParallelizableMonad m, Typeable x, Typeable b1, Typeable b2)
- => Splitter m x b1 -> Splitter m x b2 -> Splitter m x b1
-s1 ... s2 = liftSplitter "..." (maxUsableThreads s1 + maxUsableThreads s2) $
- \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2
- s source true false edge
- = liftM (\(x, y)-> y ++ x) $
- (if parallel then pipeP else pipe)
- (transduce (splittersToPairMarker s1' s2') source)
- (\source-> let next n = get source >>= maybe (return []) (state n)
- pass n x = (if n > 0 then put true x else put false x)
- >>= cond (next n) (return [x])
- pass' n x = (if n >= 0 then put true x else put false x)
- >>= cond (next n) (return [x])
- state n (Left (x, True, False)) = pass (succ n) x
- state n (Left (x, False, True)) = pass' (pred n) x
- state n (Left (x, True, True)) = pass' n x
- state n (Left (x, False, False)) = pass n x
- state 0 (Right (Left b)) = put edge b >> next 1
- state n (Right (Left _)) = next (succ n)
- state n (Right (Right _)) = next (pred n)
- in next 0)
- in (configuration, s)
-
--- Helper functions
-
--- | Converts a 'Control.Concurrent.SCC.ComponentTypes.Splitter' into a
--- 'Control.Concurrent.SCC.ComponentTypes.Transducer'. Every input value @x@ that the argument splitter sends to its
--- /true/ sink is converted to @Left (x, True)@, every @y@ sent to the splitter's /false/ sink becomes @Left (y,
--- False)@, and any value @e@ the splitter puts in its /edge/ sink becomes @Right e@.
-splitterToMarker :: forall m x b. (ParallelizableMonad m, Typeable x, Typeable b)
- => Splitter m x b -> Transducer m x (Either (x, Bool) b)
-splitterToMarker s = liftTransducer "splitterToMarker" (maxUsableThreads s) $
- \threads-> let s' = usingThreads threads s
- t source sink = liftM (\(x, y, z, _)-> z ++ y ++ x) $
- splitToConsumers s' source
- (mark (\x-> Left (x, True)))
- (mark (\x-> Left (x, False)))
- (mark Right)
- where mark f source = canPut sink
- >>= cond
- (get source
- >>= maybe (return [])
- (\x-> put sink (f x)
- >>= cond (mark f source) (return [x])))
- (return [])
- in (ComponentConfiguration [AnyComponent s'] threads (cost s' + 1), t)
-
-
-splittersToPairMarker :: forall m x b1 b2. (ParallelizableMonad m, Typeable x, Typeable b1, Typeable b2)
- => Splitter m x b1 -> Splitter m x b2
- -> Transducer m x (Either (x, Bool, Bool) (Either b1 b2))
-splittersToPairMarker s1 s2
- = liftTransducer "splittersToPairMarker" (maxUsableThreads s1 + maxUsableThreads s2) $
- \threads-> let (configuration, s1', s2', parallelize) = optimalTwoParallelConfigurations threads s1 s2
- t source sink = liftM (\(((_, _), (x, _, _, _)), _)-> x) $
- pipeD "splittersToPairMarker synchronize"
- (\sync-> (if parallelize then pipeP else pipe)
- (\sink1-> pipe
- (tee source sink1)
- (\source2-> splitToConsumers s2' source2
- (flip (pourMap (\x-> Left ((x, True), False))) sync)
- (flip (pourMap (\x-> Left ((x, False), False))) sync)
- (flip (pourMap (Right . Right)) sync)))
- (\source1-> splitToConsumers s1' source1
- (flip (pourMap (\x-> Left ((x, True), True))) sync)
- (flip (pourMap (\x-> Left ((x, False), True))) sync)
- (flip (pourMap (Right. Left)) sync)))
- (synchronizeMarks Nothing sink)
- synchronizeMarks :: Maybe (Seq (Either (x, Bool) (Either b1 b2)), Bool)
- -> Sink c (Either (x, Bool, Bool) (Either b1 b2))
- -> Source c (Either ((x, Bool), Bool) (Either b1 b2))
- -> Pipe c m [x]
- synchronizeMarks state sink source = get source
- >>= maybe
- (assert (isNothing state) (return []))
- (handleMark state sink source)
- handleMark :: Maybe (Seq (Either (x, Bool) (Either b1 b2)), Bool)
- -> Sink c (Either (x, Bool, Bool) (Either b1 b2))
- -> Source c (Either ((x, Bool), Bool) (Either b1 b2))
- -> Either ((x, Bool), Bool) (Either b1 b2) -> Pipe c m [x]
- handleMark Nothing sink source (Right b) = put sink (Right b)
- >> synchronizeMarks Nothing sink source
- handleMark Nothing sink source (Left (p, first))
- = synchronizeMarks (Just (Seq.singleton (Left p), first)) sink source
- handleMark state@(Just (q, first)) sink source (Left (p, first')) | first == first'
- = synchronizeMarks (Just (q |> Left p, first)) sink source
- handleMark state@(Just (q, True)) sink source (Right b@Left{})
- = synchronizeMarks (Just (q |> Right b, True)) sink source
- handleMark state@(Just (q, False)) sink source (Right b@Right{})
- = synchronizeMarks (Just (q |> Right b, False)) sink source
- handleMark state sink source (Right b) = put sink (Right b) >> synchronizeMarks state sink source
- handleMark state@(Just (q, pos')) sink source mark@(Left ((x, t), pos))
- = case Seq.viewl q
- of Seq.EmptyL -> synchronizeMarks (Just (Seq.singleton (Left (x, t)), pos)) sink source
- Right b :< rest -> put sink (Right b)
- >>= cond
- (handleMark
- (if Seq.null rest then Nothing else Just (rest, pos'))
- sink
- source
- mark)
- (returnQueuedList q)
- Left (y, t') :< rest -> put sink (Left $ if pos then (y, t, t') else (y, t', t))
- >>= cond
- (synchronizeMarks
- (if Seq.null rest then Nothing else Just (rest, pos'))
- sink
- source)
- (returnQueuedList q)
- returnQueuedList q = return $ concatMap (either ((:[]) . fst) (const [])) $ Foldable.toList $ Seq.viewl q
- in (configuration, t)
-
-zipSplittersWith :: (ParallelizableMonad m, Typeable x, Typeable b1, Typeable b2, Typeable b)
- => (Bool -> Bool -> Bool)
- -> (forall c. Source c (Either b1 b2) -> Sink c b -> Pipe c m ())
- -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x b
-zipSplittersWith f boundaries s1 s2
- = liftSplitter "zip" (maxUsableThreads s1 + maxUsableThreads s2) $
- \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2
- s source true false edge = liftM (\((x, y), _)-> y ++ x) $
- pipe
- (\edge'->
- (if parallel then pipeP else pipe)
- (transduce (splittersToPairMarker s1' s2') source)
- (\source-> let split = get source
- >>= maybe
- (return [])
- (either
- test
- (\b-> put edge' b >> split))
- test (x, t1, t2) = put (if f t1 t2 then true else false) x
- >>= cond split (return [x])
- in split))
- (flip boundaries edge)
- in (configuration, s)
--- | Runs the second argument on every contiguous region of input source (typically produced by 'splitterToMarker')
--- whose all values either match @Left (_, True)@ or @Left (_, False)@.
-groupMarks :: forall c m x b r. (ParallelizableMonad m, Typeable x, Typeable b)
- => Source c (Either (x, Bool) b) -> (Maybe (Maybe b) -> Source c x -> Pipe c m r) -> Pipe c m ()
-groupMarks source getConsumer = start
- where start = getSuccess source (either startContent startRegion)
- startContent (x, False) = pipe (\sink-> pass False sink x) (getConsumer Nothing)
- >>= maybe (return ()) (either startContent startRegion) . fst
- startContent (x, True) = pipe (\sink-> pass True sink x) (getConsumer $ Just Nothing)
- >>= maybe (return ()) (either startContent startRegion) . fst
- startRegion b = pipe (next True) (getConsumer (Just $ Just b))
- >>= maybe (return ()) (either startContent startRegion) . fst
- pass t sink x = put sink x >> next t sink
- next t sink = get source >>= maybe (return Nothing) (continue t sink)
- continue t sink (Left (x, t')) | t == t' = pass t sink x
- continue t sink p = return (Just p)
+{-# LANGUAGE ScopedTypeVariables, Rank2Types, KindSignatures, EmptyDataDecls,
+ MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, FunctionalDependencies, TypeFamilies #-}
+
+-- | 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 (connect), JoinableComponentPair (join, sequence),
+ -- * Pseudo-logic splitter combinators
+ -- | Combinators '>&' and '>|' are only /pseudo/-logic. While the laws of double negation and De Morgan's laws hold,
+ -- '>&' and '>|' are in general not commutative, associative, nor idempotent. In the special case when all argument
+ -- splitters are stateless, such as those produced by 'Components.liftStatelessSplitter', these combinators do satisfy
+ -- all laws of Boolean algebra.
+ sNot, sAnd, sOr,
+ -- ** Zipping logic combinators
+ -- | The '&&' and '||' combinators run the argument splitters in parallel and combine their logical outputs using
+ -- the corresponding logical operation on each output pair, in a manner similar to 'Prelude.zipWith'. They fully
+ -- satisfy the laws of Boolean algebra.
+ 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/ 'Components.asis'
+ --
+ -- * /transducer/ ``unless`` /splitter/ = 'ifs' /splitter/ 'Components.asis' /transducer/
+ --
+ -- * 'select' /splitter/ = 'ifs' /splitter/ 'Components.asis' 'Components.suppress'
+ --
+ ifs, wherever, unless, select,
+ -- ** Recursive
+ while, nestedIn,
+ -- * Section-based combinators
+ -- | All combinators in this section use their 'Splitter' argument to determine the structure of the input. Every
+ -- contiguous portion of the input that gets passed to one or the other sink of the splitter is treated as one
+ -- section in the logical structure of the input stream. What is done with the section depends on the combinator,
+ -- but the sections, and therefore the logical structure of the input stream, are determined by the argument
+ -- splitter alone.
+ foreach, having, havingOnly, followedBy, even,
+ -- ** first and its variants
+ first, uptoFirst, prefix,
+ -- ** last and its variants
+ last, lastAndAfter, suffix,
+ -- ** positional splitters
+ startOf, endOf,
+ -- ** input ranges
+ between,
+ -- * parser support
+ parseRegions, parseNestedRegions,
+ -- * grouping helpers
+ groupMarks)
+where
+
+import Control.Concurrent.Coroutine
+import Control.Concurrent.SCC.Streams
+import Control.Concurrent.SCC.Types
+
+import Prelude hiding (even, last, sequence, (||), (&&))
+import qualified Prelude
+import Control.Exception (assert)
+import Control.Monad (liftM, when)
+import qualified Control.Monad as Monad
+import Control.Monad.Trans (lift)
+import Data.Maybe (isJust, isNothing, fromJust)
+import qualified Data.Foldable as Foldable
+import qualified Data.Sequence as Seq
+import Data.Sequence (Seq, (|>), (><), ViewL (EmptyL, (:<)))
+
+import Debug.Trace (trace)
+
+-- | Converts a 'Consumer' into a 'Transducer' with no output.
+consumeBy :: forall m x y r. (Monad m) => Consumer m x r -> Transducer m x y
+consumeBy c = Transducer $ \ source _sink -> consume c source >> return []
+
+-- | Class 'PipeableComponentPair' applies to any two components that can be combined into a third component with the
+-- following properties:
+--
+-- * The input of the result, if any, becomes the input of the first component.
+--
+-- * The output produced by the first child component is consumed by the second child component.
+--
+-- * The result output, if any, is the output of the second component.
+class PipeableComponentPair (m :: * -> *) w c1 c2 c3 | c1 c2 -> c3, c1 c3 -> c2, c2 c3 -> c2,
+ c1 -> m w, c2 -> m w, c3 -> m
+ where connect :: Bool -> c1 -> c2 -> c3
+
+instance forall m x. (ParallelizableMonad m) =>
+ PipeableComponentPair m x (Producer m x ()) (Consumer m x ()) (Performer m ())
+ where connect parallel p c = let performPipe :: Coroutine Naught m ((), ())
+ performPipe = pipePS parallel (produce p) (consume c)
+ in Performer (runCoroutine performPipe >> return ())
+
+instance (ParallelizableMonad m)
+ => PipeableComponentPair m y (Transducer m x y) (Consumer m y r) (Consumer m x r)
+ where connect parallel t c = isolateConsumer $ \source->
+ liftM snd $
+ pipePS parallel
+ (transduce t source)
+ (consume c)
+
+instance (ParallelizableMonad m) => PipeableComponentPair m x (Producer m x r) (Transducer m x y) (Producer m y r)
+ where connect parallel p t = isolateProducer $ \sink->
+ liftM fst $
+ pipePS parallel
+ (produce p)
+ (\source-> transduce t source sink)
+
+instance ParallelizableMonad m => PipeableComponentPair m y (Transducer m x y) (Transducer m y z) (Transducer m x z)
+ where connect parallel t1 t2 = isolateTransducer $ \source sink->
+ liftM fst $
+ pipePS parallel
+ (transduce t1 source)
+ (\source-> transduce t2 source sink)
+
+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.
+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
+
+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. ParallelizableMonad m =>
+ JoinableComponentPair (ConsumerType ()) (ConsumerType ()) (ConsumerType ()) m [x] ()
+ (Consumer m x ()) (Consumer m x ()) (Consumer m x ())
+ where join parallel c1 c2 = isolateConsumer $ \source->
+ pipePS parallel
+ (\sink1-> pipe (tee source sink1) (consume c2))
+ (consume c1)
+ >> return ()
+ sequence c1 c2 = isolateConsumer $ \source->
+ pipe
+ (\buffer-> pipe (tee source buffer) (consume c1))
+ getList
+ >>= \(_, list)-> pipe (putList list) (consume c2)
+ >> return ()
+
+instance forall m x y. (ParallelizableMonad 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-> pipePS parallel
+ (\sink1-> pipe
+ (\sink2-> tee source sink1 sink2)
+ (\src-> transduce t2 src buffer))
+ (\source-> transduce t1 source sink))
+ getList
+ >>= \(_, list)-> putList list sink
+ >> getList source
+ sequence t1 t2 = isolateTransducer $ \source sink->
+ pipe
+ (\buffer-> pipe
+ (tee source buffer)
+ (\source-> transduce t1 source sink))
+ getList
+ >>= \(_, list)-> pipe
+ (\sink-> putList list sink
+ >>= whenNull (pour source sink
+ >> return []))
+ (\source-> transduce t2 source sink)
+ >>= return . fst
+
+instance forall m r1 r2. ParallelizableMonad m =>
+ JoinableComponentPair (PerformerType r1) (PerformerType r2) (PerformerType r2) m () ()
+ (Performer m r1) (Performer m r2) (Performer m r2)
+ where join parallel p1 p2 = Performer $ if parallel
+ then bindM2 (const return) (perform p1) (perform p2)
+ else perform p1 >> perform p2
+ sequence p1 p2 = Performer $ perform p1 >> perform p2
+
+instance forall m x r1 r2. (ParallelizableMonad 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
+ sequence pe pr = Producer $ \sink-> lift (perform pe) >> produce pr sink
+
+instance forall m x r1 r2. (ParallelizableMonad 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)
+ sequence pr pe = Producer $ \sink-> produce pr sink >> lift (perform pe)
+
+instance forall m x r1 r2. (ParallelizableMonad 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
+ sequence p c = Consumer $ \source-> lift (perform p) >> consume c source
+
+instance forall m x r1 r2. (ParallelizableMonad 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)
+ sequence c p = Consumer $ \source-> consume c source >> lift (perform p)
+
+instance forall m x y r. (ParallelizableMonad 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
+ sequence p t = Transducer $ \ source sink -> lift (perform p) >> transduce t source sink
+
+instance forall m x y r. (ParallelizableMonad 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
+ sequence t p = Transducer $ \ source sink -> do result <- transduce t source sink
+ lift (perform p)
+ return result
+
+instance forall m x y. (ParallelizableMonad 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
+ sequence p t = Transducer $ \ source sink -> produce p sink >> transduce t source sink
+
+instance forall m x y. (ParallelizableMonad 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
+ sequence t p = Transducer $ \ source sink -> do result <- transduce t source sink
+ produce p sink
+ return result
+
+instance forall m x y. (ParallelizableMonad 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->
+ liftM (snd . fst) $
+ pipePS parallel
+ (\sink1-> pipe
+ (tee source sink1)
+ (\source-> transduce t source sink))
+ (consume c)
+ sequence c t = isolateTransducer $ \source sink->
+ pipe
+ (\buffer-> pipe
+ (tee source buffer)
+ (consume c))
+ getList
+ >>= \(_, list)-> pipe
+ (\sink-> putList list sink
+ >>= whenNull (pour source sink >> return []))
+ (\source-> transduce t source sink)
+ >>= return . fst
+
+instance forall m x y. ParallelizableMonad 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
+ sequence t c = isolateTransducer $ \source sink->
+ pipe
+ (\buffer-> pipe
+ (tee source buffer)
+ (\source-> transduce t source sink))
+ getList
+ >>= \(_, list)-> pipe
+ (\sink-> putList list sink
+ >>= whenNull (pour source sink
+ >> return []))
+ (consume c)
+ >>= return . fst
+
+instance forall m x y. (ParallelizableMonad 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 >> return []
+ sequence p c = Transducer $ \ source sink -> produce p sink >> consume c source >> return []
+
+instance forall m x y. (ParallelizableMonad 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
+ sequence c p = Transducer $ \ source sink -> consume c source >> produce p sink >> return []
+
+-- | 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) => Producer m x r -> Transducer m x x
+prepend prefix = Transducer $ \ source sink -> produce prefix sink >> pour source sink >> return []
+
+-- | 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) => 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 transducer that produces the same output, while
+-- | consuming its entire input and ignoring it.
+substitute :: forall m x y r. (Monad m) => Producer m y r -> Transducer m x y
+substitute feed = Transducer $ \ source sink -> consumeAndSuppress source >> produce feed sink >> return []
+
+-- | The 'snot' (streaming not) combinator simply reverses the outputs of the argument splitter. In other words, data
+-- that the argument splitter sends to its /true/ sink goes to the /false/ sink of the result, and vice versa.
+sNot :: forall m x b. Monad m => Splitter m x b -> Splitter m x b
+sNot splitter = isolateSplitter $ \ source true false edge -> suppressProducer (split splitter source false true)
+
+-- | 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.
+sAnd :: forall m x b1 b2. ParallelizableMonad m => Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)
+sAnd parallel s1 s2 =
+ isolateSplitter $ \ source true false edge ->
+ liftM (fst . fst . fst . fst) $
+ pipe
+ (\edges-> pipe
+ (\edge1-> pipe
+ (\edge2-> pipePS parallel
+ (\true-> split s1 source true false edge1)
+ (\source-> split s2 source true false edge2))
+ (flip (pourMap Right) edges))
+ (flip (pourMap Left) edges))
+ (flip intersectRegions edge)
+
+intersectRegions source sink = next Nothing Nothing
+ where next lastLeft lastRight = get source
+ >>= maybe
+ (return ())
+ (either
+ (flip pair lastRight . Just)
+ (pair lastLeft . Just))
+ pair l@(Just x) r@(Just y) = put sink (x, y)
+ >>= flip when (next Nothing Nothing)
+ pair l r = next l r
+
+-- | A '>|' combinator's input value can reach its /false/ sink only by going through both argument splitters' /false/
+-- sinks.
+sOr :: forall m x b1 b2. ParallelizableMonad 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 . fst . fst) $
+ pipe
+ (\edge1-> pipe
+ (\edge2-> pipePS parallel
+ (\false-> split s1 source true false edge1)
+ (\source-> split s2 source true false edge2))
+ (flip (pourMap Right) edge))
+ (flip (pourMap Left) edge)
+
+-- | Combinator '&&' is a pairwise logical conjunction of two splitters run in parallel on the same input.
+pAnd :: forall m x b1 b2. ParallelizableMonad m => Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)
+pAnd parallel s1 s2 = isolateSplitter $ \ source true false edge ->
+ liftM (\(x, y)-> y ++ x) $
+ pipePS parallel
+ (transduce (splittersToPairMarker parallel s1 s2) source)
+ (\source-> let split l r = get source
+ >>= maybe
+ (return [])
+ (test l r)
+ test l r (Left (x, t1, t2))
+ = (if t1 Prelude.&& t2 then put true x else put false x)
+ >>= cond
+ (split
+ (if t1 then l else Nothing)
+ (if t2 then r else Nothing))
+ (return [x])
+ test _ Nothing (Right (Left l)) = split (Just l) Nothing
+ test _ (Just r) (Right (Left l))
+ = put edge (l, r) >> split (Just l) (Just r)
+ test Nothing _ (Right (Right r)) = split Nothing (Just r)
+ test (Just l) _ (Right (Right r))
+ = put edge (l, r) >> split (Just l) (Just r)
+ in split Nothing Nothing)
+
+-- | Combinator '||' is a pairwise logical disjunction of two splitters run in parallel on the same input.
+pOr :: forall c m x b1 b2. ParallelizableMonad m =>
+ Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x (Either b1 b2)
+pOr = zipSplittersWith (Prelude.||) pour
+
+ifs :: forall c m x b. (ParallelizableMonad m, Branching c m x [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 [x]) ->
+ (forall a d'. AncestorFunctor d d' => OpenConsumer m a d' x [x]) ->
+ forall a. OpenConsumer m a d x [x]
+ if' parallel c1 c2 source = splitInputToConsumers parallel s source c1 c2
+
+wherever :: forall m x b. ParallelizableMonad m => Bool -> Transducer m x x -> Splitter m x b -> Transducer m x x
+wherever parallel t s = isolateTransducer $ \source sink->
+ splitInputToConsumers parallel s source
+ (\source-> transduce t source sink)
+ (\source-> pour source sink >> return [])
+
+unless :: forall m x b. ParallelizableMonad m => Bool -> Transducer m x x -> Splitter m x b -> Transducer m x x
+unless parallel t s = isolateTransducer $ \source sink->
+ splitInputToConsumers parallel s source
+ (\source-> pour source sink >> return [])
+ (\source-> transduce t source sink)
+
+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)
+
+-- | Converts a splitter into a parser.
+parseRegions :: forall m x b. Monad m => Splitter m x b -> Parser m x b
+parseRegions s = isolateTransducer $ \source sink->
+ liftM (\(x, y)-> y ++ x) $
+ pipe
+ (transduce (splitterToMarker s) source)
+ (\source-> wrapRegions source sink)
+ where wrapRegions source sink = let wrap0 mb = get source
+ >>= maybe
+ (maybe (return True) flush mb >> return [])
+ (wrap1 mb)
+ wrap1 Nothing (Left (x, _)) = put sink (Content x)
+ >>= cond (wrap0 Nothing) (return [x])
+ wrap1 (Just p) (Left (x, False)) = flush p
+ >> put sink (Content x)
+ >>= cond
+ (wrap0 Nothing)
+ (return [x])
+ wrap1 (Just (b, t)) (Left (x, True))
+ = (if t then return True else put sink (Markup (Start b)))
+ >> put sink (Content x)
+ >>= cond (wrap0 (Just (b, True))) (return [x])
+ wrap1 (Just p) (Right b') = flush p >> wrap0 (Just (b', False))
+ wrap1 Nothing (Right b) = wrap0 (Just (b, False))
+ flush (b, t) = put sink $ Markup $ (if t then End else Point) b
+ in wrap0 Nothing
+
+-- | 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->
+ liftM (\(w, (), (), _)-> w) $
+ splitToConsumers s source
+ (flip (pourMap Content) sink)
+ (flip (pourMap Content) sink)
+ (flip (pourMap Markup) sink)
+
+-- | 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. ParallelizableMonad m => [(Bool, (Transducer m x x, Splitter m x b))] -> Transducer m x x
+while ((parallel, (t, s)) : rest) =
+ isolateTransducer $ \source sink->
+ splitInputToConsumers parallel s source
+ (\source-> get source
+ >>= maybe
+ (return [])
+ (\x-> liftM (uncurry (++)) $
+ pipe
+ (\sink-> put sink x >>= cond (pour source sink >> return []) (return [x]))
+ (\source-> transduce while' source sink)))
+ (\source-> pour source sink >> return [])
+ where while' = connect 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. ParallelizableMonad m => [(Bool, (Splitter m x b, Splitter m x b))] -> Splitter m x b
+nestedIn ((parallel, (s1, s2)) : rest) =
+ isolateSplitter $ \ source true false edge ->
+ liftM fst $
+ pipePS parallel
+ (\false-> split s1 source true false edge)
+ (\source-> pipe
+ (\true-> pipe (split s2 source true false) consumeAndSuppress)
+ (\source-> get source
+ >>= maybe
+ (return ([], []))
+ (\x-> pipe
+ (\sink-> put sink x
+ >>= cond
+ (pour source sink >> return [])
+ (return [x]))
+ (\source-> split (nestedIn rest) 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. (ParallelizableMonad m, Branching c m x [x]) => Bool -> Splitter m x b -> c -> c -> c
+foreach parallel s c1 c2 = combineBranches foreach' parallel c1 c2
+ where foreach' :: forall d. Bool ->
+ (forall a d'. AncestorFunctor d d' => OpenConsumer m a d' x [x]) ->
+ (forall a d'. AncestorFunctor d d' => OpenConsumer m a d' x [x]) ->
+ forall a. OpenConsumer m a d x [x]
+ foreach' parallel c1 c2 source =
+ liftM fst $
+ pipePS parallel
+ (transduce (splitterToMarker s) (liftSource source :: Source m d x))
+ (\source-> groupMarks source (maybe c2 (const c1)))
+
+-- | The 'having' combinator combines two pure splitters into a pure splitter. One splitter is used to chunk the input
+-- into contiguous portions. Its /false/ sink is routed directly to the /false/ sink of the combined splitter. The
+-- second splitter is instantiated and run on each portion of the input that goes to first splitter's /true/ sink. If
+-- the second splitter sends any output at all to its /true/ sink, the whole input portion is passed on to the /true/
+-- sink of the combined splitter, otherwise it goes to its /false/ sink.
+having :: forall m x b1 b2. ParallelizableMonad 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 = liftM fst $
+ pipePS parallel
+ (transduce (splitterToMarker s1) source)
+ (flip groupMarks test)
+ where test Nothing chunk = pour chunk false >> return []
+ test (Just mb) chunk = pipe
+ (\sink1-> pipe (tee chunk sink1) getList)
+ (\chunk-> splitToConsumers s2 chunk
+ (liftM isJust . get)
+ consumeAndSuppress
+ (liftM isJust . get))
+ >>= \(((), prefix), (_, anyTrue, (), anyEdge))->
+ if anyTrue Prelude.|| anyEdge
+ then maybe (return True) (put edge) mb
+ >> putList prefix true
+ >>= whenNull (pour chunk true >> return [])
+ else putList prefix false
+ >>= whenNull (pour chunk false >> return [])
+
+-- | 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. ParallelizableMonad 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 = liftM fst $
+ pipePS parallel
+ (transduce (splitterToMarker s1) source)
+ (flip groupMarks test)
+ where test Nothing chunk = pour chunk false >> return []
+ test (Just mb) chunk = pipe
+ (\sink1-> pipe (tee chunk sink1) getList)
+ (\chunk-> splitToConsumers s2 chunk
+ consumeAndSuppress
+ (liftM isJust . get)
+ consumeAndSuppress)
+ >>= \(((), prefix), (_, (), anyFalse, ()))->
+ if anyFalse
+ then putList prefix false
+ >>= whenNull (pour chunk false >> return [])
+ else maybe (return True) (put edge) mb
+ >> putList prefix true
+ >>= whenNull (pour chunk true >> return [])
+
+-- | 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 = isolateSplitter $ \ source true false edge ->
+ liftM (\(x, y)-> y ++ x) $
+ pipe
+ (transduce (splitterToMarker splitter) source)
+ (\source-> let get1 (Left (x, False)) = pass false x get1
+ get1 (Left (x, True)) = pass true x get2
+ get1 (Right b) = put edge b
+ >> get source
+ >>= maybe (return []) get2
+ get2 b@Right{} = get3 b
+ get2 (Left (x, True)) = pass true x get2
+ get2 (Left (x, False)) = pass false x get3
+ get3 (Left (x, _)) = pass false x get3
+ get3 (Right _) = get source >>= maybe (return []) get3
+ pass sink x next = put sink x
+ >>= cond
+ (get source
+ >>= maybe (return []) next)
+ (return [x])
+ in get source >>= maybe (return []) get1)
+
+-- | The result of combinator 'uptoFirst' takes all input up to and including the first portion of the input which goes
+-- into the argument's /true/ sink and feeds it to the result splitter's /true/ sink. All the rest of the input goes
+-- into the /false/ sink. The only difference between 'first' and 'uptoFirst' combinators is in where they direct the
+-- /false/ portion of the input preceding the first /true/ part.
+uptoFirst :: forall m x b. Monad m => Splitter m x b -> Splitter m x b
+uptoFirst splitter = isolateSplitter $ \ source true false edge ->
+ liftM (\(x, y)-> y ++ x) $
+ pipe
+ (transduce (splitterToMarker splitter) source)
+ (\source-> let get1 q (Left (x, False)) = let q' = q |> x
+ in get source
+ >>= maybe
+ (putQueue q' false)
+ (get1 q')
+ get1 q p@(Left (_, True)) = putQueue q true
+ >>= whenNull (get2 p)
+ get1 q (Right b) = putQueue q true
+ >>= whenNull (put edge b
+ >> get source
+ >>= maybe (return []) get2)
+ get2 b@Right{} = get3 b
+ get2 (Left (x, True)) = pass true x get2
+ get2 (Left (x, False)) = pass false x get3
+ get3 (Left (x, _)) = pass false x get3
+ get3 (Right _) = get source >>= maybe (return []) get3
+ pass sink x next = put sink x
+ >>= cond
+ (get source
+ >>= maybe (return []) next)
+ (return [x])
+ in get source >>= maybe (return []) (get1 Seq.empty))
+
+-- | 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 => Splitter m x b -> Splitter m x b
+last splitter = isolateSplitter $ \ source true false edge ->
+ liftM (\(x, y)-> y ++ x) $
+ pipe
+ (transduce (splitterToMarker splitter) source)
+ (\source-> let get1 (Left (x, False)) = put false x
+ >>= cond (get source
+ >>= maybe (return []) get1)
+ (return [x])
+ get1 p@(Left (x, True)) = get2 Nothing Seq.empty p
+ get1 (Right b) = pass (get2 (Just b) Seq.empty)
+ get2 mb q (Left (x, True)) = let q' = q |> x
+ in get source
+ >>= maybe
+ (flush mb q')
+ (get2 mb q')
+ get2 mb q p = get3 mb q Seq.empty p
+ get3 mb qt qf (Left (x, False)) =
+ let qf' = qf |> x
+ in get source
+ >>= maybe
+ (flush mb qt >> putQueue qf' false)
+ (get3 mb qt qf')
+ get3 mb qt qf p = do rest1 <- putQueue qt false
+ rest2 <- putQueue qf false
+ if null rest1 Prelude.&& null rest2
+ then get1 p
+ else return (rest1 ++ rest2)
+ flush mb q = maybe (return True) (put edge) mb
+ >> putQueue q true
+ pass succeed = get source >>= maybe (return []) succeed
+ in pass get1)
+
+-- | 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 = isolateSplitter $ \ source true false edge ->
+ liftM (\(x, y)-> y ++ x) $
+ pipe
+ (transduce (splitterToMarker splitter) source)
+ (\source-> let get1 (Left (x, False)) = put false x
+ >>= cond
+ (pass get1)
+ (return [x])
+ get1 p@(Left (x, True)) = get2 Nothing Seq.empty p
+ get1 (Right b) = pass (get2 (Just b) Seq.empty)
+ get2 mb q (Left (x, True)) = let q' = q |> x
+ in get source
+ >>= maybe
+ (flush mb q')
+ (get2 mb q')
+ get2 mb q p = get3 mb q p
+ get3 mb q (Left (x, False)) = let q' = q |> x
+ in get source
+ >>= maybe
+ (flush mb q')
+ (get3 mb q')
+ get3 _ q p@(Left (x, True)) = putQueue q false
+ >>= whenNull (get1 p)
+ get3 _ q b'@Right{} = putQueue q false
+ >>= whenNull (get1 b')
+ flush mb q = maybe (return True) (put edge) mb
+ >> putQueue q true
+ pass succeed = get source >>= maybe (return []) succeed
+ in pass get1)
+
+-- | 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 = isolateSplitter $ \ source true false edge ->
+ liftM (\(x, y)-> y ++ x) $
+ pipe
+ (transduce (splitterToMarker splitter) source)
+ (\source-> let get0 p@Left{} = get1 p
+ get0 (Right b) = put edge b
+ >> get source
+ >>= maybe (return []) get1
+ get1 (Left (x, False)) = pass false x get2
+ get1 (Left (x, True)) = pass true x get1
+ get1 (Right b) = get source >>= maybe (return []) get2
+ get2 (Left (x, _)) = pass false x get2
+ get2 Right{} = get source >>= maybe (return []) get2
+ pass sink x next = put sink x
+ >>= cond
+ (get source
+ >>= maybe (return []) next)
+ (return [x])
+ in get source >>= maybe (return []) get0)
+
+-- | 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 = isolateSplitter $ \ source true false edge ->
+ liftM (\(x, y)-> y ++ x) $
+ pipe
+ (transduce (splitterToMarker splitter) source)
+ (\source-> let get1 (Left (x, False)) = put false x
+ >>= cond (p get1) (return [x])
+ get1 (Left (x, True)) = get2 Nothing (Seq.singleton x)
+ get1 (Right b) = get2 (Just b) Seq.empty
+ get2 mb q = get source
+ >>= maybe
+ (maybe (return True) (put edge) mb
+ >> putQueue q true)
+ (get3 mb q)
+ get3 mb q (Left (x, True)) = get2 mb (q |> x)
+ get3 mb q p@(Left (x, False)) =
+ putQueue q false
+ >>= \rest-> if null rest
+ then get1 p
+ else return (rest ++ [x])
+ get3 mb q (Right b) = putQueue q false
+ >>= whenNull (get2 (Just b) Seq.empty)
+ p succeed = get source >>= maybe (return []) succeed
+ in p get1)
+
+-- | The 'even' combinator takes every input section that its argument /splitter/ deems /true/, and feeds even ones into
+-- its /true/ sink. The odd sections and parts of input that are /false/ according to its argument splitter are fed to
+-- 'even' splitter's /false/ sink.
+even :: forall m x b. Monad m => Splitter m x b -> Splitter m x b
+even splitter = isolateSplitter $ \ source true false edge ->
+ liftM (\(x, y)-> y ++ x) $
+ pipe
+ (transduce (splitterToMarker splitter) source)
+ (\source-> let get1 (Left (x, False)) = put false x
+ >>= cond (next get1) (return [x])
+ get1 p@(Left (x, True)) = get2 p
+ get1 (Right b) = next get2
+ get2 (Left (x, True)) = put false x
+ >>= cond (next get2) (return [x])
+ get2 p@(Left (x, False)) = get3 p
+ get2 (Right b) = put edge b >> next get4
+ get3 (Left (x, False)) = put false x
+ >>= cond (next get3) (return [x])
+ get3 p@(Left (x, True)) = get4 p
+ get3 (Right b) = put edge b >> next get4
+ get4 (Left (x, True)) = put true x
+ >>= cond (next get4) (return [x])
+ get4 p@(Left (x, False)) = get1 p
+ get4 (Right b) = next get2
+ next g = get source >>= maybe (return []) g
+ in next get1)
+
+-- | Splitter 'startOf' issues an empty /true/ section at the beginning of every section considered /true/ by its
+-- argument splitter, otherwise the entire input goes into its /false/ sink.
+startOf :: forall m x b. Monad m => Splitter m x b -> Splitter m x (Maybe b)
+startOf splitter = isolateSplitter $ \ source true false edge ->
+ liftM (\(x, y)-> y ++ x) $
+ pipe
+ (transduce (splitterToMarker splitter) source)
+ (\source-> let get1 (Left (x, False)) = put false x
+ >>= cond
+ (next get1)
+ (return [x])
+ get1 p@(Left (x, True)) = put edge Nothing >> get2 p
+ get1 (Right b) = put edge (Just b)
+ >> next get2
+ get2 (Left (x, True)) = put false x
+ >>= cond
+ (next get2)
+ (return [x])
+ get2 p = get1 p
+ next g = get source >>= maybe (return []) g
+ in next get1)
+
+-- | 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 = isolateSplitter $ \ source true false edge ->
+ liftM (\(x, y)-> y ++ x) $
+ pipe
+ (transduce (splitterToMarker splitter) source)
+ (\source-> let get1 (Left (x, False)) = put false x
+ >>= cond
+ (next get1)
+ (return [x])
+ get1 p@(Left (x, True)) = get2 Nothing p
+ get1 (Right b) = next (get2 $ Just b)
+ get2 mb (Left (x, True))
+ = put false x
+ >>= cond (next $ get2 mb) (return [x])
+ get2 mb p@(Left (x, False)) = put edge mb >> get1 p
+ get2 mb (Right b) = put edge mb >> next (get2 $ Just b)
+ next g = get source >>= maybe (return []) g
+ in next get1)
+
+-- | Combinator 'followedBy' treats its argument 'Splitter's as patterns components and returns a 'Splitter' that
+-- matches their concatenation. A section of input is considered /true/ by the result iff its prefix is considered
+-- /true/ by argument /s1/ and the rest of the section is considered /true/ by /s2/. The splitter /s2/ is started anew
+-- after every section split to /true/ sink by /s1/.
+followedBy :: forall m x b1 b2. ParallelizableMonad m =>
+ Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)
+followedBy parallel s1 s2 =
+ isolateSplitter $ \ source true false edge ->
+ liftM (\(x, y)-> y ++ x) $
+ pipePS parallel
+ (transduce (splitterToMarker s1) source)
+ (\source-> let get0 q = case Seq.viewl q
+ of Seq.EmptyL -> get source >>= maybe (return []) get1
+ (Left (x, False)) :< rest -> put false x
+ >>= cond
+ (get0 rest)
+ (return
+ $ concatMap (either ((:[]) . fst) (const []))
+ $ Foldable.toList $ Seq.viewl q)
+ (Left (x, True)) :< rest -> get2 Nothing Seq.empty q
+ (Right b) :< rest -> get2 (Just b) Seq.empty rest
+ get1 (Left (x, False)) = put false x
+ >>= cond (get source >>= maybe (return []) get1)
+ (return [x])
+ get1 p@(Left (x, True)) = get2 Nothing Seq.empty (Seq.singleton p)
+ get1 (Right b) = get2 (Just b) Seq.empty Seq.empty
+ get2 mb q q' = case Seq.viewl q'
+ of Seq.EmptyL -> get source
+ >>= maybe (testEnd mb q) (get2 mb q . Seq.singleton)
+ (Left (x, True)) :< rest -> get2 mb (q |> x) rest
+ (Left (x, False)) :< rest -> get3 mb q q'
+ Right{} :< rest -> get3 mb q q'
+ get3 mb q q' = do ((q1, q2), n) <- pipe (get7 Seq.empty q') (test mb q)
+ case n of Nothing -> putQueue q false
+ >>= whenNull (get0 (q1 >< q2))
+ Just 0 -> get0 (q1 >< q2)
+ Just n -> get8 (Just mb) n (q1 >< q2)
+ get7 q1 q2 sink = canPut sink
+ >>= cond (case Seq.viewl q2
+ of Seq.EmptyL -> get source
+ >>= maybe (return (q1, q2))
+ (\p-> either
+ (put sink . fst)
+ (const $ return True)
+ p
+ >> get7 (q1 |> p) q2 sink)
+ p :< rest -> either
+ (put sink . fst)
+ (const $ return True) p
+ >> get7 (q1 |> p) rest sink)
+ (return (q1, q2))
+ testEnd mb q = do ((), n) <- pipe (const $ return ()) (test mb q)
+ case n of Nothing -> putQueue q false
+ _ -> 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 True)
+ (\b1-> put edge (b1, b)) mb
+ >> putQueue q true
+ >> get6 0
+ get5 n (Left (x, True)) = put true x
+ >> get6 (succ n)
+ get5 n _ = return (Just n)
+ get6 n = get source
+ >>= maybe
+ (return $ Just n)
+ (get5 n)
+ in get source >>= maybe (return Nothing) get4)
+ get8 Nothing 0 q = get0 q
+ get8 (Just mb) 0 q = get2 mb Seq.empty q
+ get8 mmb n q = case Seq.viewl q of Left (x, False) :< rest -> get8 Nothing (pred n) rest
+ Left (x, True) :< rest
+ -> get8 (maybe (Just Nothing) Just mmb) (pred n) rest
+ Right b :< rest -> get8 (Just (Just b)) n rest
+ in get0 Seq.empty)
+
+-- | Combinator '...' tracks the running balance of difference between the number of preceding starts of sections
+-- considered /true/ according to its first argument and the ones according to its second argument. The combinator
+-- passes to /true/ all input values for which the difference balance is positive. This combinator is typically used
+-- with 'startOf' and 'endOf' in order to count entire input sections and ignore their lengths.
+between :: forall m x b1 b2. ParallelizableMonad m => Bool -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x b1
+between parallel s1 s2 = isolateSplitter $ \ source true false edge ->
+ liftM (\(x, y)-> y ++ x) $
+ pipePS parallel
+ (transduce (splittersToPairMarker parallel s1 s2) source)
+ (\source-> let next n = get source >>= maybe (return []) (state n)
+ pass n x = (if n > 0 then put true x else put false x)
+ >>= cond (next n) (return [x])
+ pass' n x = (if n >= 0 then put true x else put false x)
+ >>= cond (next n) (return [x])
+ state n (Left (x, True, False)) = pass (succ n) x
+ state n (Left (x, False, True)) = pass' (pred n) x
+ state n (Left (x, True, True)) = pass' n x
+ state n (Left (x, False, False)) = pass n x
+ state 0 (Right (Left b)) = put edge b >> next 1
+ state n (Right (Left _)) = next (succ n)
+ state n (Right (Right _)) = next (pred n)
+ in next 0)
+
+-- Helper functions
+
+splitterToMarker :: forall m x b. Monad m => Splitter m x b -> Transducer m x (Either (x, Bool) b)
+splitterToMarker s = isolateTransducer $ \source sink->
+ let mark f source = canPut sink
+ >>= cond
+ (get source
+ >>= maybe (return [])
+ (\x-> put sink (f x)
+ >>= cond
+ (mark f source)
+ (return [x])))
+ (return [])
+ in liftM (\(x, y, z, _)-> z ++ y ++ x) $
+ splitToConsumers s source
+ (mark (\x-> Left (x, True)))
+ (mark (\x-> Left (x, False)))
+ (mark Right)
+
+splittersToPairMarker :: forall m x b1 b2. (ParallelizableMonad m) => Bool -> 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 =
+ liftM (\(((_, _), (x, _, _, _)), _)-> x) $
+ pipe
+ (\sync-> pipePS parallel
+ (\sink1-> pipe
+ (tee source sink1)
+ (\source2-> splitToConsumers s2 source2
+ (flip (pourMap (\x-> Left ((x, True), False))) sync)
+ (flip (pourMap (\x-> Left ((x, False), False))) sync)
+ (flip (pourMap (Right . Right)) sync)))
+ (\source1-> splitToConsumers s1 source1
+ (flip (pourMap (\x-> Left ((x, True), True))) sync)
+ (flip (pourMap (\x-> Left ((x, False), True))) sync)
+ (flip (pourMap (Right. Left)) sync)))
+ (synchronizeMarks Nothing sink)
+ -- synchronizeMarks :: Maybe (Seq (Either (x, Bool) (Either b1 b2)), Bool)
+ -- -> Sink m c (Either (x, Bool, Bool) (Either b1 b2))
+ -- -> Source m c (Either ((x, Bool), Bool) (Either b1 b2))
+ -- -> Coroutine c m [x]
+ synchronizeMarks state sink source = get source
+ >>= maybe
+ (assert (isNothing state) (return []))
+ (handleMark state sink source)
+ -- handleMark :: Maybe (Seq (Either (x, Bool) (Either b1 b2)), Bool)
+ -- -> Sink m c (Either (x, Bool, Bool) (Either b1 b2))
+ -- -> Source m c (Either ((x, Bool), Bool) (Either b1 b2))
+ -- -> Either ((x, Bool), Bool) (Either b1 b2) -> Coroutine c m [x]
+ handleMark Nothing sink source (Right b) = put sink (Right b)
+ >> synchronizeMarks Nothing sink source
+ handleMark Nothing sink source (Left (p, first))
+ = synchronizeMarks (Just (Seq.singleton (Left p), first)) sink source
+ handleMark state@(Just (q, first)) sink source (Left (p, first')) | first == first'
+ = synchronizeMarks (Just (q |> Left p, first)) sink source
+ handleMark state@(Just (q, True)) sink source (Right b@Left{})
+ = synchronizeMarks (Just (q |> Right b, True)) sink source
+ handleMark state@(Just (q, False)) sink source (Right b@Right{})
+ = synchronizeMarks (Just (q |> Right b, False)) sink source
+ handleMark state sink source (Right b) = put sink (Right b) >> synchronizeMarks state sink source
+ handleMark state@(Just (q, pos')) sink source mark@(Left ((x, t), pos))
+ = case Seq.viewl q
+ of Seq.EmptyL -> synchronizeMarks (Just (Seq.singleton (Left (x, t)), pos)) sink source
+ Right b :< rest -> put sink (Right b)
+ >>= cond
+ (handleMark
+ (if Seq.null rest then Nothing else Just (rest, pos'))
+ sink
+ source
+ mark)
+ (returnQueuedList q)
+ Left (y, t') :< rest -> put sink (Left $ if pos then (y, t, t') else (y, t', t))
+ >>= cond
+ (synchronizeMarks
+ (if Seq.null rest then Nothing else Just (rest, pos'))
+ sink
+ source)
+ (returnQueuedList q)
+ returnQueuedList q = return $ concatMap (either ((:[]) . fst) (const [])) $ Foldable.toList $ Seq.viewl q
+ in isolateTransducer t
+
+zipSplittersWith :: forall m x b1 b2 b. ParallelizableMonad 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
+ = isolateSplitter $ \ source true false edge ->
+ liftM (\((x, y), _)-> y ++ x) $
+ pipe
+ (\edge->
+ pipePS parallel
+ (transduce (splittersToPairMarker parallel s1 s2) source)
+ (\source-> let split = get source
+ >>= maybe
+ (return [])
+ (either
+ test
+ (\b-> put edge b >> split))
+ test (x, t1, t2) = (if f t1 t2 then put true x else put false x)
+ >>= cond split (return [x])
+ in split))
+ (flip boundaries edge)
+
+-- | Runs the second argument on every contiguous region of input source (typically produced by 'splitterToMarker')
+-- whose all values either match @Left (_, True)@ or @Left (_, False)@.
+groupMarks :: (Monad m, AncestorFunctor a d, AncestorFunctor a (SinkFunctor d x)) =>
+ Source m a (Either (x, Bool) b) ->
+ (Maybe (Maybe b) -> Source m (SourceFunctor d x) x -> Coroutine (SourceFunctor d x) m r) ->
+ Coroutine d m ()
+groupMarks source getConsumer = start
+ where start = getSuccess source (either startContent startRegion)
+ startContent (x, False) = pipe (\sink-> pass False sink x) (getConsumer Nothing)
+ >>= maybe (return ()) (either startContent startRegion) . fst
+ startContent (x, True) = pipe (\sink-> pass True sink x) (getConsumer $ Just Nothing)
+ >>= maybe (return ()) (either startContent startRegion) . fst
+ startRegion b = pipe (next True) (getConsumer (Just $ Just b))
+ >>= maybe (return ()) (either startContent startRegion) . fst
+ pass t sink x = put sink x >> next t sink
+ next t sink = get source >>= maybe (return Nothing) (continue t sink)
+ continue t sink (Left (x, t')) | t == t' = pass t sink x
+ continue t sink p = return (Just p)
+
+-- | '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 (SinkFunctor a x) x -> Coroutine (SinkFunctor a x) m r) -> Coroutine a m r
+suppressProducer producer = liftM fst $ pipe producer consumeAndSuppress
+
diff --git a/Control/Concurrent/SCC/ComponentTypes.hs b/Control/Concurrent/SCC/ComponentTypes.hs
deleted file mode 100644
--- a/Control/Concurrent/SCC/ComponentTypes.hs
+++ /dev/null
@@ -1,491 +0,0 @@
-{-
- Copyright 2008-2009 Mario Blazevic
-
- This file is part of the Streaming Component Combinators (SCC) project.
-
- The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public
- License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later
- version.
-
- SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty
- of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License along with SCC. If not, see
- .
--}
-
-{-# LANGUAGE ScopedTypeVariables, KindSignatures, Rank2Types, ImpredicativeTypes, ExistentialQuantification, DeriveDataTypeable,
- MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies #-}
-
-module Control.Concurrent.SCC.ComponentTypes
- (-- * Classes
- Component (..), BranchComponent (combineBranches), LiftableComponent (liftComponent), Container (..),
- -- * Types
- AnyComponent (AnyComponent), Performer (..), Consumer (..), Producer(..), Splitter(..), Transducer(..),
- ComponentConfiguration(..), Boundary(..), Markup(..), Parser,
- -- * Lifting functions
- liftPerformer, liftConsumer, liftAtomicConsumer, liftProducer, liftAtomicProducer,
- liftTransducer, liftAtomicTransducer, lift121Transducer, liftStatelessTransducer, liftFoldTransducer, liftStatefulTransducer,
- liftSplitter, liftAtomicSplitter, liftStatelessSplitter, liftStatefulSplitter,
- -- * Utility functions
- showComponentTree, optimalTwoParallelConfigurations, optimalTwoSequentialConfigurations, optimalThreeParallelConfigurations,
- splitToConsumers, splitInputToConsumers
- )
-where
-
-import Control.Concurrent.SCC.Foundation
-
-import Control.Monad (liftM, when)
-import Data.List (minimumBy)
-import Data.Maybe
-import Data.Typeable (Typeable, cast)
-
--- | 'AnyComponent' is an existential type wrapper around a 'Component'.
-data AnyComponent = forall a. Component a => AnyComponent a
-
--- | The types of 'Component' class carry metadata and can be configured to use a specific number of threads.
-class Component c where
- name :: c -> String
- -- | Returns the list of all children components.
- subComponents :: c -> [AnyComponent]
- -- | Returns the maximum number of threads that can be used by the component.
- maxUsableThreads :: c -> Int
- -- | Configures the component to use the specified number of threads. This function affects 'usedThreads', 'cost',
- -- and 'subComponents' methods of the result, while 'name' and 'maxUsableThreads' remain the same.
- usingThreads :: Int -> c -> c
- -- | The number of threads that the component is configured to use. By default the number is usually 1.
- usedThreads :: c -> Int
- -- | The cost of using the component as configured.
- cost :: c -> Int
- cost c = 1 + sum (map cost (subComponents c))
-
-instance Component AnyComponent where
- name (AnyComponent c) = name c
- subComponents (AnyComponent c) = subComponents c
- maxUsableThreads (AnyComponent c) = maxUsableThreads c
- usingThreads n (AnyComponent c) = AnyComponent (usingThreads n c)
- usedThreads (AnyComponent c) = usedThreads c
- cost (AnyComponent c) = cost c
-
--- | Show details of the given component's configuration.
-showComponentTree :: forall c. Component c => c -> String
-showComponentTree c = showIndentedComponent 1 c
-
-showIndentedComponent :: forall c. Component c => Int -> c -> String
-showIndentedComponent depth c = showRightAligned 4 (cost c) ++ showRightAligned 3 (usedThreads c) ++ replicate depth ' '
- ++ name c ++ "\n"
- ++ concatMap (showIndentedComponent (succ depth)) (subComponents c)
-
-showRightAligned :: Show x => Int -> x -> String
-showRightAligned width x = let str = show x
- in replicate (width - length str) ' ' ++ str
-
-data ComponentConfiguration = ComponentConfiguration {componentChildren :: [AnyComponent],
- componentThreads :: Int,
- componentCost :: Int}
-
--- | A component that performs a computation with no inputs nor outputs is a 'Performer'.
-data Performer m r = Performer {performerName :: String,
- performerMaxThreads :: Int,
- performerConfiguration :: ComponentConfiguration,
- performerUsingThreads :: Int -> (ComponentConfiguration, forall c. Pipe c m r),
- perform :: forall c. Pipe c m r}
-
--- | A component that consumes values from a 'Source' is called 'Consumer'.
--- data Consumer m x r = Consumer {consumerData :: ComponentData (forall c. Source c x -> Pipe c m r),
--- consume :: forall c. Source c x -> Pipe c m r}
-data Consumer m x r = Consumer {consumerName :: String,
- consumerMaxThreads :: Int,
- consumerConfiguration :: ComponentConfiguration,
- consumerUsingThreads :: Int -> (ComponentConfiguration, forall c. Source c x -> Pipe c m r),
- consume :: forall c. Source c x -> Pipe c m r}
-
--- | A component that produces values and puts them into a 'Sink' is called 'Producer'.
-data Producer m x r = Producer {producerName :: String,
- producerMaxThreads :: Int,
- producerConfiguration :: ComponentConfiguration,
- producerUsingThreads :: Int -> (ComponentConfiguration, forall c. Sink c x -> Pipe c m r),
- produce :: forall c. Sink c x -> Pipe c m r}
-
--- | The 'Transducer' type represents computations that transform data and return no result.
--- A transducer must continue consuming the given source and feeding the sink while there is data.
-data Transducer m x y = Transducer {transducerName :: String,
- transducerMaxThreads :: Int,
- transducerConfiguration :: ComponentConfiguration,
- transducerUsingThreads :: Int -> (ComponentConfiguration,
- forall c. Source c x -> Sink c y -> Pipe c m [x]),
- transduce :: forall c. Source c x -> Sink c y -> Pipe c m [x]}
-
--- | The 'Splitter' type represents computations that distribute data acording to some criteria. A splitter should
--- distribute only the original input data, and feed it into the sinks in the same order it has been read from the
--- source. If the two 'Sink c x' arguments of a splitter are the same, the splitter must act as an identity transform.
-data Splitter m x b = Splitter {splitterName :: String,
- splitterMaxThreads :: Int,
- splitterConfiguration :: ComponentConfiguration,
- splitterUsingThreads :: Int -> (ComponentConfiguration,
- forall c. Source c x -> Sink c x -> Sink c x -> Sink c b
- -> Pipe c m [x]),
- split :: forall c. Source c x -> Sink c x -> Sink c x -> Sink c b -> Pipe c m [x]}
-
--- | A 'Markup' value is produced to mark either a 'Start' and 'End' of a region of data, or an arbitrary
--- 'Point' in data. A 'Point' is semantically equivalent to a 'Start' immediately followed by 'End'. The 'Content'
--- constructor wraps the actual data.
-data Boundary y = Start y | End y | Point y deriving (Eq, Show, Typeable)
-data Markup x y = Content x | Markup (Boundary y) deriving (Eq, Typeable)
-type Parser m x b = Transducer m x (Markup x b)
-
-instance Functor Boundary where
- fmap f (Start b) = Start (f b)
- fmap f (End b) = End (f b)
- fmap f (Point b) = Point (f b)
-
-instance (Show y) => Show (Markup Char y) where
- showsPrec p (Content x) s = x : s
- showsPrec p (Markup b) s = '[' : shows b (']' : s)
-
--- | The 'Container' class applies to two types where a first type value may contain values of the second type.
-class Container x y where
- -- | 'unwrap' returns a pair of a 'Splitter' that determines which containers are non-empty, and a 'Transducer' that
- -- unwraps the contained values.
- unwrap :: ParallelizableMonad m => (Splitter m x (), Transducer m x y)
- -- | 'rewrap' returns a 'Transducer' that puts the unwrapped values into containers again.
- rewrap :: ParallelizableMonad m => Transducer m y x
-
-instance (Typeable x, Typeable y) => Container (Markup x y) x where
- unwrap = (liftStatelessSplitter "isContent" isContent, liftStatelessTransducer "unwrapContent" unwrapContent)
- where isContent (Content x) = True
- isContent _ = False
- unwrapContent (Content x) = [x]
- unwrapContent _ = []
- rewrap = lift121Transducer "wrapContent" Content
-
-class LiftableComponent cx cy x y | cx -> x, cy -> y, cx y -> cy, cy x -> cx where
- liftComponent :: cy -> cx
-
-instance forall m x y. (Container x y, ParallelizableMonad m, Typeable x, Typeable y)
- => LiftableComponent (Transducer m x x) (Transducer m y y) x y where
- liftComponent t = liftTransducer "liftComponent" (maxUsableThreads t + maxUsableThreads (rewrap :: Transducer m y x)) $
- \threads-> let (configuration, t', w', parallel) = optimalTwoParallelConfigurations threads t wrapper
- (wrapper :: Splitter m x (), unwrap' :: Transducer m x y) = unwrap
- tx source sink = liftM (const []) $
- pipe
- (\true-> pipe
- (split w' source true sink)
- consumeAndSuppress)
- (\wrapped-> pipe
- (transduce unwrap' wrapped)
- (\unwrapped-> pipe
- (transduce t' unwrapped)
- (\out-> transduce rewrap out sink)))
- in (configuration, tx)
-
-instance forall m x y. (Container x y, ParallelizableMonad m, Typeable x, Typeable y)
- => LiftableComponent (Splitter m x ()) (Splitter m y ()) x y where
- liftComponent splitter = liftSplitter "liftComponent" (maxUsableThreads splitter + maxUsableThreads (rewrap :: Transducer m y x)) $
- \threads-> let (configuration, s', w', parallel) = optimalTwoParallelConfigurations threads splitter wrapper
- (wrapper :: Splitter m x (), unwrap' :: Transducer m x y) = unwrap
- split' :: forall c. Source c x -> Sink c x -> Sink c x -> Sink c () -> Pipe c m [x]
- split' source true false edge
- = liftM (fst . fst . fst) $
- pipe
- (\rewrappedTrue-> pipe
- (\rewrappedFalse-> split'' source rewrappedTrue rewrappedFalse false edge)
- (flip (transduce rewrap) false))
- (flip (transduce rewrap) true)
- split'' :: forall c. Source c x -> Sink c y -> Sink c y -> Sink c x -> Sink c () -> Pipe c m ([x], ([x], [y]))
- split'' source true1 false1 false2 edge = pipe
- (\sink-> split''' source sink false2 edge)
- (\source-> pipe
- (transduce unwrap' source)
- (\source-> split s' source true1 false1 edge))
- split''' :: forall c. Source c x -> Sink c x -> Sink c x -> Sink c ()
- -> Pipe c m [x]
- split''' source true false edge = split w' source true false edge
- in (configuration, split')
-
-instance Component (Performer m r) where
- name = performerName
- subComponents = componentChildren . performerConfiguration
- maxUsableThreads = performerMaxThreads
- usedThreads = componentThreads . performerConfiguration
- usingThreads threads performer = let (configuration', perform' :: forall c. Pipe c m r) = performerUsingThreads performer threads
- in performer{performerConfiguration= configuration', perform= perform'}
- cost = componentCost . performerConfiguration
-
-instance Component (Consumer m x r) where
- name = consumerName
- subComponents = componentChildren . consumerConfiguration
- maxUsableThreads = consumerMaxThreads
- usedThreads = componentThreads . consumerConfiguration
- usingThreads threads consumer = let (configuration',
- consume' :: forall c. Source c x -> Pipe c m r) = consumerUsingThreads consumer threads
- in consumer{consumerConfiguration= configuration', consume= consume'}
- cost = componentCost . consumerConfiguration
-
-instance Component (Producer m x r) where
- name = producerName
- subComponents = componentChildren . producerConfiguration
- maxUsableThreads = producerMaxThreads
- usedThreads = componentThreads . producerConfiguration
- usingThreads threads producer = let (configuration',
- produce' :: forall c. Sink c x -> Pipe c m r) = producerUsingThreads producer threads
- in producer{producerConfiguration= configuration', produce= produce'}
- cost = componentCost . producerConfiguration
-
-instance Component (Transducer m x y) where
- name = transducerName
- subComponents = componentChildren . transducerConfiguration
- maxUsableThreads = transducerMaxThreads
- usedThreads = componentThreads . transducerConfiguration
- usingThreads threads transducer = let (configuration', transduce' :: forall c. Source c x -> Sink c y -> Pipe c m [x])
- = transducerUsingThreads transducer threads
- in transducer{transducerConfiguration= configuration', transduce= transduce'}
- cost = componentCost . transducerConfiguration
-
-instance Component (Splitter m x b) where
- name = splitterName
- subComponents = componentChildren . splitterConfiguration
- maxUsableThreads = splitterMaxThreads
- usedThreads = componentThreads . splitterConfiguration
- usingThreads threads splitter = let (configuration',
- split' :: forall c. Source c x -> Sink c x -> Sink c x -> Sink c b -> Pipe c m [x])
- = splitterUsingThreads splitter threads
- in splitter{splitterConfiguration= configuration',
- split= split'}
- cost = componentCost . splitterConfiguration
-
-
--- | 'BranchComponent' is a type class representing all components that can act as consumers, namely 'Consumer',
--- 'Transducer', and 'Splitter'.
-class BranchComponent cc m x r | cc -> m x where
- -- | 'combineBranches' is used to combine two components in 'BranchComponent' class into one, using the
- -- given 'Consumer' binary combinator.
- combineBranches :: String -> Int
- -> (forall c. Bool -> (Source c x -> Pipe c m r) -> (Source c x -> Pipe c m r) -> (Source c x -> Pipe c m r))
- -> cc -> cc -> cc
-
-instance forall m x r. Monad m => BranchComponent (Consumer m x r) m x r where
- combineBranches name cost combinator c1 c2 = liftConsumer name 1 $
- \threads-> (ComponentConfiguration [AnyComponent c1, AnyComponent c2] 1 cost,
- combinator False (consume c1) (consume c2))
-
-instance forall m x. Monad m => BranchComponent (Consumer m x ()) m x [x] where
- combineBranches name cost combinator c1 c2 = liftConsumer name 1 $
- \threads-> (ComponentConfiguration [AnyComponent c1, AnyComponent c2] 1 cost,
- liftM (const ())
- . combinator False
- (\source-> consume c1 source >> return [])
- (\source-> consume c2 source >> return []))
-
-instance forall m x y. BranchComponent (Transducer m x y) m x [x] where
- combineBranches name cost combinator t1 t2
- = liftTransducer name (maxUsableThreads t1 + maxUsableThreads t2) $
- \threads-> let (configuration, t1', t2', parallel) = optimalTwoParallelConfigurations threads t1 t2
- transduce' source sink = combinator parallel
- (\source-> transduce t1 source sink)
- (\source-> transduce t2 source sink)
- source
- in (configuration, transduce')
-
-instance forall m x b. (ParallelizableMonad m, Typeable x) => BranchComponent (Splitter m x b) m x [x] where
- combineBranches name cost combinator s1 s2
- = liftSplitter name (maxUsableThreads s1 + maxUsableThreads s2) $
- \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2
- split' source true false edge = combinator parallel
- (\source-> split s1 source true false edge)
- (\source-> split s2 source true false edge)
- source
- in (configuration, split')
-
--- | Function 'liftPerformer' takes a component name, maximum number of threads it can use, and its 'usingThreads'
--- method, and returns a 'Performer' component.
-liftPerformer :: String -> Int -> (Int -> (ComponentConfiguration, forall c. Pipe c m r)) -> Performer m r
-liftPerformer name maxThreads usingThreads = case usingThreads 1
- of (configuration, perform) -> Performer name maxThreads configuration
- usingThreads perform
-
--- | Function 'liftConsumer' takes a component name, maximum number of threads it can use, and its 'usingThreads'
--- method, and returns a 'Consumer' component.
-liftConsumer :: String -> Int -> (Int -> (ComponentConfiguration, forall c. Source c x -> Pipe c m r)) -> Consumer m x r
-liftConsumer name maxThreads usingThreads = case usingThreads 1
- of (configuration, consume) -> Consumer name maxThreads configuration
- usingThreads consume
-
--- | Function 'liftProducer' takes a component name, maximum number of threads it can use, and its 'usingThreads'
--- method, and returns a 'Producer' component.
-liftProducer :: String -> Int -> (Int -> (ComponentConfiguration, forall c. Sink c x -> Pipe c m r)) -> Producer m x r
-liftProducer name maxThreads usingThreads = case usingThreads 1
- of (configuration, produce) -> Producer name maxThreads configuration
- usingThreads produce
-
--- | Function 'liftTransducer' takes a component name, maximum number of threads it can use, and its 'usingThreads'
--- method, and returns a 'Transducer' component.
-liftTransducer :: String -> Int -> (Int -> (ComponentConfiguration, forall c. Source c x -> Sink c y -> Pipe c m [x]))
- -> Transducer m x y
-liftTransducer name maxThreads usingThreads = case usingThreads 1
- of (configuration, transduce) -> Transducer name maxThreads configuration
- usingThreads transduce
-
--- | Function 'liftAtomicConsumer' lifts a single-threaded 'consume' function into a 'Consumer' component.
-liftAtomicConsumer :: String -> Int -> (forall c. Source c x -> Pipe c m r) -> Consumer m x r
-liftAtomicConsumer name cost consume = liftConsumer name 1 (\_threads-> (ComponentConfiguration [] 1 cost, consume))
-
--- | Function 'liftAtomicProducer' lifts a single-threaded 'produce' function into a 'Producer' component.
-liftAtomicProducer :: String -> Int -> (forall c. Sink c x -> Pipe c m r) -> Producer m x r
-liftAtomicProducer name cost produce = liftProducer name 1 (\_threads-> (ComponentConfiguration [] 1 cost, produce))
-
--- | Function 'liftAtomicTransducer' lifts a single-threaded 'transduce' function into a 'Transducer' component.
-liftAtomicTransducer :: String -> Int -> (forall c. Source c x -> Sink c y -> Pipe c m [x]) -> Transducer m x y
-liftAtomicTransducer name cost transduce = liftTransducer name 1 (\_threads-> (ComponentConfiguration [] 1 cost, transduce))
-
--- | Function 'lift121Transducer' takes a function that maps one input value to one output value each, and lifts it into
--- a 'Transducer'.
-lift121Transducer :: (Monad m, Typeable x, Typeable y) => String -> (x -> y) -> Transducer m x y
-lift121Transducer name f = liftAtomicTransducer name 1 $
- \source sink-> let t = canPut sink
- >>= flip when (getSuccess source (\x-> put sink (f x) >> t))
- in t >> return []
-
--- | Function 'liftStatelessTransducer' takes a function that maps one input value into a list of output values, and
--- lifts it into a 'Transducer'.
-liftStatelessTransducer :: (Monad m, Typeable x, Typeable y) => String -> (x -> [y]) -> Transducer m x y
-liftStatelessTransducer name f = liftAtomicTransducer name 1 $
- \source sink-> let t = canPut sink
- >>= flip when (getSuccess source (\x-> putList (f x) sink >> t))
- in t >> return []
-
--- | Function 'liftFoldTransducer' creates a stateful transducer that produces only one output value after consuming the
--- entire input. Similar to 'Data.List.foldl'
-liftFoldTransducer :: (Monad m, Typeable x, Typeable y) => String -> (s -> x -> s) -> s -> (s -> y) -> Transducer m x y
-liftFoldTransducer name f s0 w = liftAtomicTransducer name 1 $
- \source sink-> let t s = canPut sink
- >>= flip when (get source
- >>= maybe
- (put sink (w s) >> return ())
- (t . f s))
- in t s0 >> return []
-
--- | Function 'liftStatefulTransducer' constructs a 'Transducer' from a state-transition function and the initial
--- state. The transition function may produce arbitrary output at any transition step.
-liftStatefulTransducer :: (Monad m, Typeable x, Typeable y) => String -> (state -> x -> (state, [y])) -> state -> Transducer m x y
-liftStatefulTransducer name f s0 = liftAtomicTransducer name 1 $
- \source sink-> let t s = canPut sink
- >>= flip when (getSuccess source
- (\x-> let (s', ys) = f s x
- in putList ys sink >> t s'))
- in t s0 >> return []
-
--- | Function 'liftStatelessSplitter' takes a function that assigns a Boolean value to each input item and lifts it into
--- a 'Splitter'.
-liftStatelessSplitter :: (ParallelizableMonad m, Typeable x) => String -> (x -> Bool) -> Splitter m x b
-liftStatelessSplitter name f = liftAtomicSplitter name 1 $
- \source true false edge->
- let s = get source
- >>= maybe
- (return [])
- (\x-> put (if f x then true else false) x
- >>= cond s (return [x]))
- in s
-
--- | Function 'liftStatefulSplitter' takes a state-converting function that also assigns a Boolean value to each input
--- item and lifts it into a 'Splitter'.
-liftStatefulSplitter :: (ParallelizableMonad m, Typeable x) => String -> (state -> x -> (state, Bool)) -> state -> Splitter m x ()
-liftStatefulSplitter name f s0 = liftAtomicSplitter name 1 $
- \source true false edge->
- let split s = get source
- >>= maybe
- (return [])
- (\x-> let (s', truth) = f s x
- in put (if truth then true else false) x
- >>= cond (split s') (return [x]))
- in split s0
-
--- | Function 'liftSplitter' lifts a splitter function into a full 'Splitter'.
-liftSplitter :: forall m x b. (Monad m, Typeable x) =>
- String -> Int
- -> (Int -> (ComponentConfiguration, forall c. Source c x -> Sink c x -> Sink c x -> Sink c b -> Pipe c m [x]))
- -> Splitter m x b
-liftSplitter name maxThreads usingThreads = case usingThreads 1
- of (configuration, split) -> Splitter name maxThreads configuration usingThreads split
-
--- | Function 'liftAtomicSplitter' lifts a single-threaded 'split' function into a 'Splitter' component.
-liftAtomicSplitter :: forall m x b. (Monad m, Typeable x) =>
- String -> Int -> (forall c. Source c x -> Sink c x -> Sink c x -> Sink c b -> Pipe c m [x])
- -> Splitter m x b
-liftAtomicSplitter name cost split = liftSplitter name 1 (\_threads-> (ComponentConfiguration [] 1 cost, split))
-
--- | Function 'optimalTwoParallelConfigurations' configures two components, both of them with the full thread count, and
--- returns the components and a 'ComponentConfiguration' that can be used to build a new component from them.
-optimalTwoSequentialConfigurations :: (Component c1, Component c2) => Int -> c1 -> c2 -> (ComponentConfiguration, c1, c2)
-optimalTwoSequentialConfigurations threads c1 c2 = (configuration, c1', c2')
- where configuration = ComponentConfiguration
- [AnyComponent c1', AnyComponent c2']
- (usedThreads c1' `max` usedThreads c2')
- (cost c1' + cost c2')
- c1' = usingThreads threads c1
- c2' = usingThreads threads c2
-
--- | Function 'optimalTwoParallelConfigurations' configures two components assuming they can be run in parallel,
--- splitting the given thread count between them, and returns the configured components, a 'ComponentConfiguration' that
--- can be used to build a new component from them, and a flag that indicates if they should be run in parallel or
--- sequentially for optimal resource usage.
-optimalTwoParallelConfigurations :: (Component c1, Component c2) => Int -> c1 -> c2 -> (ComponentConfiguration, c1, c2, Bool)
-optimalTwoParallelConfigurations threads c1 c2 = (configuration, c1', c2', parallelize)
- where parallelize = threads > 1 && parallelCost + 1 < sequentialCost
- configuration = ComponentConfiguration
- [AnyComponent c1', AnyComponent c2']
- (if parallelize then usedThreads c1' + usedThreads c2' else usedThreads c1' `max` usedThreads c2')
- (if parallelize then parallelCost + 1 else sequentialCost)
- (c1', c2') = if parallelize then (c1p, c2p) else (c1s, c2s)
- (c1p, c2p, parallelCost) = minimumBy
- (\(_, _, cost1) (_, _, cost2)-> compare cost1 cost2)
- [let c2threads = threads - c1threads `min` maxUsableThreads c2
- c1i = usingThreads c1threads c1
- c2i = usingThreads c2threads c2
- in (c1i, c2i, cost c1i `max` cost c2i)
- | c1threads <- [1 .. threads - 1 `min` maxUsableThreads c1]]
- c1s = usingThreads threads c1
- c2s = usingThreads threads c2
- sequentialCost = cost c1s + cost c2s
-
--- | Function 'optimalThreeParallelConfigurations' configures three components assuming they can be run in parallel,
--- splitting the given thread count between them, and returns the components, a 'ComponentConfiguration' that can be
--- used to build a new component from them, and a flag per component that indicates if it should be run in parallel or
--- sequentially for optimal resource usage.
-optimalThreeParallelConfigurations :: (Component c1, Component c2, Component c3) =>
- Int -> c1 -> c2 -> c3 -> (ComponentConfiguration, (c1, Bool), (c2, Bool), (c3, Bool))
-optimalThreeParallelConfigurations threadCount c1 c2 c3 = undefined
-
-
--- | Given a 'Splitter', a 'Source', and three consumer functions, 'splitToConsumers' runs the splitter on the source
--- and feeds the splitter's outputs to its /true/, /false/, and /edge/ sinks, respectively, to the three consumers.
-splitToConsumers :: forall c m x b r1 r2 r3. (ParallelizableMonad m, Typeable x, Typeable b)
- => Splitter m x b -> Source c x -> (Source c x -> Pipe c m r1) -> (Source c x -> Pipe c m r2)
- -> (Source c b -> Pipe c m r3) -> Pipe c m ([x], r1, r2, r3)
-splitToConsumers s source trueConsumer falseConsumer edgeConsumer
- = pipe
- (\true-> pipe
- (\false-> pipe
- (split s source true false)
- edgeConsumer)
- falseConsumer)
- trueConsumer
- >>= \(((extra, r3), r2), r1)-> return (extra, r1, r2, r3)
-
--- | Given a 'Splitter', a 'Source', and two consumer functions, 'splitInputToConsumers' runs the splitter on the source
--- and feeds the splitter's /true/ and /false/ outputs, respectively, to the two consumers.
-splitInputToConsumers :: forall c m x b r1 r2. (ParallelizableMonad m, Typeable x, Typeable b)
- => Bool -> Splitter m x b -> Source c x -> (Source c x -> Pipe c m [x]) -> (Source c x -> Pipe c m [x])
- -> Pipe c m [x]
-splitInputToConsumers parallel s source trueConsumer falseConsumer
- = pipe'
- (\false-> pipe'
- (\true-> pipe
- (split s source true false)
- consumeAndSuppress)
- trueConsumer)
- falseConsumer
- >>= \(((extra, _), xs1), xs2)-> return (prependCommonPrefix xs1 xs2 extra)
- where pipe' = if parallel then pipeP else pipe
- prependCommonPrefix (x:xs) (y:ys) tail = x : prependCommonPrefix xs ys tail
- prependCommonPrefix _ _ tail = tail
diff --git a/Control/Concurrent/SCC/Components.hs b/Control/Concurrent/SCC/Components.hs
--- a/Control/Concurrent/SCC/Components.hs
+++ b/Control/Concurrent/SCC/Components.hs
@@ -14,383 +14,474 @@
.
-}
--- | Module "Components" defines primitive components of 'Producer', 'Consumer', 'Transducer' and 'Splitter' types,
--- defined in the "Foundation" and "ComponentTypes" modules.
+{-# LANGUAGE ScopedTypeVariables, Rank2Types, KindSignatures, EmptyDataDecls,
+ MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, FunctionalDependencies, TypeFamilies #-}
-{-# LANGUAGE ScopedTypeVariables, Rank2Types, DeriveDataTypeable #-}
+-- | 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
- (
- -- * 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
- asis, parse, unparse, parseSubstring,
- -- * Generic splitters
- everything, nothing, marked, markedContent, markedWith, contentMarkedWith, one, substring,
- -- * List transducers
- -- | The following laws hold:
- --
- -- * 'group' '>->' 'concatenate' == 'asis'
- --
- -- * 'concatenate' == 'concatSeparate' []
- group, concatenate, concatSeparate,
- -- * Character stream components
- lowercase, uppercase, whitespace, letters, digits, line, nonEmptyLine,
- -- * Oddballs
- count, toString,
- ioCost
-)
-where
+module Control.Concurrent.SCC.Components where
-import Prelude hiding (appendFile, last)
+import Control.Concurrent.Coroutine
+import Control.Concurrent.SCC.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 Control.Concurrent.SCC.Foundation
-import Control.Concurrent.SCC.ComponentTypes
+import Prelude hiding (appendFile, even, last, sequence, (||), (&&))
+import Control.Monad (liftM)
-import Control.Exception (assert)
+import System.IO (Handle)
-import Control.Monad (liftM, when)
-import qualified Control.Monad as Monad
-import Data.Char (isAlpha, isDigit, isPrint, isSpace, toLower, toUpper)
-import Data.List (delete, isPrefixOf, stripPrefix)
-import Data.Maybe (fromJust)
-import qualified Data.Foldable as Foldable
-import qualified Data.Sequence as Seq
-import Data.Sequence (Seq, (|>), (><), ViewL (EmptyL, (:<)))
-import Data.Typeable (Typeable)
-import Debug.Trace (trace)
-import System.IO (Handle, IOMode (ReadMode, WriteMode, AppendMode), openFile, hClose,
- hGetChar, hPutChar, hFlush, hIsEOF, hClose, putChar, isEOF, stdout)
+-- | 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
--- | Consumer 'toList' copies the given source into a list.
-toList :: forall m x. (Monad m, Typeable x) => Consumer m x [x]
-toList = liftAtomicConsumer "toList" 1 getList
+-- | 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, Typeable x) => [x] -> Producer m x [x]
-fromList l = liftAtomicProducer "fromList" 1 (putList l)
+fromList :: forall m x. Monad m => [x] -> ProducerComponent m x [x]
+fromList l = atomic "fromList" 1 (Primitive.fromList l)
--- | Consumer 'toStdOut' copies the given source into the standard output.
-toStdOut :: Consumer IO Char ()
-toStdOut = liftAtomicConsumer "toStdOut" ioCost $ \source-> let c = get source
- >>= maybe (return ()) (\x-> liftPipe (putChar x) >> c)
- in c
+-- | ConsumerComponent 'toStdOut' copies the given source into the standard output.
+toStdOut :: ConsumerComponent IO Char ()
+toStdOut = atomic "toStdOut" ioCost Primitive.toStdOut
--- | Producer 'fromStdIn' feeds the given sink from the standard input.
-fromStdIn :: Producer IO Char ()
-fromStdIn = liftAtomicProducer "fromStdIn" ioCost $ \sink-> let p = do readyInput <- liftM not (liftPipe isEOF)
- readyOutput <- canPut sink
- when (readyInput && readyOutput) (liftPipe getChar
- >>= put sink
- >> p)
- in p
+-- | ProducerComponent 'fromStdIn' feeds the given sink from the standard input.
+fromStdIn :: ProducerComponent IO Char ()
+fromStdIn = atomic "fromStdIn" ioCost Primitive.fromStdIn
--- | Producer 'fromFile' opens the named file and feeds the given sink from its contents.
-fromFile :: String -> Producer IO Char ()
-fromFile path = liftAtomicProducer "fromFile" ioCost $ \sink-> do handle <- liftPipe (openFile path ReadMode)
- produce (fromHandle handle True) sink
+-- | 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)
--- | 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 = liftAtomicProducer "fromHandle" ioCost $
- \sink-> (canPut sink
- >>= flip when (let p = do eof <- liftPipe (hIsEOF handle)
- when (not eof) (liftPipe (hGetChar handle)
- >>= put sink
- >>= flip when p)
- in p)
- >> when doClose (liftPipe $ hClose handle))
+-- | 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)
--- | Consumer 'toFile' opens the named file and copies the given source into it.
-toFile :: String -> Consumer IO Char ()
-toFile path = liftAtomicConsumer "toFile" ioCost $ \source-> do handle <- liftPipe (openFile path WriteMode)
- consume (toHandle handle True) source
+-- | 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)
--- | Consumer 'appendFile' opens the name file and appends the given source to it.
-appendFile :: String -> Consumer IO Char ()
-appendFile path = liftAtomicConsumer "appendFile" ioCost $ \source-> do handle <- liftPipe (openFile path AppendMode)
- consume (toHandle handle True) source
+-- | 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)
--- | 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 = liftAtomicConsumer "toHandle" ioCost $ \source-> let c = get source
- >>= maybe
- (when doClose $ liftPipe $ hClose handle)
- (\x-> liftPipe (hPutChar handle x) >> c)
- in c
+-- | 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)
--- | Transducer 'asis' passes its input through unmodified.
-asis :: forall m x. (Monad m, Typeable x) => Transducer m x x
-asis = lift121Transducer "asis" id
+-- | TransducerComponent 'asis' passes its input through unmodified.
+asis :: forall m x. Monad m => TransducerComponent m x x
+asis = atomic "asis" 1 Primitive.asis
--- | Transducer 'unparse' removes all markup from its input and passes the content through.
-unparse :: forall m x y. (Monad m, Typeable x, Typeable y) => Transducer m (Markup x y) x
-unparse = liftStatelessTransducer "unparse" removeTag
- where removeTag (Content x) = [x]
- removeTag _ = []
+-- | 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
--- | Transducer 'parse' prepares input content for subsequent parsing.
-parse :: forall m x y. (Monad m, Typeable x, Typeable y) => Transducer m x (Markup x y)
-parse = lift121Transducer "parse" Content
+-- | 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, Typeable x) => Consumer m x ()
-suppress = liftAtomicConsumer "suppress" 1 consumeAndSuppress
+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, Typeable x) => String -> Consumer m x ()
-erroneous message = liftAtomicConsumer "erroneous" 0 $ \source-> get source >>= maybe (return ()) (const (error message))
+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 => Transducer m Char Char
-lowercase = lift121Transducer "lowercase" toLower
+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 => Transducer m Char Char
-uppercase = lift121Transducer "uppercase" toUpper
+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, Typeable x) => Transducer m x Integer
-count = liftFoldTransducer "count" (\count _-> succ count) 0 id
+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, Typeable x) => Transducer m x String
-toString = lift121Transducer "toString" show
+toString :: forall m x. (Monad m, Show x) => TransducerComponent m x String
+toString = atomic "toString" 1 Primitive.toString
--- | Transducer 'group' collects all its input values into a single list.
-group :: forall m x. (Monad m, Typeable x) => Transducer m x [x]
-group = liftFoldTransducer "group" (|>) Seq.empty Foldable.toList
+-- | 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
--- | Transducer 'concatenate' flattens the input stream of lists of values into the output stream of values.
-concatenate :: forall m x. (Monad m, Typeable x) => Transducer m [x] x
-concatenate = liftStatelessTransducer "concatenate" id
+-- | 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, Typeable x) => [x] -> Transducer m [x] x
-concatSeparate separator = liftStatefulTransducer "concatSeparate"
- (\seen list-> (True, if seen then separator ++ list else list))
- False
+concatSeparate :: forall m x. Monad m => [x] -> TransducerComponent m [x] x
+concatSeparate separator = atomic "concatSeparate" 1 (Primitive.concatSeparate separator)
--- | Splitter 'whitespace' feeds all white-space characters into its /true/ sink, all others into /false/.
-whitespace :: forall m. ParallelizableMonad m => Splitter m Char ()
-whitespace = liftStatelessSplitter "whitespace" isSpace
+-- | 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
--- | Splitter 'letters' feeds all alphabetical characters into its /true/ sink, all other characters into /false/.
-letters :: forall m. ParallelizableMonad m => Splitter m Char ()
-letters = liftStatelessSplitter "letters" isAlpha
+-- | 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
--- | Splitter 'digits' feeds all digits into its /true/ sink, all other characters into /false/.
-digits :: forall m. ParallelizableMonad m => Splitter m Char ()
-digits = liftStatelessSplitter "digits" isDigit
+-- | 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
--- | Splitter 'nonEmptyLine' feeds line-ends into its /false/ sink, and all other characters into /true/.
-nonEmptyLine :: forall m. ParallelizableMonad m => Splitter m Char ()
-nonEmptyLine = liftStatelessSplitter "nonEmptyLine" (\ch-> ch /= '\n' && ch /= '\r')
+-- | 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. ParallelizableMonad m => Splitter m Char ()
-line = liftAtomicSplitter "line" 1 $
- \source true false boundaries-> let split0 = get source >>= maybe (return []) split1
- split1 x = if x == '\n' || x == '\r'
- then split2 x
- else lineChar x
- split2 x = put false x
- >>= cond
- (get source
- >>= maybe
- (return [])
- (\y-> if x == y
- then emptyLine x
- else if y == '\n' || y == '\r'
- then split3 x
- else lineChar y))
- (return [x])
- split3 x = put false x
- >>= cond
- (get source
- >>= maybe
- (return [])
- (\y-> if y == '\n' || y == '\r'
- then emptyLine y
- else lineChar y))
- (return [x])
- emptyLine x = put boundaries () >>= cond (split2 x) (return [])
- lineChar x = put true x >>= cond split0 (return [x])
- in split0
-
--- | Splitter 'everything' feeds its entire input into its /true/ sink.
-everything :: forall m x. (ParallelizableMonad m, Typeable x) => Splitter m x ()
-everything = liftAtomicSplitter "everything" 1 $
- \source true false edge-> do put edge ()
- pour source true
- return []
-
--- | Splitter 'nothing' feeds its entire input into its /false/ sink.
-nothing :: forall m x. (ParallelizableMonad m, Typeable x) => Splitter m x ()
-nothing = liftAtomicSplitter "nothing" 1 $
- \source true false edge-> do pour source false
- return []
+line :: forall m. Monad m => SplitterComponent m Char ()
+line = atomic "line" 1 Primitive.line
--- | Splitter 'one' feeds all input values to its /true/ sink, treating every value as a separate section.
-one :: forall m x. (ParallelizableMonad m, Typeable x) => Splitter m x ()
-one = liftAtomicSplitter "one" 1 $
- \source true false edge-> let s = get source
- >>= maybe
- (return [])
- (\x-> put edge ()
- >>= cond
- (put true x
- >>= cond s (return [x]))
- (return [x]))
- in s
+-- | 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
--- | Splitter 'marked' passes all marked-up input sections to its /true/ sink, and all unmarked input to its /false/
--- sink.
-marked :: forall m x y. (ParallelizableMonad m, Typeable x, Typeable y, Eq y) => Splitter m (Markup x y) ()
-marked = markedWith (const True)
+-- | 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
--- | Splitter 'markedContent' passes the content of all marked-up input sections to its /true/ sink, while the outermost
--- tags and all unmarked input go to its /false/ sink.
-markedContent :: forall m x y. (ParallelizableMonad m, Typeable x, Typeable y, Eq y) => Splitter m (Markup x y) ()
-markedContent = contentMarkedWith (const True)
+-- | 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
--- | Splitter 'markedWith' passes input sections marked-up with the appropriate tag to its /true/ sink, and the rest of
--- the input to its /false/ sink. The argument /select/ determines if the tag is appropriate.
-markedWith :: forall m x y. (ParallelizableMonad m, Typeable x, Typeable y, Eq y) => (y -> Bool) -> Splitter m (Markup x y) ()
-markedWith select = liftStatefulSplitter "markedWith" transition ([], False)
- where transition s@([], _) Content{} = (s, False)
- transition s@(_, truth) Content{} = (s, truth)
- transition s@([], _) (Markup (Point y)) = (s, select y)
- transition s@(_, truth) (Markup (Point y)) = (s, truth)
- transition ([], _) (Markup (Start y)) = (([y], select y), select y)
- transition (open, truth) (Markup (Start y)) = ((y:open, truth), truth)
- transition (open, truth) (Markup (End y)) = assert (elem y open) ((delete y open, truth), truth)
+-- | 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
--- | Splitter 'contentMarkedWith' passes the content of input sections marked-up with the appropriate tag to its /true/
--- sink, and the rest of the input to its /false/ sink. The argument /select/ determines if the tag is appropriate.
-contentMarkedWith :: forall m x y. (ParallelizableMonad m, Typeable x, Typeable y, Eq y)
- => (y -> Bool) -> Splitter m (Markup x y) ()
-contentMarkedWith select = liftStatefulSplitter "markedWith" transition ([], False)
- where transition s@(_, truth) Content{} = (s, truth)
- transition s@(_, truth) (Markup Point{}) = (s, truth)
- transition ([], _) (Markup (Start y)) = (([y], select y), False)
- transition (open, truth) (Markup (Start y)) = ((y:open, truth), truth)
- transition (open, truth) (Markup (End y)) = assert (elem y open) (let open' = delete y open
- truth' = not (null open') && truth
- in ((open', truth'), truth'))
+-- | 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
--- | Used by 'parseSubstring' to distinguish between overlapping substrings.
-data OccurenceTag = Occurence Int deriving (Eq, Show, Typeable)
+-- | 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)
-instance Enum OccurenceTag where
- succ (Occurence n) = Occurence (succ n)
- pred (Occurence n) = Occurence (pred n)
- toEnum = Occurence
- fromEnum (Occurence n) = n
+-- | 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. (ParallelizableMonad m, Eq x, Typeable x) => [x] -> Parser m x OccurenceTag
-parseSubstring [] = liftAtomicTransducer "parseSubstring" 1 $
- \ source sink -> let next = get source
- >>= maybe (return []) wrap
- wrap x = put sink (Content x) >>= cond prepend (return [x])
- prepend = put sink (Markup (Point (toEnum 1))) >>= cond next (return [])
- in prepend
-parseSubstring list
- = liftAtomicTransducer "parseSubstring" 1 $
- \ source sink ->
- let getNext id rest q = get source
- >>= maybe
- (flush q)
- (advance id rest q)
- advance id rest@(head:tail) q x = let q' = q |> Content x
- view@(qh@Content{} :< qt) = Seq.viewl q'
- id' = succ id
- in if x == head
- then if null tail
- then put sink (Markup (Start (toEnum id')))
- >>= cond
- (put sink qh
- >>= cond
- (fallback id' (qt |> Markup (End (toEnum id'))))
- (return $ remainingContent q'))
- (return $ remainingContent q')
- else getNext id tail q'
- else fallback id q'
- fallback id q = case Seq.viewl q
- of EmptyL -> getNext id list q
- head@(Markup (End id')) :< tail -> put sink head
- >>= cond
- (fallback
- (if id == fromEnum id' then 0 else id)
- tail)
- (return $ remainingContent tail)
- view@(head@Content{} :< tail) -> case stripPrefix (remainingContent q) list
- of Just rest -> getNext id rest q
- Nothing -> put sink head
- >>= cond
- (fallback id tail)
- (return $ remainingContent q)
- flush q = liftM extractContent $ putList (Foldable.toList $ Seq.viewl q) sink
- remainingContent :: Seq (Markup x OccurenceTag) -> [x]
- remainingContent q = extractContent (Seq.viewl q)
- extractContent :: Foldable.Foldable f => f (Markup x b) -> [x]
- extractContent = Foldable.concatMap (\e-> case e of {Content x -> [x]; _ -> []})
- in getNext 0 list Seq.empty
+parseSubstring :: forall m x y. (Monad m, Eq x) => [x] -> ParserComponent m x OccurenceTag
+parseSubstring list = atomic "parseSubstring" 1 (Primitive.parseSubstring list)
--- | Splitter 'substring' feeds to its /true/ sink all input parts that match the contents of the given 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. (ParallelizableMonad m, Eq x, Typeable x) => [x] -> Splitter m x ()
-substring [] = liftAtomicSplitter "substring" 1 $
- \ source true false edge -> do rest <- split one source false true edge
- put edge ()
- return rest
-substring list
- = liftAtomicSplitter "substring" 1 $
- \ source true false edge ->
- let getNext rest qt qf = get source
- >>= maybe
- (putList (Foldable.toList (Seq.viewl qt)) true
- >> putList (Foldable.toList (Seq.viewl qf)) false)
- (advance rest qt qf)
- advance rest@(head:tail) qt qf x = let qf' = qf |> x
- view@(qqh :< qqt) = Seq.viewl (qt >< qf')
- in if x == head
- then if null tail
- then put edge ()
- >> put true qqh
- >>= cond
- (fallback qqt Seq.empty)
- (return $ Foldable.toList view)
- else getNext tail qt qf'
- else fallback qt qf'
- fallback qt qf = case Seq.viewl (qt >< qf)
- of EmptyL -> getNext list Seq.empty Seq.empty
- view@(head :< tail) -> case stripPrefix (Foldable.toList view) list
- of Just rest -> getNext rest qt qf
- Nothing -> if Seq.null qt
- then put false head
- >>= cond
- (fallback Seq.empty tail)
- (return $ Foldable.toList view)
- else put true head
- >>= cond
- (fallback (Seq.drop 1 qt) qf)
- (return $ Foldable.toList view)
- in getNext list Seq.empty Seq.empty
+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.connect
+
+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. ParallelizableMonad 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. ParallelizableMonad 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. ParallelizableMonad 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.
+(||) :: (ParallelizableMonad m)
+ => SplitterComponent m x b1 -> SplitterComponent m x b2 -> SplitterComponent m x (Either b1 b2)
+(||) = liftParallelPair "||" Combinator.pOr
+
+ifs :: forall c m x b. (ParallelizableMonad m, Branching c m x [x]) =>
+ SplitterComponent m x b -> Component c -> Component c -> Component c
+ifs = parallelRouterAndBranches "ifs" Combinator.ifs
+
+wherever :: forall m x b. ParallelizableMonad m =>
+ TransducerComponent m x x -> SplitterComponent m x b -> TransducerComponent m x x
+wherever = liftParallelPair "wherever" Combinator.wherever
+
+unless :: forall m x b. ParallelizableMonad 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. ParallelizableMonad 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. ParallelizableMonad 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. ParallelizableMonad 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. (ParallelizableMonad m, Branching c m x [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. ParallelizableMonad 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. ParallelizableMonad 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. ParallelizableMonad 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. ParallelizableMonad 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. ParallelizableMonad 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. ParallelizableMonad 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. ParallelizableMonad 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. ParallelizableMonad m =>
+ SplitterComponent m (Markup Token Char) b1 -> SplitterComponent m Char b2 ->
+ SplitterComponent m (Markup Token Char) b1
+xmlHavingOnlyText = liftParallelPair "XML.havingOnlyText" XML.havingOnlyText
diff --git a/Control/Concurrent/SCC/Foundation.hs b/Control/Concurrent/SCC/Foundation.hs
deleted file mode 100644
--- a/Control/Concurrent/SCC/Foundation.hs
+++ /dev/null
@@ -1,337 +0,0 @@
-{-
- Copyright 2008-2009 Mario Blazevic
-
- This file is part of the Streaming Component Combinators (SCC) project.
-
- The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public
- License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later
- version.
-
- SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty
- of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License along with SCC. If not, see
- .
--}
-
--- | Module "Foundation" defines the pipe computations and their basic building blocks.
-
-{-# LANGUAGE ScopedTypeVariables, Rank2Types, PatternGuards, ExistentialQuantification #-}
-
-module Control.Concurrent.SCC.Foundation
- (-- * Classes
- ParallelizableMonad (parallelize),
- -- * Types
- Pipe, Source, Sink,
- -- * Flow-control functions
- pipe, pipeD, pipeP, get, getSuccess, get', canPut, put,
- liftPipe, runPipes,
- -- * Utility functions
- cond, whenNull, pour, pourMap, pourMapMaybe, tee, getList, putList, putQueue, consumeAndSuppress)
-where
-
-import Control.Concurrent (forkIO)
-import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
-import Control.Exception (assert)
-import Control.Monad (liftM, liftM2, when)
-import Control.Monad.Identity
-import Control.Parallel (par, pseq)
-
-import Data.Foldable (toList)
-import Data.Maybe (maybe)
-import Data.Sequence (Seq, viewl)
-import Data.Typeable (Typeable, cast)
-
-import Debug.Trace (trace)
-
-class Monad m => ParallelizableMonad m where
- parallelize :: m a -> m b -> m (a, b)
- parallelize = liftM2 (,)
-
-instance ParallelizableMonad Identity where
- parallelize ma mb = let a = runIdentity ma
- b = runIdentity mb
- in a `par` (b `pseq` Identity (a, b))
-
-instance ParallelizableMonad Maybe where
- parallelize ma mb = case ma `par` (mb `pseq` (ma, mb))
- of (Just a, Just b) -> Just (a, b)
- _ -> Nothing
-
-
-instance ParallelizableMonad IO where
- parallelize ma mb = do va <- newEmptyMVar
- vb <- newEmptyMVar
- forkIO (ma >>= putMVar va)
- forkIO (mb >>= putMVar vb)
- a <- takeMVar va
- b <- takeMVar vb
- return (a, b)
-
-
--- | 'Pipe' represents the type of monadic computations that can be split into co-routining computations using function
--- 'pipe'. The /context/ type parameter delimits the scope of the computation.
-newtype Pipe context m r = Pipe {proceed :: PipeState context -> m (PipeRendezvous context m r)}
-data PipeState context = PipeState {level :: Int,
- clock :: Integer}
-data PipeRendezvous context m r = Suspend [Suspension context m r]
- | Done Integer r
-data Suspension context m r = Suspension {targetLevel :: Int,
- state :: PipeState context,
- description :: String,
- continuation :: SuspendedContinuation context m r}
-data SuspendedContinuation context m r = forall x. Typeable x => Get (Maybe x -> Pipe context m r)
- | forall x. Typeable x => Put x (Bool -> Pipe context m r)
- | CanPut (Bool -> Pipe context m r)
-
--- | A 'Source' is the read-only end of a 'Pipe' communication channel.
-data Source context x = Source Int String
--- | A 'Sink' is the write-only end of a 'Pipe' communication channel.
-data Sink context x = Sink Int String
-
--- | A computation that consumes values from a 'Source' is called 'Consumer'.
-type Consumer c m x r = Source c x -> Pipe c m r
--- | A computation that produces values and puts them into a 'Sink' is called 'Producer'.
-type Producer c m x r = Sink c x -> Pipe c m r
-
--- | Function 'liftPipe' lifts a value of the underlying monad type into a 'Pipe' computation.
-liftPipe :: forall context m r. Monad m => m r -> Pipe context m r
-liftPipe mr = Pipe (\state-> liftM (Done (clock state)) mr)
-
--- | Function 'runPipes' runs the given computation involving pipes and returns the final result.
--- The /context/ argument ensures that no suspended computation can escape its scope.
-runPipes :: forall m r. Monad m => (forall context. Pipe context m r) -> m r
-runPipes c = proceed c (PipeState 1 0) >>= \s-> case s of Done _ r -> return r
-
-instance Monad m => Monad (Pipe context m) where
- return r = Pipe (\state-> return (Done (clock state) r))
- Pipe p >>= f = Pipe (\state-> p state >>= apply f state)
- where apply :: forall r1 r2. (r1 -> Pipe context m r2) -> PipeState context -> PipeRendezvous context m r1
- -> m (PipeRendezvous context m r2)
- apply f state (Done t r) = proceed (f r) state{clock= succ t}
- apply f state (Suspend suspensions) = return $ Suspend (map suspendApplied suspensions)
- where suspendApplied s = postApply (>>= f) s{description= "applied " ++ description s}
-
-postApply :: (Pipe context m r1 -> Pipe context m r2) -> Suspension context m r1 -> Suspension context m r2
-postApply f s = s{continuation= case continuation s of Get cont -> Get (f . cont)
- Put x cont -> Put x (f . cont)
- CanPut cont -> CanPut (f . cont)}
-
-instance ParallelizableMonad m => ParallelizableMonad (Pipe context m) where
- parallelize p1 p2 = Pipe (\state-> liftM combine $ parallelize (proceed p1 state) (proceed p2 state))
- where combine :: forall r1 r2. (PipeRendezvous context m r1, PipeRendezvous context m r2) -> PipeRendezvous context m (r1, r2)
- combine (Done c1 r1, Done c2 r2) = Done (max c1 c2) (r1, r2)
- combine (Suspend s1, Done c2 r2) = Suspend (map (adjustSuspension c2 (liftM $ flip (,) r2)) s1)
- combine (Done c1 r1, Suspend s2) = Suspend (map (adjustSuspension c1 (liftM $ (,) r1)) s2)
- combine (r1@(Suspend s1), r2@(Suspend s2)) = Suspend (merge (map (postApply (flip parallelize (rewrap r2))) s1)
- (map (postApply (parallelize (rewrap r1))) s2))
- rewrap :: PipeRendezvous context m r -> Pipe context m r
- rewrap r = Pipe $ const $ return $ r
- adjustSuspension :: Integer -> (Pipe context m r1 -> Pipe context m r2)
- -> Suspension context m r1 -> Suspension context m r2
- adjustSuspension c f s = postApply f s{state= (state s) {clock= clock (state s) `max` c}}
-
-instance Show (Suspension context m r) where
- show Suspension{targetLevel= lvl, description = desc, continuation= c} = (case c of Put{} -> "(Put)"
- CanPut{} -> "(CanPut)"
- Get{} -> "(Get)")
- ++ desc ++ " -> " ++ show lvl
-
--- | 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 context x m r1 r2. Monad m => Producer context m x r1 -> Consumer context m x r2 -> Pipe context m (r1, r2)
-pipe = pipeD ""
-
--- | The 'pipeD' function is same as 'pipe', with an additional description argument.
-pipeD :: forall c x m r1 r2. Monad m => String -> Producer c m x r1 -> Consumer c m x r2 -> Pipe c m (r1, r2)
-pipeD description producer consumer = pipePrim description (liftM2 (,)) producer consumer
-
--- | The 'pipeP' function is equivalent to 'pipe', except the /producer/ and /consumer/ are run in parallel if resources
--- allow.
-pipeP :: forall c x m r1 r2. ParallelizableMonad m => Producer c m x r1 -> Consumer c m x r2 -> Pipe c m (r1, r2)
-pipeP producer consumer = pipePrim "" parallelize producer consumer
-
--- | The 'pipePrim' function is the actual worker function of the 'pipe' family.
-pipePrim :: forall c m x r1 r2. Monad m =>
- String -> (forall a b. m a -> m b -> m (a, b)) -> Producer c m x r1 -> Consumer c m x r2 -> Pipe c m (r1, r2)
-pipePrim description pairMonads producer consumer
- = Pipe (\(PipeState level clock)-> let level' = succ level
- description' = description ++ ':' : show level
- in assert (track (indent level ++ "pipe " ++ description')) $
- do (ps, cs) <- pairMonads (proceed (producer (Sink level description'))
- (PipeState level' clock))
- (proceed (consumer (Source level description'))
- (PipeState level' clock))
- reduce pairMonads level ps cs)
-
-reduce :: forall c m r1 r2. Monad m =>
- (m (PipeRendezvous c m r1) -> m (PipeRendezvous c m r2) -> m (PipeRendezvous c m r1, PipeRendezvous c m r2))
- -> Int -> PipeRendezvous c m r1 -> PipeRendezvous c m r2 -> m (PipeRendezvous c m (r1, r2))
-reduce pairMonads level (Done t1 r1) (Done t2 r2)
- = assert (track (indent level ++ "Done " ++ show level ++ " -> " ++ show level)) $
- return (Done (max t1 t2) (r1, r2))
-reduce pairMonads level (Suspend ps@(Suspension{targetLevel= l1, state= s1, continuation= pCont} : _)) consumer@Done{}
- | l1 == level, Put _ cont <- pCont
- = assert (track (indent level ++ "Failed producer put " ++ show ps ++ " from " ++ show level)) $
- proceed (cont False) s1 >>= \p'-> reduce pairMonads level p' consumer
- | l1 == level, CanPut cont <- pCont
- = assert (track (indent level ++ "Finish producer " ++ show ps ++ " from " ++ show level)) $
- proceed (cont False) s1 >>= \p'-> reduce pairMonads level p' consumer
- | l1 < level = assert (track (indent level ++ "Suspend producer " ++ show ps ++ " from " ++ show level)) $
- return $ Suspend $ map (delay (\ps'-> reduce pairMonads level ps' consumer)) ps
- | otherwise = error (show l1 ++ ">" ++ show level ++ " | producer : " ++ show ps)
-reduce pairMonads level producer@Done{} (Suspend cs@(Suspension{targetLevel= l2, state= s2, continuation= cCont} : _))
- | l2 == level, Get cont <- cCont
- = assert (track (indent level ++ "Finish consumer " ++ show cs ++ " from " ++ show level)) $
- proceed (cont Nothing) s2 >>= reduce pairMonads level producer
- | l2 < level
- = assert (track (indent level ++ "Suspend consumer " ++ show cs ++ " from " ++ show level)) $
- return $ Suspend $ map (delay (reduce pairMonads level producer)) cs
- | otherwise = error (show l2 ++ ">" ++ show level ++ " | consumer : " ++ show cs)
-reduce pairMonads level producer@(Suspend ps@(Suspension{targetLevel= l1, state= s1, continuation= pc} : _))
- consumer@(Suspend cs@(Suspension{targetLevel= l2, state= s2, continuation= Get cCont} : _))
- | l1 == level && l2 == level, CanPut pCont <- pc
- = assert (track (indent level ++ "CanPut Match at " ++ show level ++ " : " ++ show ps ++ " -> " ++ show cs)) $
- proceed (pCont True) s1 >>= \p'-> reduce pairMonads level p' consumer
- | l1 == level, Put x pCont <- pc
- = assert (track (indent level ++ "Match at " ++ show level ++ " : " ++ show ps ++ " -> " ++ show cs)) $
- do (p', c') <- pairMonads (assert (track "producer (") $ proceed (pCont True) (synchronizeState s1 s2))
- (assert (track ") consumer (") $ proceed (cCont (cast x)) (synchronizeState s2 s1))
- assert (track ") combined ->") reduce pairMonads level p' c'
-reduce pairMonads level producer@(Suspend ps) consumer@(Suspend cs) = assert (track (indent level ++ "Suspend producer & consumer, "
- ++ show ps ++ " from " ++ show level ++ " & "
- ++ show cs ++ " from " ++ show level)) $
- keepSuspending ps cs
- where keepSuspending (Suspension{targetLevel=level'} : pTail) cs | level' == level = keepSuspending pTail cs
- keepSuspending ps (Suspension{targetLevel= level'} : cTail) | level' == level = keepSuspending ps cTail
- keepSuspending ps cs = assert (track (indent level ++ "Suspend' producer & consumer, "
- ++ show ps ++ " from " ++ show level ++ " & "
- ++ show cs ++ " from " ++ show level)) $
- return $ Suspend $
- merge (map (\p-> delay (\p'-> reduce pairMonads level p' consumer) p) ps)
- (map (delay (reduce pairMonads level producer)) cs)
-
-merge :: [Suspension context m r] -> [Suspension context m r] -> [Suspension context m r]
-merge [] l = l
-merge l [] = l
-merge l1@(h1@Suspension{targetLevel= level1, state= PipeState _ c1} : tail1)
- l2@(h2@Suspension{targetLevel= level2, state= PipeState _ c2} : tail2)
- | level1 > level2 = h1 : merge tail1 l2
- | level1 < level2 = h2 : merge l1 tail2
- | c1 < c2 = h1 : merge tail1 l2
- | otherwise = h2 : merge l1 tail2
-
-delay :: Monad m =>
- (PipeRendezvous context m r1 -> m (PipeRendezvous context m r2)) -> Suspension context m r1 -> Suspension context m r2
-delay f = delay' (\p-> Pipe $ \state-> proceed p state >>= f)
-
-delay' :: (Pipe context m r1 -> Pipe context m r2) -> Suspension context m r1 -> Suspension context m r2
-delay' f s@Suspension{description= desc, continuation= Get cont}
- = s{description= "delayed " ++ desc, continuation= Get (f . cont)}
-delay' f s@Suspension{description= desc, continuation= Put x cont}
- = s{description= "delayed " ++ desc, continuation= Put x (f . cont)}
-delay' f s@Suspension{description= desc, continuation= CanPut cont}
- = s{description= "delayed " ++ desc, continuation= CanPut (f . cont)}
-
-synchronizeState :: PipeState context -> PipeState context -> PipeState context
-synchronizeState (PipeState pid1 clock1) (PipeState pid2 clock2) = (PipeState pid1 (max clock1 clock2))
-
-indent 0 = ""
-indent n = ' ' : indent (n `div` 2)
-
--- | Function 'get' tries to get a value from the given 'Source' argument. The intervening 'Pipe' computations suspend
--- all the way to the 'pipe' function invocation that created the source. The result of 'get' is 'Nothing' iff the
--- argument source is empty.
-get :: forall context x m r. (Monad m, Typeable x) => Source context x -> Pipe context m (Maybe x)
-get (Source pid desc) = assert (track (indent pid ++ "Get from " ++ desc ++ "@" ++ show pid)) $
- Pipe (\state@(PipeState pid' clock)->
- assert (track (indent pid ++ "Get<- " ++ desc ++ "@" ++ show pid ++ ":" ++ show clock)) $
- return $ Suspend $
- [Suspension pid state ("get from " ++ desc ++ "@" ++ show pid ++ ":" ++ show clock) $ Get return])
-
-getSuccess :: forall context x m. (Monad m, Typeable x)
- => Source context x
- -> (x -> Pipe context m ()) -- ^ Success continuation
- -> Pipe context m ()
-getSuccess source succeed = get source >>= maybe (return ()) succeed
-
--- | Function 'get'' assumes that the argument source is not empty and returns the value the source yields. If the
--- source is empty, the function throws an error.
-get' :: forall context x m r. (Monad m, Typeable x) => Source context x -> Pipe context m x
-get' source = get source >>= maybe (error "get' failed") return
-
--- | Function 'put' tries to put a value into the given sink. The intervening 'Pipe' computations suspend up to the
--- 'pipe' invocation that has created the argument sink. The result of 'put' indicates whether the operation succeded.
-put :: forall context x m r. (Monad m, Typeable x) => Sink context x -> x -> Pipe context m Bool
-put (Sink pid desc) x = assert (track (indent pid ++ "Put into " ++ desc ++ "@" ++ show pid)) $
- Pipe (\state@(PipeState pid' clock)->
- assert (track (indent pid ++ "Put-> " ++ desc ++ "@" ++ show pid ++ ":" ++ show clock)) $
- return $ Suspend $
- [Suspension pid state ("put into " ++ desc ++ "@" ++ show pid ++ ":" ++ show clock)
- (Put x return)])
-
--- | Function 'canPut' checks if the argument sink accepts values, i.e., whether a 'put' operation would succeed on the
--- sink.
-canPut :: forall context x m r. (Monad m, Typeable x) => Sink context x -> Pipe context m Bool
-canPut (Sink pid desc) = assert (track (indent pid ++ "CanPut into " ++ desc ++ "@" ++ show pid)) $
- Pipe (\state@(PipeState pid' clock)->
- assert (track (indent pid ++ "CanPut-> " ++ desc ++ "@" ++ show pid ++ ":" ++ show clock)) $
- return $ Suspend $
- [Suspension pid state ("canPut into " ++ desc ++ "@" ++ show pid ++ ":" ++ show clock)
- (CanPut return)])
-
--- | 'pour' copies all data from the /source/ argument into the /sink/ argument, as long as there is anything to copy
--- and the sink accepts it.
-pour :: forall c x m. (Monad m, Typeable x) => Source c x -> Sink c x -> Pipe c m ()
-pour source sink = fill'
- where fill' = canPut sink >>= flip when (getSuccess source (\x-> put sink x >> fill'))
-
--- | 'pourMap' is like 'pour' that applies the function /f/ to each argument before passing it into the /sink/.
-pourMap :: forall c x y m. (Monad m, Typeable x, Typeable y) => (x -> y) -> Source c x -> Sink c y -> Pipe c m ()
-pourMap f source sink = loop
- where loop = canPut sink >>= flip when (get source >>= maybe (return ()) (\x-> put sink (f x) >> loop))
-
--- | 'pourMapMaybe' is to 'pourMap' like 'Data.Maybe.mapMaybe' is to 'Data.List.Map'.
-pourMapMaybe :: forall c x y m. (Monad m, Typeable x, Typeable y) => (x -> Maybe y) -> Source c x -> Sink c y -> Pipe c m ()
-pourMapMaybe f source sink = loop
- where loop = canPut sink >>= flip when (get source >>= maybe (return ()) (\x-> maybe (return False) (put sink) (f x) >> loop))
-
--- | 'tee' is similar to 'pour' except it distributes every input value from the /source/ arguments into both /sink1/
--- and /sink2/.
-tee :: (Monad m, Typeable x) => Source c x -> Sink c x -> Sink c x -> Pipe c m ()
-tee source sink1 sink2 = distribute
- where distribute = do c1 <- canPut sink1
- c2 <- canPut sink2
- when (c1 && c2)
- (get source >>= maybe (return ()) (\x-> put sink1 x >> put sink2 x >> distribute))
-
--- | 'putList' puts entire list into its /sink/ argument, as long as the sink accepts it. The remainder that wasn't
--- accepted by the sink is the result value.
-putList :: forall x c m. (Monad m, Typeable x) => [x] -> Sink c x -> Pipe c m [x]
-putList [] sink = return []
-putList l@(x:rest) sink = put sink x >>= cond (putList rest sink) (return l)
-
--- | 'getList' returns the list of all values generated by the source.
-getList :: forall x c m. (Monad m, Typeable x) => Source c x -> Pipe c m [x]
-getList source = get source >>= maybe (return []) (\x-> liftM (x:) (getList source))
-
--- | 'consumeAndSuppress' consumes the entire source ignoring the values it generates.
-consumeAndSuppress :: forall x c m. (Monad m, Typeable x) => Source c x -> Pipe c m ()
-consumeAndSuppress source = get source
- >>= maybe (return ()) (const (consumeAndSuppress source))
-
--- | A utility function wrapping if-then-else, useful for handling monadic truth values
-cond :: a -> a -> Bool -> a
-cond x y test = if test then x else y
-
--- | A utility function, useful for handling monadic list values where empty list means success
-whenNull :: forall a m. Monad m => m [a] -> [a] -> m [a]
-whenNull action list = if null list then action else return list
-
-track :: String -> Bool
-track message = True
-
--- | Like 'putList', except it puts the contents of the given 'Data.Sequence.Seq' into the sink.
-putQueue :: forall c m x. (Monad m, Typeable x) => Seq x -> Sink c x -> Pipe c m [x]
-putQueue q sink = putList (toList (viewl q)) sink
diff --git a/Control/Concurrent/SCC/Primitives.hs b/Control/Concurrent/SCC/Primitives.hs
new file mode 100644
--- /dev/null
+++ b/Control/Concurrent/SCC/Primitives.hs
@@ -0,0 +1,397 @@
+{-
+ Copyright 2008-2009 Mario Blazevic
+
+ This file is part of the Streaming Component Combinators (SCC) project.
+
+ The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public
+ License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later
+ version.
+
+ SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty
+ of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License along with SCC. If not, see
+ .
+-}
+
+-- | Module "Primitives" defines primitive components of 'Producer', 'Consumer', 'Transducer' and 'Splitter' types,
+-- defined in the "Types" module.
+
+{-# LANGUAGE ScopedTypeVariables, Rank2Types #-}
+
+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
+ asis, parse, unparse, parseSubstring,
+ -- * Generic splitters
+ everything, nothing, marked, markedContent, markedWith, contentMarkedWith, one, substring,
+ -- * List transducers
+ -- | The following laws hold:
+ --
+ -- * 'group' '>->' 'concatenate' == 'asis'
+ --
+ -- * 'concatenate' == 'concatSeparate' []
+ group, concatenate, concatSeparate,
+ -- * Character stream components
+ lowercase, uppercase, whitespace, letters, digits, line, nonEmptyLine,
+ -- * Oddballs
+ count, toString
+)
+where
+
+import Prelude hiding (appendFile)
+
+import Control.Concurrent.Coroutine
+import Control.Concurrent.SCC.Streams
+import Control.Concurrent.SCC.Types
+
+import Control.Exception (assert)
+
+import Control.Monad (liftM, when)
+import Control.Monad.Trans (lift)
+import qualified Control.Monad as Monad
+import Data.Char (isAlpha, isDigit, isPrint, isSpace, toLower, toUpper)
+import Data.List (delete, isPrefixOf, stripPrefix)
+import Data.Maybe (fromJust)
+import qualified Data.Foldable as Foldable
+import qualified Data.Sequence as Seq
+import Data.Sequence (Seq, (|>), (><), ViewL (EmptyL, (:<)))
+import Debug.Trace (trace)
+import System.IO (Handle, IOMode (ReadMode, WriteMode, AppendMode), openFile, hClose,
+ hGetChar, hPutChar, hFlush, hIsEOF, hClose, putChar, isEOF, stdout)
+
+-- | Consumer 'toList' copies the given 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.
+fromList :: forall m x. Monad m => [x] -> Producer m x [x]
+fromList l = Producer (putList l)
+
+-- | Consumer 'toStdOut' copies the given source into the standard output.
+toStdOut :: Consumer IO Char ()
+toStdOut = Consumer $
+ \source-> let c = get source
+ >>= maybe (return ()) (\x-> lift (putChar x) >> c)
+ in c
+
+-- | Producer 'fromStdIn' feeds the given sink from the standard input.
+fromStdIn :: Producer IO Char ()
+fromStdIn = Producer $
+ \sink-> let p = do readyInput <- liftM not (lift isEOF)
+ readyOutput <- canPut sink
+ when (readyInput && readyOutput) (lift getChar
+ >>= put sink
+ >> p)
+ in p
+
+-- | Producer 'fromFile' opens 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
+
+-- | 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-> (canPut sink
+ >>= flip when (let p = do eof <- lift (hIsEOF handle)
+ when (not eof) (lift (hGetChar handle)
+ >>= put sink
+ >>= flip when p)
+ in p)
+ >> when doClose (lift $ hClose handle))
+
+-- | Consumer 'toFile' opens the named file and copies the given source into it.
+toFile :: String -> Consumer IO Char ()
+toFile path = Consumer $ \source-> do handle <- lift (openFile path WriteMode)
+ consume (toHandle handle True) source
+
+-- | Consumer 'appendFile' opens the name file and appends the given source to it.
+appendFile :: String -> Consumer IO Char ()
+appendFile path = Consumer $ \source-> do handle <- lift (openFile path AppendMode)
+ consume (toHandle handle True) source
+
+-- | 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-> let c = get source
+ >>= maybe
+ (when doClose $ lift $ hClose handle)
+ (\x-> lift (hPutChar handle x) >> c)
+ in c
+
+-- | Transducer 'asis' passes its input through unmodified.
+asis :: forall m x. Monad m => Transducer m x x
+asis = oneToOneTransducer id
+
+-- | 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 = statelessTransducer removeTag
+ where removeTag (Content x) = [x]
+ removeTag _ = []
+
+-- | Transducer 'parse' prepares input content for subsequent parsing.
+parse :: forall m x y. Monad m => Transducer m x (Markup y x)
+parse = oneToOneTransducer Content
+
+-- | 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 consumeAndSuppress
+
+-- | The 'erroneous' consumer reports an error if any input reaches it.
+erroneous :: forall m x. Monad m => String -> Consumer m x ()
+erroneous message = Consumer $
+ \source-> get source >>= maybe (return ()) (const (error message))
+
+-- | The 'lowercase' transforms all uppercase letters in the input to lowercase, leaving the rest unchanged.
+lowercase :: forall m. Monad m => Transducer m Char Char
+lowercase = oneToOneTransducer toLower
+
+-- | The 'uppercase' transforms all lowercase letters in the input to uppercase, leaving the rest unchanged.
+uppercase :: forall m. Monad m => Transducer m Char Char
+uppercase = oneToOneTransducer toUpper
+
+-- | The 'count' transducer counts all its input values and outputs the final tally.
+count :: forall m x. Monad m => Transducer m x Integer
+count = foldingTransducer (\count _-> succ count) 0 id
+
+-- | Converts each input value @x@ to @show x@.
+toString :: forall m x. (Monad m, Show x) => Transducer m x String
+toString = oneToOneTransducer show
+
+-- | Transducer 'group' collects all its input values into a single list.
+group :: forall m x. Monad m => Transducer m x [x]
+group = foldingTransducer (|>) Seq.empty Foldable.toList
+
+-- | Transducer 'concatenate' flattens the input stream of lists of values into the output stream of values.
+concatenate :: forall m x. Monad m => Transducer m [x] x
+concatenate = statelessTransducer id
+
+-- | Same as 'concatenate' except it inserts the given separator list between every two input lists.
+concatSeparate :: forall m x. Monad m => [x] -> Transducer m [x] x
+concatSeparate separator = statefulTransducer (\seen list-> (True, if seen then separator ++ list else list))
+ False
+
+-- | Splitter 'whitespace' feeds all white-space characters into its /true/ sink, all others into /false/.
+whitespace :: forall m. Monad m => Splitter m Char ()
+whitespace = statelessSplitter isSpace
+
+-- | Splitter 'letters' feeds all alphabetical characters into its /true/ sink, all other characters into
+-- | /false/.
+letters :: forall m. Monad m => Splitter m Char ()
+letters = statelessSplitter isAlpha
+
+-- | Splitter 'digits' feeds all digits into its /true/ sink, all other characters into /false/.
+digits :: forall m. Monad m => Splitter m Char ()
+digits = statelessSplitter isDigit
+
+-- | Splitter 'nonEmptyLine' feeds line-ends into its /false/ sink, and all other characters into /true/.
+nonEmptyLine :: forall m. Monad m => Splitter m Char ()
+nonEmptyLine = statelessSplitter (\ch-> ch /= '\n' && ch /= '\r')
+
+-- | The sectioning splitter 'line' feeds line-ends into its /false/ sink, and line contents into /true/. A single
+-- line-end can be formed by any of the character sequences \"\\n\", \"\\r\", \"\\r\\n\", or \"\\n\\r\".
+line :: forall m. Monad m => Splitter m Char ()
+line = Splitter $
+ \source true false boundaries-> let split0 = get source >>= maybe (return []) split1
+ split1 x = if x == '\n' || x == '\r'
+ then split2 x
+ else lineChar x
+ split2 x = put false x
+ >>= cond
+ (get source
+ >>= maybe
+ (return [])
+ (\y-> if x == y
+ then emptyLine x
+ else if y == '\n' || y == '\r'
+ then split3 x
+ else lineChar y))
+ (return [x])
+ split3 x = put false x
+ >>= cond
+ (get source
+ >>= maybe
+ (return [])
+ (\y-> if y == '\n' || y == '\r'
+ then emptyLine y
+ else lineChar y))
+ (return [x])
+ emptyLine x = put boundaries () >>= cond (split2 x) (return [])
+ lineChar x = put true x >>= cond split0 (return [x])
+ in split0
+
+-- | Splitter 'everything' feeds its entire input into its /true/ sink.
+everything :: forall m x. Monad m => Splitter m x ()
+everything = Splitter $
+ \source true false edge-> do put edge ()
+ pour source true
+ return []
+
+-- | Splitter 'nothing' feeds its entire input into its /false/ sink.
+nothing :: forall m x. Monad m => Splitter m x ()
+nothing = Splitter $
+ \source true false edge-> do pour source false
+ return []
+
+-- | Splitter 'one' feeds all input values to its /true/ sink, treating every value as a separate section.
+one :: forall m x. Monad m => Splitter m x ()
+one = Splitter $
+ \source true false edge-> let s = get source
+ >>= maybe
+ (return [])
+ (\x-> put edge ()
+ >>= cond
+ (put true x
+ >>= cond s (return [x]))
+ (return [x]))
+ in s
+
+-- | Splitter 'marked' passes all marked-up input sections to its /true/ sink, and all unmarked input to its
+-- /false/ sink.
+marked :: forall m x y. (Monad m, Eq y) => Splitter m (Markup y x) ()
+marked = markedWith (const True)
+
+-- | Splitter 'markedContent' passes the content of all marked-up input sections to its /true/ sink, while the
+-- outermost tags and all unmarked input go to its /false/ sink.
+markedContent :: forall m x y. (Monad m, Eq y) => Splitter m (Markup y x) ()
+markedContent = contentMarkedWith (const True)
+
+-- | Splitter 'markedWith' passes input sections marked-up with the appropriate tag to its /true/ sink, and the
+-- rest of the input to its /false/ sink. The argument /select/ determines if the tag is appropriate.
+markedWith :: forall m x y. (Monad m, Eq y) => (y -> Bool) -> Splitter m (Markup y x) ()
+markedWith select = statefulSplitter transition ([], False)
+ where transition s@([], _) Content{} = (s, False)
+ transition s@(_, truth) Content{} = (s, truth)
+ transition s@([], _) (Markup (Point y)) = (s, select y)
+ transition s@(_, truth) (Markup (Point y)) = (s, truth)
+ transition ([], _) (Markup (Start y)) = (([y], select y), select y)
+ transition (open, truth) (Markup (Start y)) = ((y:open, truth), truth)
+ transition (open, truth) (Markup (End y)) = assert (elem y open) ((delete y open, truth), truth)
+
+-- | Splitter 'contentMarkedWith' passes the content of input sections marked-up with the appropriate tag to
+-- its /true/ sink, and the rest of the input to its /false/ sink. The argument /select/ determines if the tag is
+-- appropriate.
+contentMarkedWith :: forall m x y. (Monad m, Eq y) => (y -> Bool) -> Splitter m (Markup y x) ()
+contentMarkedWith select = statefulSplitter transition ([], False)
+ where transition s@(_, truth) Content{} = (s, truth)
+ transition s@(_, truth) (Markup Point{}) = (s, truth)
+ transition ([], _) (Markup (Start y)) = (([y], select y), False)
+ transition (open, truth) (Markup (Start y)) = ((y:open, truth), truth)
+ transition (open, truth) (Markup (End y)) = assert (elem y open) (let open' = delete y open
+ truth' = not (null open') && truth
+ in ((open', truth'), truth'))
+
+-- | Used by 'parseSubstring' to distinguish between overlapping substrings.
+data OccurenceTag = Occurence Int deriving (Eq, Show)
+
+instance Enum OccurenceTag where
+ succ (Occurence n) = Occurence (succ n)
+ pred (Occurence n) = Occurence (pred n)
+ toEnum = Occurence
+ fromEnum (Occurence n) = n
+
+-- | Performs the same task as the 'substring' splitter, but instead of splitting it outputs the input as @'Markup' x
+-- 'OccurenceTag'@ in order to distinguish overlapping strings.
+parseSubstring :: forall m x y. (Monad m, Eq x) => [x] -> Parser m x OccurenceTag
+parseSubstring [] = Transducer $
+ \ source sink -> let next = get source
+ >>= maybe (return []) wrap
+ wrap x = put sink (Content x) >>= cond prepend (return [x])
+ prepend = put sink (Markup (Point (toEnum 1))) >>= cond next (return [])
+ in prepend
+parseSubstring list
+ = Transducer $
+ \ source sink ->
+ let getNext id rest q = get source
+ >>= maybe
+ (flush q)
+ (advance id rest q)
+ advance id rest@(head:tail) q x = let q' = q |> Content x
+ view@(qh@Content{} :< qt) = Seq.viewl q'
+ id' = succ id
+ in if x == head
+ then if null tail
+ then put sink (Markup (Start (toEnum id')))
+ >>= cond
+ (put sink qh
+ >>= cond
+ (fallback id' (qt
+ |> Markup (End (toEnum id'))))
+ (return $ remainingContent q'))
+ (return $ remainingContent q')
+ else getNext id tail q'
+ else fallback id q'
+ fallback id q = case Seq.viewl q
+ of EmptyL -> getNext id list q
+ head@(Markup (End id')) :< tail -> put sink head
+ >>= cond
+ (fallback
+ (if id == fromEnum id' then 0 else id)
+ tail)
+ (return $ remainingContent tail)
+ view@(head@Content{} :< tail) -> case stripPrefix (remainingContent q) list
+ of Just rest -> getNext id rest q
+ Nothing -> put sink head
+ >>= cond
+ (fallback id tail)
+ (return $ remainingContent q)
+ flush q = liftM extractContent $ putList (Foldable.toList $ Seq.viewl q) sink
+ remainingContent :: Seq (Markup 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
+
+-- | Splitter 'substring' feeds to its /true/ sink all input parts that match the contents of the given list
+-- argument. If two overlapping parts of the input both match the argument, both are sent to /true/ and each is preceded
+-- by an edge.
+substring :: forall m x. (Monad m, Eq x) => [x] -> Splitter m x ()
+substring [] = Splitter $
+ \ source true false edge -> do rest <- split one source false true edge
+ put edge ()
+ return rest
+substring list
+ = Splitter $
+ \ source true false edge ->
+ let getNext rest qt qf = get source
+ >>= maybe
+ (putList (Foldable.toList (Seq.viewl qt)) true
+ >> putList (Foldable.toList (Seq.viewl qf)) false)
+ (advance rest qt qf)
+ advance rest@(head:tail) qt qf x = let qf' = qf |> x
+ view@(qqh :< qqt) = Seq.viewl (qt >< qf')
+ in if x == head
+ then if null tail
+ then put edge ()
+ >> put true qqh
+ >>= cond
+ (fallback qqt Seq.empty)
+ (return $ Foldable.toList view)
+ else getNext tail qt qf'
+ else fallback qt qf'
+ fallback qt qf = case Seq.viewl (qt >< qf)
+ of EmptyL -> getNext list Seq.empty Seq.empty
+ view@(head :< tail) -> case stripPrefix (Foldable.toList view) list
+ of Just rest -> getNext rest qt qf
+ Nothing -> if Seq.null qt
+ then put false head
+ >>= cond
+ (fallback Seq.empty tail)
+ (return $ Foldable.toList view)
+ else put true head
+ >>= cond
+ (fallback (Seq.drop 1 qt) qf)
+ (return $ Foldable.toList view)
+ in getNext list Seq.empty Seq.empty
diff --git a/Control/Concurrent/SCC/Streams.hs b/Control/Concurrent/SCC/Streams.hs
new file mode 100644
--- /dev/null
+++ b/Control/Concurrent/SCC/Streams.hs
@@ -0,0 +1,214 @@
+{-
+ 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
+ .
+-}
+
+-- | This module defines 'Source' and 'Sink' types and 'pipe' functions that create them. The method 'get' on 'Source'
+-- abstracts away 'Control.Concurrent.SCC.Coroutine.await', and the method 'put' on 'Sink' is a higher-level
+-- abstraction of 'Control.Concurrent.SCC.Coroutine.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.SCC.Coroutine.Coroutine' functor; the only requirement is for each funtor of the sources and
+-- sinks the coroutine uses to be an 'Control.Concurrent.SCC.Coroutine.AncestorFunctor' of the coroutine's
+-- functor. For example, coroutine /zip/ that takes two sources and one sink would be declared like this:
+--
+-- @
+-- zip :: forall m a1 a2 a3 d x y. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d)
+-- => Source m a1 x -> Source m a2 y -> Sink m a3 (x, y) -> Coroutine d m ()
+-- @
+--
+-- Sources, sinks, and coroutines communicating through them are all created using the 'pipe' function or one of its
+-- variants. They effectively split the current coroutine into a producer-consumer coroutine pair. The producer gets a
+-- new 'Sink' to write to and the consumer a new 'Source' to read from, in addition to all the streams that are visible
+-- in the original coroutine. The following function, for example, uses the /zip/ coroutine above to add together the
+-- values from two Integer sources:
+--
+-- @
+-- add :: forall m a1 a2 a3 d. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d)
+-- => Source m a1 Integer -> Source m a2 Integer -> Sink m a3 Integer -> Coroutine d m ()
+-- add source1 source2 sink = do pipe
+-- (\pairSink-> zip source1 source2 pairSink) -- producer coroutine
+-- (\pairSource-> pourMap (uncurry (+)) pairSource sink) -- consumer coroutine
+-- return ()
+-- @
+
+{-# LANGUAGE ScopedTypeVariables, Rank2Types, TypeFamilies, KindSignatures #-}
+
+module Control.Concurrent.SCC.Streams
+ (
+ -- * Sink and Source types
+ Sink(put, canPut), Source(get),
+ SinkFunctor, SourceFunctor,
+ -- * Various pipe functions
+ pipe, pipeP, pipePS,
+ -- * Utility functions
+ get', getSuccess,
+ liftSink, liftSource,
+ consumeAndSuppress, tee, pour, pourMap, getList, putList, putQueue,
+ cond, whenNull
+ )
+where
+
+import Control.Concurrent.Coroutine
+
+import Control.Monad (when)
+import Data.Foldable (toList)
+import Data.Sequence (Seq, viewl)
+
+type TryYield x = EitherFunctor (Yield x) (Await Bool)
+
+tryYield :: forall m x. Monad m => x -> Coroutine (TryYield x) m Bool
+tryYield x = suspend (LeftF (Yield x (suspend (RightF (Await return)))))
+
+canYield :: forall m x. Monad m => Coroutine (TryYield x) m Bool
+canYield = suspend (RightF (Await return))
+
+type SourceFunctor a x = EitherFunctor a (Await (Maybe x))
+type SinkFunctor a x = EitherFunctor a (TryYield 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 'Pipe' communication channel.
+data Sink (m :: * -> *) a x =
+ Sink
+ {
+ -- | Function 'put' tries to put a value into the given `Sink`. The intervening 'Coroutine' computations suspend up
+ -- to the 'pipe' invocation that has created the argument sink. The result of 'put' indicates whether the operation
+ -- succeded.
+ put :: forall d. (AncestorFunctor a d) => x -> Coroutine d m Bool,
+ -- | Function 'canPut' checks if the argument `Sink` accepts values, i.e., whether a 'put' operation would succeed on
+ -- the sink.
+ canPut :: forall d. (AncestorFunctor a d) => Coroutine d m Bool
+ }
+
+-- | A 'Source' can be used to read values into any nested `Coroutine` computation whose functor provably descends from
+-- the functor /a/. It's the read-only end of a 'Pipe' communication channel.
+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)
+ }
+
+-- | 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 Bool),
+ canPut= liftOut (canPut s :: Coroutine d m Bool)}
+
+-- | 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))}
+
+-- | 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})
+
+-- | The 'pipeP' function is equivalent to 'pipe', except the /producer/ and /consumer/ are run in parallel.
+pipeP :: forall m a a1 a2 x r1 r2. (ParallelizableMonad 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. (ParallelizableMonad 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)
+ -> Coroutine a m (r1, r2)
+pipeG run2 producer consumer =
+ seesawNested run2 resolver (producer sink) (consumer source)
+ where sink = Sink {put= liftOut . (local . tryYield :: x -> Coroutine a1 m Bool),
+ canPut= liftOut (local canYield :: Coroutine a1 m Bool)} :: Sink m a1 x
+ source = Source (liftOut (local await :: Coroutine a2 m (Maybe x))) :: Source m a2 x
+ resolver = SeesawResolver {
+ resumeLeft= \s-> case s of (LeftF (Yield _ c))-> c
+ (RightF (Await c))-> c False,
+ resumeRight = \(Await c)-> c Nothing,
+ resumeAny= \ resumeProducer _ resumeBoth s (Await cc) ->
+ case s of LeftF (Yield x cp) -> resumeBoth cp (cc (Just x))
+ RightF (Await cp) -> resumeProducer (cp True)
+ }
+
+getSuccess :: forall m a d x . (Monad m, AncestorFunctor a d)
+ => Source m a x -> (x -> Coroutine d m ()) {- ^ Success continuation -} -> Coroutine d m ()
+getSuccess source succeed = get source >>= maybe (return ()) succeed
+
+-- | Function 'get'' assumes that the argument source is not empty and returns the value the source yields. If the
+-- source is empty, the function throws an error.
+get' :: forall m a d x . (Monad m, AncestorFunctor a d) => Source m a x -> Coroutine d m x
+get' source = get source >>= maybe (error "get' failed") return
+
+-- | 'pour' copies all data from the /source/ argument into the /sink/ argument, as long as there is anything to copy
+-- and the sink accepts it.
+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 = fill'
+ where fill' = canPut sink >>= flip when (getSuccess source (\x-> put sink x >> fill'))
+
+-- | 'pourMap' is like 'pour' that applies the function /f/ to each argument before passing it into the /sink/.
+pourMap :: forall 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 ()
+pourMap f source sink = loop
+ where loop = canPut sink >>= flip when (get source >>= maybe (return ()) (\x-> put sink (f x) >> loop))
+
+-- | 'pourMapMaybe' is to 'pourMap' like 'Data.Maybe.mapMaybe' is to 'Data.List.Map'.
+pourMapMaybe :: forall 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 ()
+pourMapMaybe f source sink = loop
+ where loop = canPut sink >>= flip when (get source >>= maybe (return ()) (\x-> maybe (return False) (put sink) (f x) >> loop))
+
+-- | 'tee' is similar to 'pour' except it distributes every input value from the /source/ arguments into both /sink1/
+-- and /sink2/.
+tee :: 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 = do c1 <- canPut sink1
+ c2 <- canPut sink2
+ when (c1 && c2)
+ (get source >>= maybe (return ()) (\x-> put sink1 x >> put sink2 x >> distribute))
+
+-- | 'putList' puts entire list into its /sink/ argument, as long as the sink accepts it. The remainder that wasn't
+-- accepted by the sink is the result value.
+putList :: forall m a d x. (Monad m, AncestorFunctor a d) => [x] -> Sink m a x -> Coroutine d m [x]
+putList [] sink = return []
+putList l@(x:rest) sink = put sink x >>= cond (putList rest sink) (return l)
+
+-- | '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:)))
+
+-- | 'consumeAndSuppress' consumes the entire source ignoring the values it generates.
+consumeAndSuppress :: forall m a d x. (Monad m, AncestorFunctor a d) => Source m a x -> Coroutine d m ()
+consumeAndSuppress source = get source
+ >>= maybe (return ()) (const (consumeAndSuppress source))
+
+-- | A utility function wrapping if-then-else, useful for handling monadic truth values
+cond :: a -> a -> Bool -> a
+cond x y test = if test then x else y
+
+-- | A utility function, useful for handling monadic list values where empty list means success
+whenNull :: forall a m. Monad m => m [a] -> [a] -> m [a]
+whenNull action list = if null list then action else return list
+
+-- | Like 'putList', except it puts the contents of the given 'Data.Sequence.Seq' into the sink.
+putQueue :: forall m a d x. (Monad m, AncestorFunctor a d) => Seq x -> Sink m a x -> Coroutine d m [x]
+putQueue q sink = putList (toList (viewl q)) sink
diff --git a/Control/Concurrent/SCC/Types.hs b/Control/Concurrent/SCC/Types.hs
new file mode 100644
--- /dev/null
+++ b/Control/Concurrent/SCC/Types.hs
@@ -0,0 +1,299 @@
+{-
+ Copyright 2009-2010 Mario Blazevic
+
+ This file is part of the Streaming Component Combinators (SCC) project.
+
+ The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public
+ License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later
+ version.
+
+ SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty
+ of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License along with SCC. If not, see
+ .
+-}
+
+-- | This module defines various 'Control.Concurrent.SCC.Coroutine.Coroutine' types that operate on
+-- 'Control.Concurrent.SCC.Streams.Sink' and 'Control.Concurrent.SCC.Streams.Source' values. The simplest of the bunch
+-- are 'Consumer' and 'Producer' types, which respectively operate on a single source or sink. A 'Transducer' has access
+-- both to a 'Control.Concurrent.SCC.Streams.Source' to read from and a 'Control.Concurrent.SCC.Streams.Sink' to write
+-- into. Finally, a 'Splitter' reads from a single source and writes all input into two sinks of the same type,
+-- signalling interesting input boundaries by writing into the third sink.
+--
+
+{-# LANGUAGE ScopedTypeVariables, KindSignatures, RankNTypes, ExistentialQuantification,
+ MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, FunctionalDependencies, TypeFamilies #-}
+
+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, foldingTransducer, statefulTransducer,
+ statelessSplitter, statefulSplitter,
+ -- * Utility functions
+ splitToConsumers, splitInputToConsumers, pipePS
+ )
+where
+
+import Control.Concurrent.Coroutine
+import Control.Concurrent.SCC.Streams
+
+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 =
+ (AncestorFunctor a1 d, AncestorFunctor a2 d) => Source m a1 x -> Sink m a2 y -> Coroutine d m [x]
+type OpenSplitter m a1 a2 a3 a4 d x b =
+ (AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d, AncestorFunctor a4 d) =>
+ Source m a1 x -> Sink m a2 x -> Sink m a3 x -> Sink m a4 b -> Coroutine d m [x]
+
+-- | A component that performs a computation with no inputs nor outputs.
+newtype Performer m r = Performer {perform :: m r}
+
+-- | A component that consumes values from a 'Control.Concurrent.SCC.Streams.Source'.
+newtype Consumer m x r = Consumer {consume :: forall a d. OpenConsumer m a d x r}
+
+-- | A component that produces values and puts them into a 'Control.Concurrent.SCC.Streams.Sink'.
+newtype Producer m x r = Producer {produce :: forall a d. OpenProducer m a d x r}
+
+-- | The 'Transducer' type represents computations that transform a data stream. Execution of 'transduce' must continue
+-- consuming the given 'Control.Concurrent.SCC.Streams.Source' and feeding the 'Control.Concurrent.SCC.Streams.Sink' as
+-- long both can be resumed. If the sink dies first, 'transduce' should return the list of all values it has consumed
+-- from the source but hasn't managed to process and write into the sink.
+newtype Transducer m x y = Transducer {transduce :: forall a1 a2 d. OpenTransducer m a1 a2 d x y}
+
+-- | The 'SplitterComponent' type represents computations that distribute the input stream acording to some criteria. A
+-- splitter should distribute only the original input data, and feed it into the sinks in the same order it has been
+-- read from the source. Furthermore, the input source should be entirely consumed and fed into the first two sinks. The
+-- third sink can be used to supply extra information at arbitrary points in the input. If any of the sinks dies before
+-- all data is fed to them, 'split' should return the list of all values it has consumed from the source but hasn't
+-- managed to write into the sinks.
+--
+-- A splitter can be used in two ways: as a predicate to determine which portions of its input stream satisfy a certain
+-- property, or as a chunker to divide the input stream into chunks. In the former case, the predicate is considered
+-- true for exactly those parts of the input that are written to its /true/ sink. In the latter case, a chunk is a
+-- contiguous section of the input stream that is written exclusively to one sink, either true or false. Anything
+-- written to the third sink also terminates the chunk.
+newtype Splitter m x b = Splitter {split :: forall a1 a2 a3 a4 d. OpenSplitter m a1 a2 a3 a4 d x b}
+
+-- | A 'Markup' value is produced to mark either a 'Start' and 'End' of a region of data, or an arbitrary
+-- 'Point' in data. A 'Point' is semantically equivalent to a 'Start' immediately followed by 'End'. The 'Content'
+-- constructor wraps the actual data.
+data Boundary y = Start y | End y | Point y deriving (Eq, Show)
+data Markup y x = Content x | Markup (Boundary y) deriving (Eq)
+type Parser m x b = Transducer m x (Markup b x)
+
+instance Functor Boundary where
+ fmap f (Start b) = Start (f b)
+ fmap f (End b) = End (f b)
+ fmap f (Point b) = Point (f b)
+
+instance Functor (Markup y) where
+ 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
+ showsPrec p (Markup b) s = '[' : shows b (']' : s)
+
+-- | 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'
+ where consume' :: forall a d. OpenConsumer m a d x r
+ consume' source = let source' :: Source m d x
+ source' = liftSource source
+ in consume source'
+
+-- | Creates a proper 'Producer' from a function that is, but can't be proven to be, an 'OpenProducer'.
+isolateProducer :: forall m x r. Monad m => (forall d. Functor d => Sink m d x -> Coroutine d m r) -> Producer m x r
+isolateProducer produce = Producer produce'
+ where produce' :: forall a d. OpenProducer m a d x r
+ produce' sink = let sink' :: Sink m d x
+ sink' = liftSink sink
+ in produce sink'
+
+-- | Creates a proper 'Transducer' from a function that is, but can't be proven to be, an 'OpenTransducer'.
+isolateTransducer :: forall m x y. Monad m =>
+ (forall d. Functor d => Source m d x -> Sink m d y -> Coroutine d m [x]) -> Transducer m x y
+isolateTransducer transduce = Transducer transduce'
+ where transduce' :: forall a1 a2 d. OpenTransducer m a1 a2 d x y
+ transduce' source sink = let source' :: Source m d x
+ source' = liftSource source
+ sink' :: Sink m d y
+ sink' = liftSink sink
+ in transduce source' sink'
+
+-- | Creates a proper 'Splitter' from a function that is, but can't be proven to be, an 'OpenSplitter'.
+isolateSplitter :: forall m x b. Monad m =>
+ (forall d. Functor d =>
+ Source m d x -> Sink m d x -> Sink m d x -> Sink m d b -> Coroutine d m [x])
+ -> Splitter m x b
+isolateSplitter split = Splitter split'
+ where split' :: forall a1 a2 a3 a4 d. OpenSplitter m a1 a2 a3 a4 d x b
+ split' source true false edge = let source' :: Source m d x
+ source' = liftSource source
+ true' :: Sink m d x
+ true' = liftSink true
+ false' :: Sink m d x
+ false' = liftSink false
+ edge' :: Sink m d b
+ edge' = liftSink edge
+ in split source' true' false' edge'
+
+-- | 'Branching' is a type class representing all types that can act as consumers, namely 'Consumer',
+-- 'Transducer', and 'Splitter'.
+class Branching c (m :: * -> *) x r | c -> m x where
+ -- | 'combineBranches' is used to combine two values of 'Branch' class into one, using the given 'Consumer' binary
+ -- combinator.
+ combineBranches :: (forall d. (Bool ->
+ (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
+
+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)
+
+instance forall m x. Monad m => Branching (Consumer m x ()) m x [x] where
+ combineBranches combinator parallel c1 c2
+ = Consumer $
+ liftM (const ())
+ . combinator parallel
+ (\source-> consume c1 source >> return [])
+ (\source-> consume c2 source >> return [])
+
+instance forall m x y. Monad m => Branching (Transducer m x y) m x [x] where
+ combineBranches combinator parallel t1 t2
+ = let transduce' :: forall a1 a2 d. OpenTransducer m a1 a2 d x y
+ transduce' source sink = combinator parallel
+ (\source-> transduce t1 source sink')
+ (\source-> transduce t2 source sink')
+ source
+ where sink' :: Sink m d y
+ sink' = liftSink sink
+ in Transducer transduce'
+
+instance forall m x b. (ParallelizableMonad m) => Branching (Splitter m x b) m x [x] where
+ combineBranches combinator parallel 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
+ (\source-> split s1 source true' false' edge')
+ (\source-> split s2 source true' false' edge')
+ source
+ where true' :: Sink m d x
+ true' = liftSink true
+ false' :: Sink m d x
+ false' = liftSink false
+ edge' :: Sink m d b
+ edge' = liftSink edge
+ in Splitter split'
+
+-- | Function 'oneToOneTransducer' takes a function that maps one input value to one output value each, and lifts it
+-- into a 'Transducer'.
+oneToOneTransducer :: Monad m => (x -> y) -> Transducer m x y
+oneToOneTransducer f = Transducer $
+ \source sink-> let t = canPut sink
+ >>= flip when (getSuccess source (\x-> put sink (f x) >> t))
+ in t >> return []
+
+-- | 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-> let t = canPut sink
+ >>= flip when (getSuccess source (\x-> putList (f x) sink >> t))
+ in t >> return []
+
+-- | Function 'foldingTransducer' creates a stateful transducer that produces only one output value after consuming the
+-- entire input. Similar to 'Data.List.foldl'
+foldingTransducer :: Monad m => (s -> x -> s) -> s -> (s -> y) -> Transducer m x y
+foldingTransducer f s0 w = Transducer $
+ \source sink-> let t s = canPut sink
+ >>= flip when (get source
+ >>= maybe
+ (put sink (w s) >> return ())
+ (t . f s))
+ in t s0 >> return []
+
+-- | Function 'statefulTransducer' constructs a 'Transducer' from a state-transition function and the initial
+-- state. The transition function may produce arbitrary output at any transition step.
+statefulTransducer :: Monad m => (state -> x -> (state, [y])) -> state -> Transducer m x y
+statefulTransducer f s0 = Transducer $
+ \source sink-> let t s = canPut sink
+ >>= flip when (getSuccess source
+ (\x-> let (s', ys) = f s x
+ in putList ys sink >> t s'))
+ in t s0 >> return []
+
+-- | Function 'statelessSplitter' takes a function that assigns a Boolean value to each input item and lifts it into
+-- a 'Splitter'.
+statelessSplitter :: Monad m => (x -> Bool) -> Splitter m x b
+statelessSplitter f = Splitter (\source true false edge->
+ let s = get source
+ >>= maybe
+ (return [])
+ (\x-> (if f x then put true x else put false x)
+ >>= cond s (return [x]))
+ in s)
+
+-- | Function 'statefulSplitter' takes a state-converting function that also assigns a Boolean value to each input
+-- item and lifts it into a 'Splitter'.
+statefulSplitter :: Monad m => (state -> x -> (state, Bool)) -> state -> Splitter m x ()
+statefulSplitter f s0 = Splitter (\source true false edge->
+ let split s = get source
+ >>= maybe
+ (return [])
+ (\x-> let (s', truth) = f s x
+ in (if truth then put true x else put false x)
+ >>= cond (split s') (return [x]))
+ in split s0)
+
+-- | 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 ([x], r1, r2, r3)
+splitToConsumers s source trueConsumer falseConsumer edgeConsumer
+ = pipe
+ (\true-> pipe
+ (\false-> pipe
+ (split s source true false)
+ edgeConsumer)
+ falseConsumer)
+ trueConsumer
+ >>= \(((extra, r3), r2), r1)-> return (extra, r1, r2, r3)
+
+-- | Given a 'Splitter', a 'Source', and two consumer functions, 'splitInputToConsumers' runs the splitter on the source
+-- and feeds the splitter's /true/ and /false/ outputs, respectively, to the two consumers.
+splitInputToConsumers :: forall m a d d1 x b. (ParallelizableMonad 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 [x]) ->
+ (Source m (SourceFunctor d x) x -> Coroutine (SourceFunctor d x) m [x]) ->
+ Coroutine d m [x]
+splitInputToConsumers parallel s source trueConsumer falseConsumer
+ = pipePS parallel
+ (\false-> pipePS parallel
+ (\true-> pipePS parallel
+ (split s source' true false)
+ consumeAndSuppress)
+ trueConsumer)
+ falseConsumer
+ >>= \(((extra, _), xs1), xs2)-> return (prependCommonPrefix xs1 xs2 extra)
+ where prependCommonPrefix (x:xs) (y:ys) tail = x : prependCommonPrefix xs ys tail
+ prependCommonPrefix _ _ tail = tail
+ source' :: Source m d x
+ source' = liftSource source
diff --git a/Control/Concurrent/SCC/XML.hs b/Control/Concurrent/SCC/XML.hs
new file mode 100644
--- /dev/null
+++ b/Control/Concurrent/SCC/XML.hs
@@ -0,0 +1,551 @@
+{-
+ Copyright 2009 Mario Blazevic
+
+ This file is part of the Streaming Component Combinators (SCC) project.
+
+ The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public
+ License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later
+ version.
+
+ SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty
+ of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License along with SCC. If not, see
+ .
+-}
+
+-- | Module "XML" defines primitives and combinators for parsing and manipulating XML.
+
+{-# LANGUAGE PatternGuards, ScopedTypeVariables #-}
+
+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
+)
+where
+
+import Control.Exception (assert)
+import Control.Monad (liftM, when)
+import Data.Char
+import qualified Data.Map as Map
+import Data.Maybe (fromJust, isJust, mapMaybe)
+import Data.List (find, stripPrefix)
+import qualified Data.Sequence as Seq
+import Data.Sequence ((|>))
+import Numeric (readDec, readHex)
+import Debug.Trace (trace)
+
+import Control.Concurrent.Coroutine
+import Control.Concurrent.SCC.Streams
+import Control.Concurrent.SCC.Types
+import Control.Concurrent.SCC.Combinators (groupMarks, splitterToMarker, parseNestedRegions)
+import Control.Concurrent.SCC.Primitives (unparse)
+
+
+data Token = StartTag | EndTag | EmptyTag
+ | ElementName | AttributeName | AttributeValue
+ | EntityReferenceToken | EntityName
+ | ProcessingInstruction | ProcessingInstructionText
+ | Comment | CommentText
+ | StartMarkedSectionCDATA | EndMarkedSection
+ | ErrorToken String
+ deriving (Eq, Show)
+
+
+-- | Escapes a character for inclusion into an XML attribute value.
+escapeAttributeCharacter :: Char -> String
+escapeAttributeCharacter '"' = """
+escapeAttributeCharacter '\t' = " "
+escapeAttributeCharacter '\n' = "
"
+escapeAttributeCharacter '\r' = "
"
+escapeAttributeCharacter x = escapeContentCharacter x
+
+-- | Escapes a character for inclusion into the XML data content.
+escapeContentCharacter :: Char -> String
+escapeContentCharacter '<' = "<"
+escapeContentCharacter '&' = "&"
+escapeContentCharacter x = [x]
+
+-- | Converts an XML entity name into the text value it represents: @expandEntity \"lt\" = \"<\"@.
+expandEntity :: String -> String
+expandEntity "lt" = "<"
+expandEntity "gt" = ">"
+expandEntity "quot" = "\""
+expandEntity "apos" = "'"
+expandEntity "amp" = "&"
+expandEntity ('#' : 'x' : codePoint) = [chr (fst $ head $ readHex codePoint)]
+expandEntity ('#' : codePoint) = [chr (fst $ head $ readDec codePoint)]
+
+isNameStart x = isLetter x || x == '_'
+isNameChar x = isAlphaNum x || x == '_' || x == '-'
+
+-- | The 'tokens' splitter distinguishes XML markup from data content. It is used by 'parseTokens'.
+tokens :: Monad m => Splitter m Char (Boundary Token)
+tokens = Splitter $
+ \source true false edge->
+ let getContent = get source
+ >>= maybe (return []) content
+ content '<' = get source
+ >>= maybe (return "<") (\x-> tag x >> get source >>= maybe (return []) content)
+ content '&' = entity >> next content
+ content x = put false x
+ >>= cond getContent (return [x])
+ tag '?' = put edge (Start ProcessingInstruction)
+ >> putList ">= whenNull (put edge (Start ProcessingInstructionText)
+ >> processingInstruction)
+ tag '!' = dispatchOnString source
+ (\other-> put edge (Point (ErrorToken ("Expecting > return (" put edge (Start Comment)
+ >> putList match true
+ >>= whenNull (put edge (Start CommentText)
+ >> comment)),
+ ("[CDATA[",
+ \match-> put edge (Start StartMarkedSectionCDATA)
+ >> putList match true
+ >>= whenNull (put edge (End StartMarkedSectionCDATA)
+ >> markedSection))]
+ tag '/' = {-# SCC "EndTag" #-}
+ do put edge (Start EndTag)
+ put true '<'
+ put true '/'
+ x <- next (name ElementName)
+ put true x
+ when (x /= '>')
+ (put edge (Point (ErrorToken ("Invalid character " ++ show x ++ " in end tag")))
+ >> return ())
+ put edge (End EndTag)
+ return []
+ tag x | isNameStart x
+ = {-# SCC "StartTag" #-}
+ do put edge (Start StartTag)
+ put true '<'
+ y <- name ElementName x
+ z <- attributes y
+ w <- if z == '/'
+ then put true z >> put edge (Point EmptyTag)
+ >> get source
+ >>= maybe
+ (put edge (Point (ErrorToken ("Missing '>' at the end of start tag.")))
+ >> return '>')
+ return
+ else return z
+ put true w
+ when (w /= '>') (put edge (Point (ErrorToken ("Invalid character " ++ show w
+ ++ " in start tag")))
+ >> return ())
+ put edge (End StartTag)
+ return []
+ tag x = put edge (Point (ErrorToken "Unescaped character '<' in content"))
+ >> put false '<'
+ >> put false x
+ >> return []
+ attributes x | isSpace x = put true x >> next attributes
+ attributes x | isNameStart x
+ = do y <- name AttributeName x
+ when (y /= '=') (put edge (Point (ErrorToken ("Invalid character " ++ show y
+ ++ " following attribute name")))
+ >> return ())
+ q <- if y == '"' || y == '\''
+ then return y
+ else put true y >> get source
+ >>= maybe (put edge (Point (ErrorToken ("Truncated input after attribute name")))
+ >> return '"')
+ return
+ when
+ (q /= '"' && q /= '\'')
+ (put edge (Point (ErrorToken ("Invalid quote character " ++ show q)))
+ >> return ())
+ put true q
+ put edge (Start AttributeValue)
+ next (attributeValue q)
+ next attributes
+ attributes x = return x
+ attributeValue q x | q == x = do put edge (End AttributeValue)
+ put true x
+ attributeValue q '<' = do put edge (Start (ErrorToken "Invalid character '<' in attribute value."))
+ put true '<'
+ put edge (End (ErrorToken "Invalid character '<' in attribute value."))
+ next (attributeValue q)
+ attributeValue q '&' = entity >> next (attributeValue q)
+ attributeValue q x = put true x >> next (attributeValue q)
+ processingInstruction = {-# SCC "PI" #-}
+ dispatchOnString source
+ (\other-> if null other
+ then (put edge (Point (ErrorToken "Unterminated processing instruction"))
+ >> return [])
+ else putList other true >>= whenNull processingInstruction)
+ [("?>",
+ \match-> put edge (End ProcessingInstructionText)
+ >> putList match true
+ >>= whenNull (put edge (End ProcessingInstruction)
+ >> getContent))]
+ comment = {-# SCC "comment" #-}
+ dispatchOnString source
+ (\other-> if null other
+ then (put edge (Point (ErrorToken "Unterminated comment"))
+ >> return [])
+ else putList other true >>= whenNull comment)
+ [("-->",
+ \match-> put edge (End CommentText)
+ >> putList match true
+ >>= whenNull (put edge (End Comment)
+ >> getContent))]
+ markedSection = {-# SCC " if null other
+ then (put edge (Point (ErrorToken "Unterminated marked section"))
+ >> return [])
+ else putList other true >>= whenNull markedSection)
+ [("]]>",
+ \match-> put edge (Start EndMarkedSection)
+ >> putList match true
+ >>= whenNull (put edge (End EndMarkedSection)
+ >> getContent))]
+ entity = do put edge (Start EntityReferenceToken)
+ put true '&'
+ x <- next (name EntityName)
+ when (x /= ';') (put edge (Point (ErrorToken ("Invalid character " ++ show x
+ ++ " ends entity name.")))
+ >> return ())
+ put true x
+ put edge (End EntityReferenceToken)
+ name token x | isNameStart x = {-# SCC "name" #-}
+ do put edge (Start token)
+ put true x
+ next (nameTail token)
+ name _ x = do put edge (Point (ErrorToken ("Invalid character " ++ show x ++ " in attribute value.")))
+ return x
+ nameTail token x = if isNameChar x || x == ':'
+ then put true x >> next (nameTail token)
+ else put edge (End token) >> return x
+ next f = {-# SCC "next" #-} get' source >>= f
+ in getContent
+
+-- | The XML token parser. This parser converts plain text to parsed text, which is a precondition for using the
+-- remaining XML components.
+parseTokens :: Monad m => Parser m Char Token
+parseTokens = parseNestedRegions tokens
+
+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)]
+ -> Coroutine d m r
+dispatchOnString source failure fullCases = dispatch fullCases id
+ where dispatch cases consumed
+ = case find (null . fst) cases
+ of Just ("", rhs) -> rhs (consumed "")
+ Nothing -> get source
+ >>= maybe
+ (failure (consumed ""))
+ (\x-> case mapMaybe (startingWith x) cases
+ of [] -> failure (consumed [x])
+ subcases -> dispatch (subcases ++ fullCases) (consumed . (x :)))
+ startingWith x (y:rest, rhs) | x == y = Just (rest, rhs)
+ | otherwise = Nothing
+
+getElementName :: 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)
+getElementName source f = get source
+ >>= maybe
+ (return (f [], Nothing))
+ (\x-> case x
+ of Markup (Start ElementName) -> getRestOfRegion ElementName source (f . (x:)) id
+ Markup (Point ErrorToken{}) -> getElementName source (f . (x:))
+ Content{} -> getElementName source (f . (x:))
+ _ -> error ("Expected an ElementName, received " ++ show x))
+
+getRestOfRegion :: 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))
+
+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)
+ -> Coroutine d m (Maybe [Markup Token Char])
+pourRestOfRegion token source sink endSink
+ = get source
+ >>= maybe
+ (return $ Just [])
+ (\x-> case x
+ of Markup (End token') | token == token' -> put endSink x
+ >>= cond (return Nothing) (return $ Just [x])
+ Content y -> put sink x
+ >>= cond (pourRestOfRegion token source sink endSink) (return $ Just [x])
+ _ -> error ("Expected rest of " ++ show token ++ ", received " ++ show x))
+
+pourRestOfTag :: 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
+ (return True)
+ (\x-> put sink x
+ >> case x of Markup (End StartTag) -> return True
+ Markup (End EndTag) -> return True
+ Markup (Point EmptyTag) -> pourRestOfTag source sink
+ >> return False
+ _ -> pourRestOfTag source sink)
+
+findEndTag :: 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
+ -> Coroutine d m [Markup Token Char]
+findEndTag source sink endSink name = find where
+ find = get source
+ >>= maybe
+ (return [])
+ (\x-> case x
+ of Markup (Start EndTag) -> do (tokens, mn) <- getElementName source (x :)
+ maybe
+ (return tokens)
+ (\name'-> if name == name'
+ then putList tokens endSink
+ >>= whenNull
+ (pourRestOfTag source endSink
+ >> return [])
+ else putList tokens sink
+ >>= whenNull
+ (pourRestOfTag source sink
+ >> find))
+ mn
+ Markup (Start StartTag) -> do (tokens, mn) <- getElementName source (x :)
+ maybe
+ (return tokens)
+ (\name'-> putList tokens sink
+ >>= whenNull
+ (if name == name'
+ then pourRestOfTag source sink
+ >>= cond
+ (findEndTag source sink sink name)
+ (return [])
+ >>= whenNull find
+ else pourRestOfTag source sink
+ >> find))
+ mn
+ _ -> put sink x
+ >>= cond find (return [x]))
+
+findStartTag :: 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 (Either [Markup Token Char] (Markup Token Char))
+findStartTag source sink = get source
+ >>= maybe
+ (return $ Left [])
+ (\x-> case x of Markup (Start StartTag) -> return $ Right x
+ _ -> put sink x
+ >>= cond (findStartTag source sink) (return $ Left [x]))
+
+-- | Splits all top-level elements with all their content to /true/, all other input to /false/.
+element :: Monad m => Splitter m (Markup Token Char) ()
+element = Splitter $
+ \source true false edge->
+ let split0 = findStartTag source false
+ >>= either return
+ (\x-> put edge ()
+ >> put true x
+ >>= cond
+ (do (tokens, mn) <- getElementName source id
+ maybe
+ (putList tokens true)
+ (\name-> putList tokens true
+ >>= whenNull
+ (pourRestOfTag source true
+ >>= cond
+ (split1 name)
+ split0))
+ mn)
+ (return [x]))
+ split1 name = findEndTag source true true name
+ >>= whenNull split0
+ in split0
+
+-- | Splits the content of all top-level elements to /true/, their tags and intervening input to /false/.
+elementContent :: Monad m => Splitter m (Markup Token Char) ()
+elementContent = Splitter $
+ \source true false edge->
+ let split0 = findStartTag source false
+ >>= either return
+ (\x-> put false x
+ >>= cond
+ (do (tokens, mn) <- getElementName source id
+ maybe
+ (putList tokens false)
+ (\name-> putList tokens false
+ >>= whenNull (pourRestOfTag source false
+ >>= cond
+ (put edge ()
+ >> split1 name)
+ split0))
+ mn)
+ (return [x]))
+ split1 name = findEndTag source true false name
+ >>= whenNull split0
+ in split0
+
+-- | Similiar to @('Control.Concurrent.SCC.Combinators.having' 'element')@, except it runs the argument splitter
+-- only on each element's start tag, not on the entire element with its content.
+elementHavingTag :: forall m b. ParallelizableMonad 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
+ >>= either return
+ (\x-> do (tokens, mn) <- getElementName source (x :)
+ maybe
+ (return tokens)
+ (\name-> do (hasContent, rest) <- pipe
+ (pourRestOfTag source)
+ getList
+ let tag = tokens ++ rest
+ (_, (unconsumed, maybeTrue, (), maybeEdge))
+ <- pipe
+ (putList tag)
+ (\tag-> splitToConsumers
+ test
+ tag
+ get
+ consumeAndSuppress
+ get)
+ if isJust maybeTrue || isJust maybeEdge
+ then maybe (return True) (put edge) maybeEdge
+ >> putList tag true
+ >>= whenNull (split1 hasContent true name)
+ else putList tag false
+ >>= whenNull (split1 hasContent false name))
+ mn)
+ split1 hasContent sink name = if hasContent
+ then findEndTag source sink sink name >>= whenNull split0
+ else split0
+ in 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 = get source
+ >>= maybe
+ (return [])
+ (\x-> case x of Markup (Start AttributeName)
+ -> put edge ()
+ >> put true x
+ >>= cond
+ (pourRestOfRegion AttributeName source true true
+ >>= maybe split1 return)
+ (return [x])
+ _ -> put false x
+ >>= cond split0 (return [x]))
+ split1 = get source
+ >>= maybe
+ (return [])
+ (\x-> case x of Markup (Start AttributeValue)
+ -> put true x
+ >>= cond
+ (pourRestOfRegion AttributeValue source true true
+ >>= maybe split0 return)
+ (return [x])
+ _ -> put true x
+ >>= cond split1 (return [x]))
+ in split0
+
+-- | Splits every element name, including the names of nested elements and names in end tags, to /true/, all the rest of
+-- input to /false/.
+elementName :: Monad m => Splitter m (Markup Token Char) ()
+elementName = 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)
+
+-- | 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)
+
+splitSimpleRegions token source true false edge = split
+ where split = get source
+ >>= maybe
+ (return [])
+ (\x-> case x of Markup (Start token') | token == token'
+ -> put false x
+ >>= cond
+ (put edge ()
+ >> pourRestOfRegion token source true false
+ >>= maybe split return)
+ (return [x])
+ _ -> put false x
+ >>= cond split (return [x]))
+
+-- | Behaves like 'Control.Concurrent.SCC.Combinators.having', but the right-hand splitter works on plain instead of
+-- marked-up text. This allows regular 'Char' splitters to be applied to parsed XML.
+havingText :: forall m b1 b2. ParallelizableMonad m =>
+ Bool -> Splitter m (Markup Token Char) b1 -> Splitter m Char b2 -> Splitter m (Markup Token Char) b1
+havingText parallel chunker tester =
+ isolateSplitter $ \ source true false edge ->
+ let test Nothing chunk = pour chunk false >> return []
+ test (Just mb) chunk = pipe
+ (\sink1-> pipe (tee chunk sink1) getList)
+ (\chunk-> liftM snd $
+ pipe
+ (transduce unparse chunk)
+ (\chunk-> splitToConsumers tester chunk
+ (liftM isJust . get)
+ consumeAndSuppress
+ (liftM isJust . get)))
+ >>= \(((), prefix), (_, anyTrue, (), anyEdge))->
+ if anyTrue || anyEdge
+ then maybe (return True) (put edge) mb
+ >> putList prefix true
+ >>= whenNull (pour chunk true >> return [])
+ else putList prefix false
+ >>= whenNull (pour chunk false >> return [])
+ in 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. ParallelizableMonad m =>
+ Bool -> Splitter m (Markup Token Char) b1 -> Splitter m Char b2 -> Splitter m (Markup Token Char) b1
+havingOnlyText parallel chunker tester =
+ isolateSplitter $ \ source true false edge ->
+ let test Nothing chunk = pour chunk false >> return []
+ test (Just mb) chunk = pipe
+ (\sink1-> pipe (tee chunk sink1) getList)
+ (\chunk-> liftM snd $
+ pipe
+ (transduce unparse chunk)
+ (\chunk-> splitToConsumers tester chunk
+ consumeAndSuppress
+ (liftM isJust . get)
+ consumeAndSuppress))
+ >>= \(((), prefix), (_, (), anyFalse, ()))->
+ if anyFalse
+ then putList prefix false
+ >>= whenNull (pour chunk false >> return [])
+ else maybe (return True) (put edge) mb
+ >> putList prefix true
+ >>= whenNull (pour chunk true >> return [])
+ in liftM fst $
+ pipePS parallel
+ (transduce (splitterToMarker chunker) source)
+ (flip groupMarks test)
diff --git a/Control/Concurrent/SCC/XMLComponents.hs b/Control/Concurrent/SCC/XMLComponents.hs
deleted file mode 100644
--- a/Control/Concurrent/SCC/XMLComponents.hs
+++ /dev/null
@@ -1,528 +0,0 @@
-{-
- Copyright 2009 Mario Blazevic
-
- This file is part of the Streaming Component Combinators (SCC) project.
-
- The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public
- License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later
- version.
-
- SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty
- of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License along with SCC. If not, see
- .
--}
-
--- | Module "XMLComponents" defines primitive components for parsing and manipulating XML.
-
-{-# LANGUAGE DeriveDataTypeable, PatternGuards #-}
-
-module Control.Concurrent.SCC.XMLComponents (
--- * Types
-Token (..),
--- * Parsing XML
-tokens, parseTokens, expandEntity,
--- * Showing XML
-escapeAttributeCharacter, escapeContentCharacter,
--- * Splitters
-element, elementContent, elementName, attribute, attributeName, attributeValue,
--- * Splitter combinators
-elementHavingTag, havingText, havingOnlyText
-)
-where
-
-import Control.Exception (assert)
-import Control.Monad (liftM, when)
-import Data.Char
-import Data.Dynamic (Typeable)
-import qualified Data.Map as Map
-import Data.Maybe (fromJust, isJust, mapMaybe)
-import Data.List (find, stripPrefix)
-import qualified Data.Sequence as Seq
-import Data.Sequence ((|>))
-import Numeric (readDec, readHex)
-import Debug.Trace (trace)
-
-import Control.Concurrent.SCC.Foundation
-import Control.Concurrent.SCC.ComponentTypes
-import Control.Concurrent.SCC.Components (unparse)
-import Control.Concurrent.SCC.Combinators ((>->), groupMarks, having, havingOnly, parseNestedRegions, splitterToMarker)
-
-
-data Token = StartTag | EndTag | EmptyTag
- | ElementName | AttributeName | AttributeValue
- | EntityReferenceToken | EntityName
- | ProcessingInstruction | ProcessingInstructionText
- | Comment | CommentText
- | StartMarkedSectionCDATA | EndMarkedSection
- | ErrorToken String
- deriving (Eq, Show, Typeable)
-
--- | Escapes a character for inclusion into an XML attribute value.
-escapeAttributeCharacter :: Char -> String
-escapeAttributeCharacter '"' = """
-escapeAttributeCharacter '\t' = " "
-escapeAttributeCharacter '\n' = "
"
-escapeAttributeCharacter '\r' = "
"
-escapeAttributeCharacter x = escapeContentCharacter x
-
--- | Escapes a character for inclusion into the XML data content.
-escapeContentCharacter :: Char -> String
-escapeContentCharacter '<' = "<"
-escapeContentCharacter '&' = "&"
-escapeContentCharacter x = [x]
-
--- | Converts an XML entity name into the text value it represents: @expandEntity \"lt\" = \"<\"@.
-expandEntity :: String -> String
-expandEntity "lt" = "<"
-expandEntity "gt" = ">"
-expandEntity "quot" = "\""
-expandEntity "apos" = "'"
-expandEntity "amp" = "&"
-expandEntity ('#' : 'x' : codePoint) = [chr (fst $ head $ readHex codePoint)]
-expandEntity ('#' : codePoint) = [chr (fst $ head $ readDec codePoint)]
-
-isNameStart x = isLetter x || x == '_'
-isNameChar x = isAlphaNum x || x == '_' || x == '-'
-
--- | The 'tokens' splitter distinguishes XML markup from data content. It is used by 'parseTokens'.
-tokens :: (ParallelizableMonad m) => Splitter m Char (Boundary Token)
-tokens = liftAtomicSplitter "XML.tokens" 1 $
- \source true false edge->
- let getContent = get source
- >>= maybe (return []) content
- content '<' = get source
- >>= maybe (return "<") (\x-> tag x >> get source >>= maybe (return []) content)
- content '&' = entity >> next content
- content x = put false x
- >>= cond getContent (return [x])
- tag '?' = put edge (Start ProcessingInstruction)
- >> putList ">= whenNull (put edge (Start ProcessingInstructionText)
- >> processingInstruction)
- tag '!' = dispatchOnString source
- (\other-> put edge (Point (ErrorToken ("Expecting > return (" put edge (Start Comment)
- >> putList match true
- >>= whenNull (put edge (Start CommentText)
- >> comment)),
- ("[CDATA[",
- \match-> put edge (Start StartMarkedSectionCDATA)
- >> putList match true
- >>= whenNull (put edge (End StartMarkedSectionCDATA)
- >> markedSection))]
- tag '/' = {-# SCC "EndTag" #-}
- do put edge (Start EndTag)
- put true '<'
- put true '/'
- x <- next (name ElementName)
- put true x
- when (x /= '>') (put edge (Point (ErrorToken ("Invalid character " ++ show x ++ " in end tag")))
- >> return ())
- put edge (End EndTag)
- return []
- tag x | isNameStart x
- = {-# SCC "StartTag" #-}
- do put edge (Start StartTag)
- put true '<'
- y <- name ElementName x
- z <- attributes y
- w <- if z == '/'
- then put true z >> put edge (Point EmptyTag) >> get' source
- else return z
- put true w
- when (w /= '>') (put edge (Point (ErrorToken ("Invalid character " ++ show w
- ++ " in start tag")))
- >> return ())
- put edge (End StartTag)
- return []
- attributes x | isSpace x = put true x >> next attributes
- attributes x | isNameStart x = do y <- name AttributeName x
- when (y /= '=') (put edge (Point (ErrorToken ("Invalid character " ++ show y
- ++ " following attribute name")))
- >> return ())
- q <- if y == '"' || y == '\'' then return y else put true y >> get' source
- when
- (q /= '"' && q /= '\'')
- (put edge (Point (ErrorToken ("Invalid quote character " ++ show q)))
- >> return ())
- put true q
- put edge (Start AttributeValue)
- next (attributeValue q)
- next attributes
- attributes x = return x
- attributeValue q x | q == x = do put edge (End AttributeValue)
- put true x
- attributeValue q '<' = do put edge (Start (ErrorToken "Invalid character '<' in attribute value."))
- put true '<'
- put edge (End (ErrorToken "Invalid character '<' in attribute value."))
- next (attributeValue q)
- attributeValue q '&' = entity >> next (attributeValue q)
- attributeValue q x = put true x >> next (attributeValue q)
- processingInstruction = {-# SCC "PI" #-}
- dispatchOnString source
- (\other-> if null other
- then (put edge (Point (ErrorToken "Unterminated processing instruction"))
- >> return [])
- else putList other true >>= whenNull processingInstruction)
- [("?>",
- \match-> put edge (End ProcessingInstructionText)
- >> putList match true
- >>= whenNull (put edge (End ProcessingInstruction)
- >> getContent))]
- comment = {-# SCC "comment" #-}
- dispatchOnString source
- (\other-> if null other
- then (put edge (Point (ErrorToken "Unterminated comment"))
- >> return [])
- else putList other true >>= whenNull comment)
- [("-->",
- \match-> put edge (End CommentText)
- >> putList match true
- >>= whenNull (put edge (End Comment)
- >> getContent))]
- markedSection = {-# SCC " if null other
- then (put edge (Point (ErrorToken "Unterminated marked section"))
- >> return [])
- else putList other true >>= whenNull markedSection)
- [("]]>",
- \match-> put edge (Start EndMarkedSection)
- >> putList match true
- >>= whenNull (put edge (End EndMarkedSection)
- >> getContent))]
- entity = do put edge (Start EntityReferenceToken)
- put true '&'
- x <- next (name EntityName)
- when (x /= ';') (put edge (Point (ErrorToken ("Invalid character " ++ show x
- ++ " ends entity name.")))
- >> return ())
- put true x
- put edge (End EntityReferenceToken)
- name token x | isNameStart x = {-# SCC "name" #-}
- do put edge (Start token)
- put true x
- next (nameTail token)
- name _ x = do put edge (Point (ErrorToken ("Invalid character " ++ show x ++ " in attribute value.")))
- return x
- nameTail token x = if isNameChar x || x == ':'
- then put true x >> next (nameTail token)
- else put edge (End token) >> return x
- next f = {-# SCC "next" #-} get' source >>= f
- in getContent
-
--- | The XML token parser. This parser converts plain text to parsed text, which is a precondition for using the
--- remaining XML components.
-parseTokens :: (ParallelizableMonad m) => Parser m Char Token
-parseTokens = parseNestedRegions tokens
-
-dispatchOnString :: Monad m => Source c Char -> (String -> Pipe c m r) -> [(String, String -> Pipe c m r)] -> Pipe c m r
-dispatchOnString source failure fullCases = dispatch fullCases id
- where dispatch cases consumed
- = case find (null . fst) cases
- of Just ("", rhs) -> rhs (consumed "")
- Nothing -> get source
- >>= maybe
- (failure (consumed ""))
- (\x-> case mapMaybe (startingWith x) cases
- of [] -> failure (consumed [x])
- subcases -> dispatch (subcases ++ fullCases) (consumed . (x :)))
- startingWith x (y:rest, rhs) | x == y = Just (rest, rhs)
- | otherwise = Nothing
-
-getElementName :: Monad m => Source c (Markup Char Token) -> ([Markup Char Token] -> [Markup Char Token])
- -> Pipe c m ([Markup Char Token], Maybe String)
-getElementName source f = get source
- >>= maybe
- (return (f [], Nothing))
- (\x-> case x of Markup (Start ElementName) -> getRestOfRegion ElementName source (f . (x:)) id
- Markup (Point ErrorToken{}) -> getElementName source (f . (x:))
- Content{} -> getElementName source (f . (x:))
- _ -> error ("Expected an ElementName, received " ++ show x))
-
-getRestOfRegion :: Monad m => Token -> Source c (Markup Char Token)
- -> ([Markup Char Token] -> [Markup Char Token]) -> (String -> String)
- -> Pipe c m ([Markup Char Token], Maybe String)
-getRestOfRegion token source f g = get source
- >>= maybe
- (return (f [], Nothing))
- (\x-> case x of Markup (End token) -> return (f [x], Just (g ""))
- Content y -> getRestOfRegion token source (f . (x:)) (g . (y:))
- _ -> error ("Expected rest of " ++ show token ++ ", received " ++ show x))
-
-pourRestOfRegion :: Monad m
- => Token -> Source c (Markup Char Token) -> Sink c (Markup Char Token) -> Sink c (Markup Char Token)
- -> Pipe c m (Maybe [Markup Char Token])
-pourRestOfRegion token source sink endSink
- = get source
- >>= maybe
- (return $ Just [])
- (\x-> case x
- of Markup (End token') | token == token' -> put endSink x
- >>= cond (return Nothing) (return $ Just [x])
- Content y -> put sink x
- >>= cond (pourRestOfRegion token source sink endSink) (return $ Just [x])
- _ -> error ("Expected rest of " ++ show token ++ ", received " ++ show x))
-
-pourRestOfTag :: Monad m => Source c (Markup Char Token) -> Sink c (Markup Char Token) -> Pipe c m Bool
-pourRestOfTag source sink = get source
- >>= maybe
- (return True)
- (\x-> put sink x
- >> case x of Markup (End StartTag) -> return True
- Markup (End EndTag) -> return True
- Markup (Point EmptyTag) -> pourRestOfTag source sink >> return False
- _ -> pourRestOfTag source sink)
-
-findEndTag :: Monad m => Source c (Markup Char Token) -> Sink c (Markup Char Token) -> Sink c (Markup Char Token) -> String
- -> Pipe c m [Markup Char Token]
-findEndTag source sink endSink name = find where
- find = get source
- >>= maybe
- (return [])
- (\x-> case x
- of Markup (Start EndTag) -> do (tokens, mn) <- getElementName source (x :)
- maybe
- (return tokens)
- (\name'-> if name == name'
- then putList tokens endSink
- >>= whenNull
- (pourRestOfTag source endSink
- >> return [])
- else putList tokens sink
- >>= whenNull
- (pourRestOfTag source sink
- >> find))
- mn
- Markup (Start StartTag) -> do (tokens, mn) <- getElementName source (x :)
- maybe
- (return tokens)
- (\name'-> putList tokens sink
- >>= whenNull
- (if name == name'
- then pourRestOfTag source sink
- >>= cond
- (findEndTag source sink sink name)
- (return [])
- >>= whenNull find
- else pourRestOfTag source sink
- >> find))
- mn
- _ -> put sink x
- >>= cond find (return [x]))
-
-findStartTag :: Monad m => Source c (Markup Char Token) -> Sink c (Markup Char Token)
- -> Pipe c m (Either [Markup Char Token] (Markup Char Token))
-findStartTag source sink = get source
- >>= maybe
- (return $ Left [])
- (\x-> case x of Markup (Start StartTag) -> return $ Right x
- _ -> put sink x
- >>= cond (findStartTag source sink) (return $ Left [x]))
-
--- | Splits all top-level elements with all their content to /true/, all other input to /false/.
-element :: (Monad m) => Splitter m (Markup Char Token) ()
-element = liftAtomicSplitter "element" 1 $
- \source true false edge->
- let split0 = findStartTag source false
- >>= either return
- (\x-> put edge ()
- >> put true x
- >>= cond
- (do (tokens, mn) <- getElementName source id
- maybe
- (putList tokens true)
- (\name-> putList tokens true
- >>= whenNull
- (pourRestOfTag source true
- >>= cond
- (split1 name)
- split0))
- mn)
- (return [x]))
- split1 name = findEndTag source true true name
- >>= whenNull split0
- in split0
-
--- | Splits the content of all top-level elements to /true/, their tags and intervening input to /false/.
-elementContent :: (Monad m) => Splitter m (Markup Char Token) ()
-elementContent = liftAtomicSplitter "elementContent" 1 $
- \source true false edge->
- let split0 = findStartTag source false
- >>= either return
- (\x-> put false x
- >>= cond
- (do (tokens, mn) <- getElementName source id
- maybe
- (putList tokens false)
- (\name-> putList tokens false
- >>= whenNull (pourRestOfTag source false
- >>= cond
- (put edge ()
- >> split1 name)
- split0))
- mn)
- (return [x]))
- split1 name = findEndTag source true false name
- >>= whenNull split0
- in split0
-
--- | Similiar to @('Control.Concurrent.SCC.Combinators.having' 'element')@, except it runs the argument splitter
--- only on each element's start tag, not on the entire element with its content.
-elementHavingTag :: (ParallelizableMonad m, Typeable b)
- => Splitter m (Markup Char Token) b -> Splitter m (Markup Char Token) b
-elementHavingTag test
- = liftSplitter "elementHavingTag" (maxUsableThreads test) $
- \threads-> let test' = usingThreads threads test
- configuration = ComponentConfiguration [AnyComponent test'] threads (cost test' + 2)
- split source true false edge = split0 where
- split0 = findStartTag source false
- >>= either return
- (\x-> do (tokens, mn) <- getElementName source (x :)
- maybe
- (return tokens)
- (\name-> do (hasContent, rest) <- pipe (pourRestOfTag source) getList
- let tag = tokens ++ rest
- (_, (unconsumed, maybeTrue, (), maybeEdge))
- <- pipe
- (putList tag)
- (\tag-> splitToConsumers
- test'
- tag
- get
- consumeAndSuppress
- get)
- if isJust maybeTrue || isJust maybeEdge
- then maybe (return True) (put edge) maybeEdge
- >> putList tag true
- >>= whenNull (split1 hasContent true name)
- else putList tag false
- >>= whenNull (split1 hasContent false name))
- mn)
- split1 hasContent sink name = if hasContent
- then findEndTag source sink sink name >>= whenNull split0
- else split0
- in (configuration, split)
-
--- | Splits every attribute specification to /true/, everything else to /false/.
-attribute :: (ParallelizableMonad m) => Splitter m (Markup Char Token) ()
-attribute = liftAtomicSplitter "attribute" 1 $
- \source true false edge->
- let split0 = get source
- >>= maybe
- (return [])
- (\x-> case x of Markup (Start AttributeName)
- -> put edge ()
- >> put true x
- >>= cond
- (pourRestOfRegion AttributeName source true true
- >>= maybe split1 return)
- (return [x])
- _ -> put false x
- >>= cond split0 (return [x]))
- split1 = get source
- >>= maybe
- (return [])
- (\x-> case x of Markup (Start AttributeValue)
- -> put true x
- >>= cond
- (pourRestOfRegion AttributeValue source true true
- >>= maybe split0 return)
- (return [x])
- _ -> put true x
- >>= cond split1 (return [x]))
- in split0
-
--- | Splits every element name, including the names of nested elements and names in end tags, to /true/, all the rest of
--- input to /false/.
-elementName :: (ParallelizableMonad m) => Splitter m (Markup Char Token) ()
-elementName = liftAtomicSplitter "elementName" 1 (splitSimpleRegions ElementName)
-
--- | Splits every attribute name to /true/, all the rest of input to /false/.
-attributeName :: (ParallelizableMonad m) => Splitter m (Markup Char Token) ()
-attributeName = liftAtomicSplitter "attributeName" 1 (splitSimpleRegions AttributeName)
-
--- | Splits every attribute value, excluding the quote delimiters, to /true/, all the rest of input to /false/.
-attributeValue :: (ParallelizableMonad m) => Splitter m (Markup Char Token) ()
-attributeValue = liftAtomicSplitter "attributeValue" 1 (splitSimpleRegions AttributeValue)
-
-splitSimpleRegions token source true false edge = split
- where split = get source
- >>= maybe
- (return [])
- (\x-> case x of Markup (Start token') | token == token'
- -> put false x
- >>= cond
- (put edge ()
- >> pourRestOfRegion token source true false
- >>= maybe split return)
- (return [x])
- _ -> put false x
- >>= cond split (return [x]))
-
--- | Behaves like 'Control.Concurrent.SCC.Combinators.having', but the right-hand splitter works on plain instead of
--- marked-up text. This allows regular 'Char' splitters to be applied to parsed XML.
-havingText :: (ParallelizableMonad m, Typeable b1, Typeable b2)
- => Splitter m (Markup Char Token) b1 -> Splitter m Char b2 -> Splitter m (Markup Char Token) b1
-havingText chunker tester
- = liftSplitter "havingText" (maxUsableThreads chunker + maxUsableThreads tester) $
- \threads-> let (configuration, chunker', tester', parallel) = optimalTwoParallelConfigurations threads chunker tester
- split source true false edge
- = liftM fst $
- (if parallel then pipeP else pipe)
- (transduce (splitterToMarker chunker') source)
- (flip groupMarks test)
- where test Nothing chunk = pour chunk false >> return []
- test (Just mb) chunk = pipe
- (\sink1-> pipe (tee chunk sink1) getList)
- (\chunk-> liftM snd $
- pipe
- (transduce unparse chunk)
- (\chunk-> splitToConsumers tester' chunk
- (liftM isJust . get)
- consumeAndSuppress
- (liftM isJust . get)))
- >>= \(((), prefix), (_, anyTrue, (), anyEdge))->
- if anyTrue || anyEdge
- then maybe (return True) (put edge) mb
- >> putList prefix true
- >>= whenNull (pour chunk true >> return [])
- else putList prefix false
- >>= whenNull (pour chunk false >> return [])
- in (configuration, split)
-
--- | Behaves like 'Control.Concurrent.SCC.Combinators.havingOnly', but the right-hand splitter works on plain instead of
--- marked-up text. This allows regular 'Char' splitters to be applied to parsed XML.
-havingOnlyText :: (ParallelizableMonad m, Typeable b1, Typeable b2)
- => Splitter m (Markup Char Token) b1 -> Splitter m Char b2 -> Splitter m (Markup Char Token) b1
-havingOnlyText chunker tester
- = liftSplitter "havingOnlyText" (maxUsableThreads chunker + maxUsableThreads tester) $
- \threads-> let (configuration, chunker', tester', parallel) = optimalTwoParallelConfigurations threads chunker tester
- split source true false edge
- = liftM fst $
- (if parallel then pipeP else pipe)
- (transduce (splitterToMarker chunker') source)
- (flip groupMarks test)
- where test Nothing chunk = pour chunk false >> return []
- test (Just mb) chunk = pipe
- (\sink1-> pipe (tee chunk sink1) getList)
- (\chunk-> liftM snd $
- pipe
- (transduce unparse chunk)
- (\chunk-> splitToConsumers tester' chunk
- consumeAndSuppress
- (liftM isJust . get)
- consumeAndSuppress))
- >>= \(((), prefix), (_, (), anyFalse, ()))->
- if anyFalse
- then putList prefix false
- >>= whenNull (pour chunk false >> return [])
- else maybe (return True) (put edge) mb
- >> putList prefix true
- >>= whenNull (pour chunk true >> return [])
- in (configuration, split)
diff --git a/Makefile b/Makefile
--- a/Makefile
+++ b/Makefile
@@ -1,6 +1,7 @@
Executables=test test-prof shsh shsh-prof
LibraryFiles=$(addprefix Control/Concurrent/SCC/, \
- Foundation.hs ComponentTypes.hs Combinators.hs Components.hs XMLComponents.hs)
+ Streams.hs Types.hs Primitives.hs Combinators.hs Components.hs XML.hs) \
+ Control/Concurrent/Coroutine.hs Control/Concurrent/Configuration.hs
DocumentationFiles=$(LibraryFiles)
OptimizingOptions=-O2 -threaded -hidir obj -odir obj
ProfilingOptions=-prof -auto-all -hidir prof -odir prof
diff --git a/Shell.hs b/Shell.hs
--- a/Shell.hs
+++ b/Shell.hs
@@ -1,5 +1,6 @@
+
{-
- Copyright 2008 Mario Blazevic
+ Copyright 2008-2009 Mario Blazevic
This file is part of the Streaming Component Combinators (SCC) project.
@@ -22,10 +23,10 @@
import Data.List (intersperse, partition)
import Data.Char (isAlphaNum)
import Data.Maybe (fromJust)
-import Data.Typeable (Typeable, Typeable1, Typeable2)
import Control.Concurrent (forkIO)
import Control.Exception (evaluate)
import Control.Monad (liftM, when)
+import Control.Monad.Trans (lift)
import qualified Text.Parsec as Parsec
import qualified Text.Parsec.String as Parsec
import Text.Parsec hiding (count, parse)
@@ -43,16 +44,18 @@
import System.IO (Handle, IOMode (ReadMode, WriteMode, AppendMode), openFile, hClose,
hGetChar, hGetContents, hPutChar, hFlush, hIsEOF, hClose, putChar, isEOF, stdout)
-import Control.Concurrent.SCC.Foundation
-import Control.Concurrent.SCC.ComponentTypes
-import Control.Concurrent.SCC.Combinators hiding ((&&), (||))
-import qualified Control.Concurrent.SCC.Combinators as Combinators
-import Control.Concurrent.SCC.Components
-import qualified Control.Concurrent.SCC.XMLComponents as XML
+import Control.Concurrent.Configuration (Component, atomic, showComponentTree, usingThreads, with)
+import Control.Concurrent.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
data Expression where
-- Compiled expressions
- Compiled :: Component x => TypeTag x -> x -> Expression
+ Compiled :: TypeTag x -> Component x -> Expression
-- Generic expressions
NativeCommand :: String -> Expression
TypeError :: TypeTag x -> TypeTag y -> Expression -> Expression
@@ -63,16 +66,16 @@
ForEach :: Expression -> Expression -> Expression -> Expression
-- Void expressions, i.e. commands
Exit :: Expression
- -- Producer constructs
+ -- ProducerComponent constructs
FromList :: String -> Expression
FileProducer :: String -> Expression
StdInProducer :: Expression
- -- Consumer constructs
+ -- ConsumerComponent constructs
FileConsumer :: String -> Expression
FileAppend :: String -> Expression
Suppress :: Expression
ErrorConsumer :: String -> Expression
- -- Transducer constructs
+ -- TransducerComponent constructs
Select :: Expression -> Expression
While :: Expression -> Expression -> Expression
ExecuteTransducer :: Expression
@@ -83,7 +86,7 @@
Unparse :: Expression
Uppercase :: Expression
ShowTransducer :: Expression
- -- Splitter constructs
+ -- SplitterComponent constructs
EverythingSplitter :: Expression
NothingSplitter :: Expression
WhitespaceSplitter :: Expression
@@ -112,7 +115,7 @@
Substitute :: Expression -> Expression
StartOf :: Expression -> Expression
EndOf :: Expression -> Expression
- -- XML Components
+ -- XML PrimitiveComponents
XMLTokenParser :: Expression
XMLAttribute :: Expression
XMLAttributeName :: Expression
@@ -128,7 +131,8 @@
showsPrec _ (Compiled tag c) rest = "compiled " ++ shows tag rest
showsPrec _ (NativeCommand cmd) rest = "native \"" ++ cmd ++ "\"" ++ rest
showsPrec p (Pipe left right) rest | p < 3 = showsPrec 3 left (" | " ++ showsPrec 2 right rest)
- showsPrec _ (If s t f) rest = "if " ++ showsPrec 0 s (" then " ++ showsPrec 0 t (" else " ++ showsPrec 0 f (" end if" ++ rest)))
+ showsPrec _ (If s t f) rest
+ = "if " ++ showsPrec 0 s (" then " ++ showsPrec 0 t (" else " ++ showsPrec 0 f (" end if" ++ rest)))
showsPrec _ (ForEach s t f) rest = "foreach " ++ showsPrec 0 s (" then " ++ showsPrec 0 t
(" else " ++ showsPrec 0 f (" end foreach" ++ rest)))
showsPrec _ Exit rest = "Exit" ++ rest
@@ -200,23 +204,24 @@
-- Data type tags
AnyTag :: TypeTag ()
UnitTag :: TypeTag ()
- ShowableTag :: (Typeable x, Show x) => TypeTag x
+ ShowableTag :: Show x => TypeTag x
CharTag :: TypeTag Char
IntTag :: TypeTag Integer
XMLTokenTag :: TypeTag XML.Token
EitherTag :: TypeTag x -> TypeTag y -> TypeTag (Either x y)
- ListTag :: Typeable x => TypeTag x -> TypeTag [x]
- MaybeTag :: Typeable x => TypeTag x -> TypeTag (Maybe x)
+ ListTag :: TypeTag x -> TypeTag [x]
+ MaybeTag :: TypeTag x -> TypeTag (Maybe x)
PairTag :: TypeTag x -> TypeTag y -> TypeTag (x, y)
- MarkupTag :: (Typeable x, Typeable y) => TypeTag x -> TypeTag y -> TypeTag (Markup x y)
+ MarkupTag :: TypeTag x -> TypeTag y -> TypeTag (Markup x y)
-- Streaming component type tags
+ ComponentTag :: TypeTag x -> TypeTag (Component x)
CommandTag :: TypeTag (Performer IO ())
- ConsumerTag :: Typeable x => TypeTag x -> TypeTag (Consumer IO x ())
- ProducerTag :: Typeable x => TypeTag x -> TypeTag (Producer IO x ())
- SplitterTag :: forall x b. (Typeable x, Typeable b) => TypeTag x -> TypeTag b -> TypeTag (Splitter IO x b)
- TransducerTag :: (Typeable x, Typeable y) => TypeTag x -> TypeTag y -> TypeTag (Transducer IO x y)
- GenericInputTag :: forall x y. (Typeable x, Typeable y) => (TypeTag x -> TypeTag y) -> TypeTag y
+ ConsumerTag :: TypeTag x -> TypeTag (Consumer IO x ())
+ ProducerTag :: TypeTag x -> TypeTag (Producer IO x ())
+ SplitterTag :: forall x b. TypeTag x -> TypeTag b -> TypeTag (Splitter IO x b)
+ TransducerTag :: TypeTag x -> TypeTag y -> TypeTag (Transducer IO x y)
+ GenericInputTag :: (TypeTag x -> TypeTag y) -> TypeTag y
instance Show (TypeTag x) where
show AnyTag = "Any"
@@ -229,6 +234,7 @@
show (EitherTag x y) = "Either " ++ shows x (" " ++ show y)
show (MarkupTag x y) = "Markup " ++ shows x (" " ++ show y)
show (PairTag x y) = "(" ++ shows x (", " ++ shows y ")")
+ show (ComponentTag c) = show c
show CommandTag = "Command"
show (ConsumerTag x) = "Consumer " ++ show x
show (ProducerTag x) = "Producer " ++ show x
@@ -240,6 +246,7 @@
data CConsumer c x = CConsumer (c (Consumer IO x ()))
data CProducer c x = CProducer (c (Producer IO x ()))
+data CComponent c x = CComponent (c (Component x))
data CList c a = CList (c [a])
data CMaybe c a = CMaybe (c (Maybe a))
@@ -277,6 +284,8 @@
h = (typecast rb rb' :: (CR c a0') b0 -> Maybe ((CR c a0') b0'))
in case g (CL x) of Just (CL x') -> case h (CR x') of Just (CR y') -> Just y'
Nothing -> Nothing
+
+typecast (ComponentTag a) (ComponentTag b) x = fmap (\(CComponent y)-> y) (typecast a b (CComponent x))
typecast CommandTag CommandTag x = Just x
typecast (ConsumerTag a) (ConsumerTag b) x = fmap (\(CConsumer y)-> y) (typecast a b (CConsumer x))
typecast (ProducerTag a) (ProducerTag b) x = fmap (\(CProducer y)-> y) (typecast a b (CProducer x))
@@ -298,6 +307,10 @@
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)
+
data Flag = Command | Help | Interactive | PrettyPrint | ScriptFile String | StandardInput | Threads String
deriving Eq
@@ -347,8 +360,9 @@
prettyprint options expression = print expression
>> case compile UnitTag expression
- of Compiled tag component -> putStrLn "::" >> print tag
- >> putStrLn (showComponentTree $ adjust options component)
+ of Compiled tag component ->
+ putStrLn "::" >> print tag
+ >> putStrLn (showComponentTree $ adjust options component)
e@TypeError{} -> print e
showHelp = putStrLn (usageInfo usageSyntax flagList)
@@ -372,45 +386,48 @@
>> return False
execute :: Flags -> Expression -> IO ()
-execute options (Compiled CommandTag command) = runPipes (perform $ adjust options command)
-execute options (Compiled (ProducerTag CharTag) producer) = liftM fst (runPipes (pipe (produce $ adjust options producer)
- (consume toStdOut)))
- >> hFlush stdout
-execute options (Compiled tag _) = hPutStrLn stderr ("Expecting a command or a Producer Char, received a " ++ show tag)
+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)
-adjust Flags{threadCount= Just threads} component = usingThreads threads component
+adjust Flags{threadCount= Just threads} component = usingThreads component threads
adjust _ component = component
-compile :: Typeable x => TypeTag x -> Expression -> Expression
+compile :: TypeTag x -> Expression -> Expression
compile inputTag e@Compiled{} = e
compile inputTag e@TypeError{} = e
compile inputTag (Pipe left right)
= case compile inputTag left
of Compiled tag@(ProducerTag tag1) p
-> case compile tag1 right
- of Compiled (ConsumerTag tag2) c -> trycast tag (ProducerTag tag2) p left $ \p'-> Compiled CommandTag (p' >-> c)
- Compiled (TransducerTag tag2 tag3) t -> trycast tag (ProducerTag tag2) p left $
+ of Compiled (ConsumerTag tag2) c -> tryComponentCast tag (ProducerTag tag2) p left $
+ \p'-> Compiled CommandTag (p' >-> c)
+ Compiled (TransducerTag tag2 tag3) t -> tryComponentCast tag (ProducerTag tag2) p left $
\p'-> Compiled (ProducerTag tag3) (p' >-> t)
e@TypeError{} -> e
Compiled (TransducerTag tag1 tag2) t
-> case compile tag2 right
- of Compiled tag3@ConsumerTag{} c -> trycast tag3 (ConsumerTag tag2) c right $
+ of Compiled tag3@ConsumerTag{} c -> tryComponentCast tag3 (ConsumerTag tag2) c right $
\c'-> Compiled (ConsumerTag tag1) (t >-> c')
- Compiled tag@(TransducerTag tag3 tag4) t2 -> trycast tag (TransducerTag tag2 tag4) t2 right $
+ Compiled tag@(TransducerTag tag3 tag4) t2 -> tryComponentCast tag (TransducerTag tag2 tag4) t2 right $
\t2'-> Compiled (TransducerTag tag1 tag4) (t >-> t2')
e@TypeError{} -> e
Compiled tag _ -> TypeError tag (TransducerTag tag2 AnyTag) right
Compiled tag _ -> TypeError tag (ProducerTag AnyTag) left
e@TypeError{} -> e
compile UnitTag (NativeCommand command)
- = Compiled (ProducerTag CharTag) (liftAtomicProducer command ioCost $
- \sink-> do (Nothing, Just stdout, Nothing, pid)
- <- liftPipe (Process.createProcess
- (Process.shell command){Process.std_out= Process.CreatePipe})
- produce (fromHandle stdout True) sink)
+ = Compiled (ProducerTag CharTag) $
+ 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
compile UnitTag (FileProducer path) = Compiled (ProducerTag CharTag) (fromFile path)
compile UnitTag StdInProducer = Compiled (ProducerTag CharTag) fromStdIn
-compile inputTag (FromList string) = Compiled (ProducerTag CharTag) (liftAtomicProducer "putList" 1 $
+compile inputTag (FromList string) = Compiled (ProducerTag CharTag) (atomic "putList" 1 $ Producer $
\sink-> putList string sink >> return ())
compile inputTag (FileConsumer path) = Compiled (ConsumerTag CharTag) (toFile path)
compile inputTag (FileAppend path) = Compiled (ConsumerTag CharTag) (appendFile path)
@@ -420,34 +437,38 @@
compile inputTag (Join e1 e2) = compileJoin join inputTag e1 e2
compile inputTag (ForEach splitter true false) = combineSplitterAndBranches foreach inputTag splitter true false
compile inputTag (If splitter true false) = combineSplitterAndBranches ifs inputTag splitter true false
-compile inputTag (NativeCommand command) = Compiled (TransducerTag CharTag CharTag) (liftAtomicTransducer command ioCost f)
+compile inputTag (NativeCommand command) = Compiled (TransducerTag CharTag CharTag)
+ (atomic command ioCost $ Transducer f)
where f source sink = do (Just stdin, Just stdout, Nothing, pid)
- <- liftPipe (Process.createProcess (Process.shell command){Process.std_in= Process.CreatePipe,
- Process.std_out= Process.CreatePipe})
- liftPipe (hSetBuffering stdin NoBuffering
- >> hSetBuffering stdout NoBuffering)
+ <- lift (Process.createProcess
+ (Process.shell command){Process.std_in= Process.CreatePipe,
+ Process.std_out= Process.CreatePipe})
+ lift (hSetBuffering stdin NoBuffering
+ >> hSetBuffering stdout NoBuffering)
interleave source stdin pid stdout sink
return []
- interleave :: forall c. Source c Char -> Handle -> Process.ProcessHandle -> Handle -> Sink c Char -> Pipe c IO ()
+ interleave :: forall a1 a2 d. (AncestorFunctor a1 d, AncestorFunctor a2 d) =>
+ Source IO a1 Char -> Handle -> Process.ProcessHandle -> Handle -> Sink IO a2 Char
+ -> Coroutine d IO ()
interleave source stdin pid stdout sink = interleave1
where interleave1 = get source
>>= maybe
- (liftPipe (hClose stdin) >> interleaveEnd)
- (\x-> liftPipe (Process.getProcessExitCode pid)
- >>= maybe
- (liftPipe (hPutChar stdin x) >> interleave2)
- (const interleave2))
+ (lift (hClose stdin) >> interleaveEnd)
+ (\x-> lift (Process.getProcessExitCode pid)
+ >>= maybe
+ (lift (hPutChar stdin x) >> interleave2)
+ (const interleave2))
interleave2 = canPut sink
- >>= flip when (liftPipe (hReady stdout)
- >>= flip when (liftPipe (hGetChar stdout)
+ >>= flip when (lift (hReady stdout)
+ >>= flip when (lift (hGetChar stdout)
>>= put sink
>> return ())
>> interleave1)
interleaveEnd = canPut sink
- >>= flip when (liftPipe (hIsEOF stdout)
+ >>= flip when (lift (hIsEOF stdout)
>>= cond
- (liftPipe $ hClose stdout)
- (liftPipe (hGetChar stdout)
+ (lift $ hClose stdout)
+ (lift (hGetChar stdout)
>>= put sink
>> interleaveEnd))
compile inputTag (Select e) = case compile inputTag e
@@ -458,7 +479,7 @@
= case (compile inputTag condition, compile inputTag body)
of (Compiled (SplitterTag tag1 _) s, Compiled tag2@TransducerTag{} t)
-> let tag2' = TransducerTag tag1 tag1
- in trycast tag2 tag2' t body (\t'-> Compiled tag2' (while t' s))
+ in tryComponentCast tag2 tag2' t body (\t'-> Compiled tag2' (while t' s))
compile inputTag (FollowedBy left right) = combineSplitters followedBy inputTag PairTag left right
compile inputTag (And left right) = combineSplitters (>&) inputTag PairTag left right
compile inputTag (Or left right) = combineSplitters (>|) inputTag EitherTag left right
@@ -479,12 +500,14 @@
compile inputTag (Append suffix) = wrapProducerIntoTransducer append inputTag suffix
compile inputTag (Substitute replacement) = wrapGenericProducerIntoTransducer substitute inputTag replacement
compile inputTag ExecuteTransducer
- = Compiled (TransducerTag CharTag CharTag) (liftAtomicTransducer "execute" ioCost execute)
- where execute source sink = do ((), command) <- pipe (pour source) getList
+ = Compiled (TransducerTag CharTag CharTag) (atomic "execute" ioCost $ Transducer execute)
+ where execute :: forall a1 a2 d. OpenTransducer IO a1 a2 d Char Char
+ execute source sink = do let (source' :: Source IO d Char) = liftSource source
+ ((), command) <- pipe (pour source') getList
(Nothing, Just stdout, Nothing, pid)
- <- liftPipe (Process.createProcess
- (Process.shell command){Process.std_out= Process.CreatePipe})
- produce (fromHandle stdout True) sink
+ <- lift (Process.createProcess
+ (Process.shell command){Process.std_out= Process.CreatePipe})
+ produce (with $ fromHandle stdout True) sink
return []
compile inputTag IdentityTransducer = Compiled (TransducerTag inputTag inputTag) asis
@@ -492,14 +515,15 @@
compile inputTag@(ListTag itemTag) Concatenate = Compiled (TransducerTag inputTag itemTag) concatenate
compile inputTag Concatenate = TypeError inputTag (ListTag AnyTag) Concatenate
compile inputTag Group = Compiled (TransducerTag inputTag (ListTag inputTag)) group
-compile t@(MarkupTag t1 t2) Unparse = Compiled (TransducerTag t t1) unparse
+compile t@(MarkupTag t1 t2) Unparse = Compiled (TransducerTag t t2) unparse
compile inputTag Unparse
= TypeError (TransducerTag (MarkupTag AnyTag AnyTag) AnyTag) (TransducerTag inputTag AnyTag) Unparse
compile CharTag Uppercase = Compiled (TransducerTag CharTag CharTag) uppercase
compile inputTag Uppercase = TypeError (TransducerTag CharTag CharTag) (TransducerTag inputTag AnyTag) Uppercase
compile inputTag@CharTag ShowTransducer = Compiled (TransducerTag inputTag (ListTag CharTag)) toString
compile inputTag@IntTag ShowTransducer = Compiled (TransducerTag inputTag (ListTag CharTag)) toString
-compile inputTag@(MarkupTag CharTag XMLTokenTag) ShowTransducer = Compiled (TransducerTag inputTag (ListTag CharTag)) toString
+compile inputTag@(MarkupTag XMLTokenTag CharTag) ShowTransducer
+ = Compiled (TransducerTag inputTag (ListTag CharTag)) toString
compile inputTag ShowTransducer
= TypeError (TransducerTag IntTag (ListTag CharTag)) (TransducerTag inputTag AnyTag) ShowTransducer
{-
@@ -517,64 +541,62 @@
compile inputTag OneSplitter = Compiled (SplitterTag inputTag UnitTag) one
compile CharTag (SubstringSplitter part) = Compiled (SplitterTag CharTag UnitTag) (substring part)
compile inputTag e@SubstringSplitter{} = TypeError (SplitterTag CharTag UnitTag) (SplitterTag inputTag UnitTag) e
-compile CharTag XMLTokenParser = Compiled (TransducerTag CharTag (MarkupTag CharTag XMLTokenTag)) XML.parseTokens
-compile t@(MarkupTag CharTag XMLTokenTag) XMLElement = Compiled (SplitterTag t UnitTag) (XML.element)
-compile t@(MarkupTag CharTag XMLTokenTag) XMLAttribute = Compiled (SplitterTag t UnitTag) (XML.attribute)
-compile t@(MarkupTag CharTag XMLTokenTag) XMLAttributeName = Compiled (SplitterTag t UnitTag) (XML.attributeName)
-compile t@(MarkupTag CharTag XMLTokenTag) XMLAttributeValue = Compiled (SplitterTag t UnitTag) (XML.attributeValue)
-compile t@(MarkupTag CharTag XMLTokenTag) XMLElementContent = Compiled (SplitterTag t UnitTag) XML.elementContent
-compile t@(MarkupTag CharTag XMLTokenTag) XMLElementName = Compiled (SplitterTag t UnitTag) XML.elementName
-compile t@(MarkupTag CharTag XMLTokenTag) (XMLElementHavingTag s) = wrapConcreteSplitter XML.elementHavingTag t s
-compile t@(MarkupTag CharTag XMLTokenTag) (XMLHavingText left right)
- = combineSplittersOfDifferentTypes XML.havingText t CharTag left right
-compile t@(MarkupTag CharTag XMLTokenTag) (XMLHavingOnlyText left right)
- = combineSplittersOfDifferentTypes XML.havingOnlyText t CharTag left right
+compile 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 expression = error ("Cannot compile " ++ show expression ++ " with input " ++ show inputTag)
-compileJoin :: forall t. Typeable t =>
- (forall t1 t2 t3 m x y c1 c2 c3. JoinableComponentPair t1 t2 t3 m x y c1 c2 c3 => c1 -> c2 -> c3)
+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
-compileJoin combinator inputTag e1 e2 = case (compile inputTag e1, compile inputTag e2)
- of (Compiled CommandTag c1, Compiled CommandTag c2)
- -> Compiled CommandTag (combinator c1 c2)
- (Compiled tag1@ProducerTag{} p1, Compiled tag2@ProducerTag{} p2)
- -> trycast tag2 tag1 p2 e2 (\p2'-> Compiled tag1 (combinator p1 p2'))
- (Compiled tag1@ConsumerTag{} c1, Compiled tag2@ConsumerTag{} c2)
- -> trycast tag2 tag1 c2 e2 (\c2'-> Compiled tag1 (combinator c1 c2'))
- (Compiled tag1@TransducerTag{} t1, Compiled tag2@TransducerTag{} t2)
- -> trycast tag2 tag1 t2 e2 (\t2'-> Compiled tag1 (combinator t1 t2'))
- (Compiled CommandTag c, Compiled tag@ProducerTag{} p) -> Compiled tag (combinator c p)
- (Compiled tag@ProducerTag{} p, Compiled CommandTag c) -> Compiled tag (combinator p c)
- (Compiled CommandTag c1, Compiled tag@ConsumerTag{} c2)
- -> Compiled tag (combinator c1 c2)
- (Compiled tag@ConsumerTag{} c1, Compiled CommandTag c2)
- -> Compiled tag (combinator c1 c2)
- (Compiled CommandTag c, Compiled tag@TransducerTag{} t) -> Compiled tag (combinator c t)
- (Compiled tag@TransducerTag{} t, Compiled CommandTag c) -> Compiled tag (combinator t c)
- (Compiled (ProducerTag tag1) p, Compiled (ConsumerTag tag2) c)
- -> Compiled (TransducerTag tag2 tag1) (combinator p c)
- (Compiled (ConsumerTag tag1) p, Compiled (ProducerTag tag2) c)
- -> Compiled (TransducerTag tag1 tag2) (combinator p c)
- (Compiled (ProducerTag tag1) p, Compiled tag@(TransducerTag tag2 tag3) t)
- -> let tag' = TransducerTag tag2 tag1
- in trycast tag tag' t e2 (\t'-> Compiled tag' (combinator p t'))
- (Compiled tag@(TransducerTag tag1 tag2) t, Compiled tag3@ProducerTag{} p)
- -> let tag' = TransducerTag tag2 tag1
- in trycast tag3 (ProducerTag tag2) p e2 (\p'-> Compiled tag (combinator t p'))
- (Compiled (ConsumerTag tag1) c, Compiled tag@(TransducerTag tag2 tag3) t)
- -> let tag' = TransducerTag tag1 tag3
- in trycast tag tag' t e2 (\t'-> Compiled tag' (combinator c t'))
- (Compiled tag@(TransducerTag tag1 tag2) t, Compiled tag3@ConsumerTag{} c)
- -> let tag' = TransducerTag tag2 tag1
- in trycast tag3 (ConsumerTag tag1) c e2 (\c'-> Compiled tag (combinator t c'))
- (e@TypeError{}, _) -> e
- (_, e@TypeError{}) -> e
- (Compiled tag@SplitterTag{} _, _) -> TypeError tag (ProducerTag AnyTag) e1
- (_, Compiled tag@SplitterTag{} _) -> TypeError tag (ProducerTag AnyTag) e2
+compileJoin combinator inputTag e1 e2
+ = case (compile inputTag e1, compile inputTag e2)
+ of (Compiled CommandTag c1, Compiled CommandTag c2) -> Compiled CommandTag (combinator c1 c2)
+ (Compiled tag1@ProducerTag{} p1, Compiled tag2@ProducerTag{} p2)
+ -> tryComponentCast tag2 tag1 p2 e2 (\p2'-> Compiled tag1 (combinator p1 p2'))
+ (Compiled tag1@ConsumerTag{} c1, Compiled tag2@ConsumerTag{} c2)
+ -> tryComponentCast tag2 tag1 c2 e2 (\c2'-> Compiled tag1 (combinator c1 c2'))
+ (Compiled tag1@TransducerTag{} t1, Compiled tag2@TransducerTag{} t2)
+ -> tryComponentCast tag2 tag1 t2 e2 (\t2'-> Compiled tag1 (combinator t1 t2'))
+ (Compiled CommandTag c, Compiled tag@ProducerTag{} p) -> Compiled tag (combinator c p)
+ (Compiled tag@ProducerTag{} p, Compiled CommandTag c) -> Compiled tag (combinator p c)
+ (Compiled CommandTag c1, Compiled tag@ConsumerTag{} c2) -> Compiled tag (combinator c1 c2)
+ (Compiled tag@ConsumerTag{} c1, Compiled CommandTag c2) -> Compiled tag (combinator c1 c2)
+ (Compiled CommandTag c, Compiled tag@TransducerTag{} t) -> Compiled tag (combinator c t)
+ (Compiled tag@TransducerTag{} t, Compiled CommandTag c) -> Compiled tag (combinator t c)
+ (Compiled (ProducerTag tag1) p, Compiled (ConsumerTag tag2) c)
+ -> Compiled (TransducerTag tag2 tag1) (combinator p c)
+ (Compiled (ConsumerTag tag1) p, Compiled (ProducerTag tag2) c)
+ -> Compiled (TransducerTag tag1 tag2) (combinator p c)
+ (Compiled (ProducerTag tag1) p, Compiled tag@(TransducerTag tag2 tag3) t)
+ -> let tag' = TransducerTag tag2 tag1
+ in tryComponentCast tag tag' t e2 (\t'-> Compiled tag' (combinator p t'))
+ (Compiled tag@(TransducerTag tag1 tag2) t, Compiled tag3@ProducerTag{} p)
+ -> let tag' = TransducerTag tag2 tag1
+ in tryComponentCast tag3 (ProducerTag tag2) p e2 (\p'-> Compiled tag (combinator t p'))
+ (Compiled (ConsumerTag tag1) c, Compiled tag@(TransducerTag tag2 tag3) t)
+ -> let tag' = TransducerTag tag1 tag3
+ in tryComponentCast tag tag' t e2 (\t'-> Compiled tag' (combinator c t'))
+ (Compiled tag@(TransducerTag tag1 tag2) t, Compiled tag3@ConsumerTag{} c)
+ -> let tag' = TransducerTag tag2 tag1
+ in tryComponentCast tag3 (ConsumerTag tag1) c e2 (\c'-> Compiled tag (combinator t c'))
+ (e@TypeError{}, _) -> e
+ (_, e@TypeError{}) -> e
+ (Compiled tag@SplitterTag{} _, _) -> TypeError tag (ProducerTag AnyTag) e1
+ (_, Compiled tag@SplitterTag{} _) -> TypeError tag (ProducerTag AnyTag) e2
-wrapSplitter :: forall x. (Typeable x) =>
- (forall x b. (Typeable x, Typeable b) => Splitter IO x b -> Splitter IO x b) ->
+wrapSplitter :: forall x.
+ (forall x b. SplitterComponent IO x b -> SplitterComponent IO x b) ->
TypeTag x -> Expression -> Expression
wrapSplitter combinator inputTag expression
= case compile inputTag expression
@@ -582,146 +604,147 @@
Compiled tag _ -> TypeError tag (SplitterTag inputTag AnyTag) expression
e@TypeError{} -> e
-wrapConcreteSplitter :: forall x. (Typeable x) =>
- (forall b. (Typeable b) => Splitter IO x b -> Splitter IO x b) ->
+wrapConcreteSplitter :: forall x.
+ (forall b. SplitterComponent IO x b -> SplitterComponent IO x b) ->
TypeTag x -> Expression -> Expression
wrapConcreteSplitter combinator inputTag expression
= case compile inputTag expression
- of Compiled tag@(SplitterTag tx tb) splitter -> trycast tag (SplitterTag inputTag tb) splitter expression $
- \s'-> Compiled (SplitterTag inputTag tb) (combinator s')
+ of Compiled tag@(SplitterTag tx tb) splitter ->
+ tryComponentCast tag (SplitterTag inputTag tb) splitter expression $
+ \s'-> Compiled (SplitterTag inputTag tb) (combinator s')
Compiled tag _ -> TypeError tag (SplitterTag inputTag AnyTag) expression
e@TypeError{} -> e
-wrapConcreteSplitter' :: forall x y. (Typeable x, Typeable y) =>
- (forall b. (Typeable b) => Splitter IO x b -> Splitter IO y ()) ->
+wrapConcreteSplitter' :: forall x y.
+ (forall b. SplitterComponent IO x b -> SplitterComponent IO y ()) ->
TypeTag x -> TypeTag y -> Expression -> Expression
wrapConcreteSplitter' combinator inputTag outputTag expression
= case compile inputTag expression
- of Compiled tag@(SplitterTag tx tb) splitter -> trycast tag (SplitterTag inputTag tb) splitter expression $
- \s'-> Compiled (SplitterTag outputTag UnitTag) (combinator s')
+ of Compiled tag@(SplitterTag tx tb) splitter ->
+ tryComponentCast tag (SplitterTag inputTag tb) splitter expression $
+ \s'-> Compiled (SplitterTag outputTag UnitTag) (combinator s')
Compiled tag _ -> TypeError tag (SplitterTag inputTag AnyTag) expression
e@TypeError{} -> e
-wrapSplitter' :: forall x c. (Typeable x, Typeable1 c) =>
- (forall x b. (Typeable x, Typeable b) => Splitter IO x b -> Splitter IO x (c b)) ->
- TypeTag x -> (forall b. Typeable b => TypeTag b -> TypeTag (c b)) -> Expression -> Expression
+wrapSplitter' :: forall x c.
+ (forall x b. SplitterComponent IO x b -> SplitterComponent IO x (c b)) ->
+ TypeTag x -> (forall b. TypeTag b -> TypeTag (c b)) -> Expression -> Expression
wrapSplitter' combinator inputTag constructor expression
= case compile inputTag expression
of Compiled tag@(SplitterTag tx tb) splitter -> Compiled (SplitterTag tx (constructor tb)) (combinator splitter)
Compiled tag _ -> TypeError tag (SplitterTag inputTag AnyTag) expression
e@TypeError{} -> e
-wrapProducerIntoTransducer :: forall x. Typeable x =>
- (Producer IO x () -> Transducer IO x x) -> TypeTag x -> Expression -> Expression
+wrapProducerIntoTransducer :: forall x.
+ (ProducerComponent IO x () -> TransducerComponent IO x x) -> TypeTag x -> Expression -> Expression
wrapProducerIntoTransducer combinator inputTag expression
= case compile inputTag expression
of Compiled tag@ProducerTag{} p
- -> trycast tag (ProducerTag inputTag) p expression (\p'-> Compiled (TransducerTag inputTag inputTag) (combinator p'))
+ -> tryComponentCast tag (ProducerTag inputTag) p expression $
+ \p'-> Compiled (TransducerTag inputTag inputTag) (combinator p')
Compiled tag _ -> TypeError tag (ProducerTag inputTag) expression
e@TypeError{} -> e
-wrapGenericProducerIntoTransducer :: forall x. Typeable x =>
- (forall y r. Typeable y => Producer IO y r -> Transducer IO x y)
+wrapGenericProducerIntoTransducer :: forall x.
+ (forall y r. ProducerComponent IO y r -> TransducerComponent IO x y)
-> TypeTag x -> Expression -> Expression
wrapGenericProducerIntoTransducer combinator inputTag expression
- = case compile inputTag expression of Compiled (ProducerTag outTag) p -> Compiled (TransducerTag inputTag outTag) (combinator p)
- Compiled tag _ -> TypeError tag (ProducerTag inputTag) expression
- e@TypeError{} -> e
+ = case compile inputTag expression
+ of Compiled (ProducerTag outTag) p -> Compiled (TransducerTag inputTag outTag) (combinator p)
+ Compiled tag _ -> TypeError tag (ProducerTag inputTag) expression
+ e@TypeError{} -> e
-combineSplitters :: forall x c. (Typeable x, Typeable2 c) =>
- (forall x b1 b2. (Typeable x, Typeable b1, Typeable b2)
- => Splitter IO x b1 -> Splitter IO x b2 -> Splitter IO x (c b1 b2))
- -> TypeTag x -> (forall b1 b2. (Typeable b1, Typeable b2) => TypeTag b1 -> TypeTag b2 -> TypeTag (c b1 b2))
+combineSplitters :: forall x c.
+ (forall x b1 b2. SplitterComponent IO x b1 -> SplitterComponent IO x b2 -> SplitterComponent IO x (c b1 b2))
+ -> TypeTag x -> (forall b1 b2. TypeTag b1 -> TypeTag b2 -> TypeTag (c b1 b2))
-> Expression -> Expression -> Expression
combineSplitters combinator inputTag constructor left right
= case (compile inputTag left, compile inputTag right)
of (Compiled tag1@(SplitterTag x1 b1) s1, Compiled tag2@(SplitterTag x2 b2) s2)
- -> trycast tag2 (SplitterTag x1 b2) s2 right $
+ -> tryComponentCast tag2 (SplitterTag x1 b2) s2 right $
\s2'-> Compiled (SplitterTag x1 (constructor b1 b2)) (combinator s1 s2')
(e@TypeError{}, _) -> e
(_, e@TypeError{}) -> e
(Compiled tag1 _, Compiled tag2@SplitterTag{} _) -> TypeError tag1 tag2 left
(Compiled tag1@SplitterTag{} _, Compiled tag2 _) -> TypeError tag2 tag1 right
-combineSplittersOfSameType :: forall x. Typeable x =>
- (forall x b. (Typeable x, Typeable b) => Splitter IO x b -> Splitter IO x b -> Splitter IO x b)
- -> TypeTag x -> Expression -> Expression -> Expression
+combineSplittersOfSameType :: forall x.
+ (forall x b. SplitterComponent IO x b -> SplitterComponent IO x b -> SplitterComponent IO x b)
+ -> TypeTag x -> Expression -> Expression -> Expression
combineSplittersOfSameType combinator inputTag left right
= case (compile inputTag left, compile inputTag right)
of (Compiled tag1@SplitterTag{} s1, Compiled tag2@SplitterTag{} s2)
- -> trycast tag2 tag1 s2 right (\s2'-> Compiled tag1 (combinator s1 s2'))
+ -> tryComponentCast tag2 tag1 s2 right (\s2'-> Compiled tag1 (combinator s1 s2'))
(e@TypeError{}, _) -> e
(_, e@TypeError{}) -> e
(Compiled tag1 _, Compiled tag2@SplitterTag{} _) -> TypeError tag1 tag2 left
(Compiled tag1@SplitterTag{} _, Compiled tag2 _) -> TypeError tag2 tag1 right
-combineSplittersOfDifferentTypes :: forall x1 x2. (Typeable x1, Typeable x2) =>
- (forall b1 b2. (Typeable b1, Typeable b2)
- => Splitter IO x1 b1 -> Splitter IO x2 b2 -> Splitter IO x1 b1)
+combineSplittersOfDifferentTypes :: forall x1 x2.
+ (forall b1 b2. SplitterComponent IO x1 b1 -> SplitterComponent IO x2 b2 -> SplitterComponent IO x1 b1)
-> TypeTag x1 -> TypeTag x2 -> Expression -> Expression -> Expression
combineSplittersOfDifferentTypes combinator tag1 tag2 left right
= case (compile tag1 left, compile tag2 right)
of (Compiled tag1'@(SplitterTag _ b1) s1, Compiled tag2'@(SplitterTag _ b2) s2)
- -> trycast tag1' (SplitterTag tag1 b1) s1 left $
- \s1'-> trycast tag2' (SplitterTag tag2 b2) s2 right $
+ -> tryComponentCast tag1' (SplitterTag tag1 b1) s1 left $
+ \s1'-> tryComponentCast tag2' (SplitterTag tag2 b2) s2 right $
\s2'-> Compiled (SplitterTag tag1 b1) (combinator s1' s2')
(e@TypeError{}, _) -> e
(_, e@TypeError{}) -> e
(Compiled tag1 _, Compiled tag2@SplitterTag{} _) -> TypeError tag1 tag2 left
(Compiled tag1@SplitterTag{} _, Compiled tag2 _) -> TypeError tag2 tag1 right
-combineTransducersOfSameType :: forall x. Typeable x =>
- (forall x y. (Typeable x, Typeable y)=> Transducer IO x y -> Transducer IO x y -> Transducer IO x y)
- -> TypeTag x -> Expression -> Expression -> Expression
+combineTransducersOfSameType :: forall x.
+ (forall x y. TransducerComponent IO x y -> TransducerComponent IO x y -> TransducerComponent IO x y)
+ -> TypeTag x -> Expression -> Expression -> Expression
combineTransducersOfSameType combinator inputTag left right
= case (compile inputTag left, compile inputTag right)
of (Compiled tag1@TransducerTag{} t1, Compiled tag2@TransducerTag{} t2)
- -> trycast tag2 tag1 t2 right (\t2'-> Compiled tag1 (combinator t1 t2'))
+ -> tryComponentCast tag2 tag1 t2 right (\t2'-> Compiled tag1 (combinator t1 t2'))
-combineSplitterAndBranches :: forall x. Typeable x =>
- (forall x b cc.
- (Typeable x, Typeable b, BranchComponent cc IO x [x]) => Splitter IO x b -> cc -> cc -> cc)
+combineSplitterAndBranches :: forall x.
+ (forall x b cc. Branching cc IO x [x] => SplitterComponent IO x b -> Component cc -> Component cc -> Component cc)
-> TypeTag x -> Expression -> Expression -> Expression -> Expression
combineSplitterAndBranches combinator inputTag splitter true false
= case (compile inputTag splitter, compile inputTag true, compile inputTag false)
of (Compiled (SplitterTag tag1 _) s, Compiled tag2@ConsumerTag{} t, Compiled tag3@ConsumerTag{} f)
- -> trycast tag2 (ConsumerTag tag1) t true $
- \t'-> trycast tag3 (ConsumerTag tag1) f false $
+ -> tryComponentCast tag2 (ConsumerTag tag1) t true $
+ \t'-> tryComponentCast tag3 (ConsumerTag tag1) f false $
\f'-> Compiled (ConsumerTag tag1) (combinator s t' f')
(Compiled tag1@SplitterTag{} s, Compiled tag2@SplitterTag{} t, Compiled tag3@SplitterTag{} f)
- -> trycast tag2 tag1 t true $
- \t'-> trycast tag3 tag1 f false $
+ -> tryComponentCast tag2 tag1 t true $
+ \t'-> tryComponentCast tag3 tag1 f false $
\f'-> Compiled tag1 (combinator s t' f')
(Compiled (SplitterTag tag1 _) s, Compiled tag2@(TransducerTag tag2a tag2b) t, Compiled tag3@TransducerTag{} f)
-> let tag2' = TransducerTag tag1 tag2b
- in trycast tag2 tag2' t true $
- \t'-> trycast tag3 tag2' f false $
+ in tryComponentCast tag2 tag2' t true $
+ \t'-> tryComponentCast tag3 tag2' f false $
\f'-> Compiled tag2' (combinator s t' f')
(Compiled (SplitterTag tag1 _) s, Compiled tag2@(TransducerTag tag2a tag2b) t, Compiled tag3@ConsumerTag{} f)
-> let tag2' = TransducerTag tag1 tag2b
- in trycast tag2 tag2' t true $
- \t'-> trycast tag3 (ConsumerTag tag1) f false $
+ in tryComponentCast tag2 tag2' t true $
+ \t'-> tryComponentCast tag3 (ConsumerTag tag1) f false $
\f'-> Compiled tag2' (combinator s t' (consumeBy f'))
(Compiled (SplitterTag tag1 _) s, Compiled tag2@ConsumerTag{} t, Compiled tag3@(TransducerTag tag3a tag3b) f)
-> let tag3' = TransducerTag tag1 tag3b
- in trycast tag2 (ConsumerTag tag1) t true $
- \t'-> trycast tag3 tag3' f false $
+ in tryComponentCast tag2 (ConsumerTag tag1) t true $
+ \t'-> tryComponentCast tag3 tag3' f false $
\f'-> Compiled tag3' (combinator s (consumeBy t') f')
(Compiled (SplitterTag tag1 _) s, Compiled tag2@(TransducerTag tag2a tag2b) t, Compiled tag3@ProducerTag{} f)
-> let tag2' = TransducerTag tag1 tag2b
- in trycast tag2 tag2' t true $
- \t'-> trycast tag3 (ProducerTag tag2b) f false $
+ in tryComponentCast tag2 tag2' t true $
+ \t'-> tryComponentCast tag3 (ProducerTag tag2b) f false $
\f'-> Compiled tag2' (combinator s t' (substitute f'))
(Compiled (SplitterTag tag1 _) s, Compiled tag2@ProducerTag{} t, Compiled tag3@(TransducerTag tag3a tag3b) f)
-> let tag3' = TransducerTag tag1 tag3b
- in trycast tag2 (ProducerTag tag3b) t true $
- \t'-> trycast tag3 tag3' f false $
+ in tryComponentCast tag2 (ProducerTag tag3b) t true $
+ \t'-> tryComponentCast tag3 tag3' f false $
\f'-> Compiled tag3' (combinator s (substitute t') f')
(Compiled (SplitterTag tag1 _) s, Compiled tag2@(ConsumerTag tag2a) t, Compiled tag3@(ProducerTag tag3a) f)
- -> trycast tag2 (ConsumerTag tag1) t true $
+ -> tryComponentCast tag2 (ConsumerTag tag1) t true $
\t'-> Compiled (TransducerTag tag1 tag3a) (combinator s (consumeBy t') (substitute f))
(Compiled (SplitterTag tag1 _) s, Compiled tag2@(ProducerTag tag2a) t, Compiled tag3@(ConsumerTag tag3a) f)
- -> trycast tag3 (ConsumerTag tag1) f true $
+ -> tryComponentCast tag3 (ConsumerTag tag1) f true $
\f'-> Compiled (TransducerTag tag1 tag2a) (combinator s (substitute t) (consumeBy f'))
(e@TypeError{}, _, _) -> e
(_, e@TypeError{}, _) -> e
@@ -920,7 +943,8 @@
nativeCommand :: Bool -> Parsec.Parser String
nativeCommand normalize = do parts <- try (lexeme lexer (parameterParser normalize)
`manyTill`
- ((eof >> return "") <|> lookAhead (choice (map (try . symbol lexer) reservedTokens))))
+ ((eof >> return "")
+ <|> lookAhead (choice (map (try . symbol lexer) reservedTokens))))
return (concat (intersperse " " parts))
where manyTill :: GenParser tok st a -> GenParser tok st end -> GenParser tok st [a]
manyTill p end = scan
diff --git a/Test.hs b/Test.hs
--- a/Test.hs
+++ b/Test.hs
@@ -1,5 +1,5 @@
{-
- Copyright 2008 Mario Blazevic
+ Copyright 2008-2009 Mario Blazevic
This file is part of the Streaming Component Combinators (SCC) project.
@@ -14,21 +14,23 @@
.
-}
-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleInstances, ScopedTypeVariables #-}
module Main where
-import Control.Concurrent.SCC.Foundation
-import Control.Concurrent.SCC.ComponentTypes
-import Control.Concurrent.SCC.Combinators hiding ((&&), (||))
-import Control.Concurrent.SCC.Components
-import qualified Control.Concurrent.SCC.XMLComponents as XML
-import qualified Control.Concurrent.SCC.Combinators as C
+import Control.Concurrent.Configuration
+import Control.Concurrent.Coroutine
+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 qualified Control.Concurrent.SCC.XML as XML
+import qualified Control.Concurrent.SCC.Components as C
import Control.Monad (liftM, when)
import Control.Monad.Identity (Identity (Identity, runIdentity))
import Data.Char (ord, isLetter, isSpace, toUpper)
-import Data.Dynamic (Typeable)
+import Data.Either (rights)
import Data.List (find, findIndices, groupBy, intersect, union,
intercalate, isInfixOf, isPrefixOf, isSuffixOf, nub, sort, tails)
import Data.Maybe (fromJust, isJust, mapMaybe)
@@ -39,8 +41,8 @@
import Debug.Trace (trace)
import Prelude hiding (even, last)
import qualified Prelude
-import Test.QuickCheck (Arbitrary, Property,
- arbitrary, coarbitrary, label, choose, oneof, sized, quickCheck, trivial, variant, (==>))
+import Test.QuickCheck (Arbitrary, Gen, Property, -- CoArbitrary, Positive(Positive),
+ arbitrary, coarbitrary, label, classify, choose, oneof, sized, quickCheck, variant, (==>))
sublists [] _ = []
@@ -51,14 +53,14 @@
(\n-> [n .. n + length sublist - 1])
(findIndices (isPrefixOf sublist) (tails input)))
-contentIn :: [Markup x y] -> [x]
+contentIn :: [Markup y x] -> [x]
contentIn = mapMaybe (\x-> case x of {Content y -> Just y; _ -> Nothing})
both f (x, y) = (f x, f y)
main = mapM_ quickCheck tests
-tests = [label "pipe" $ \(input :: [Int])-> runPipes (pipe (putList input) getList) == Just ([], input),
+tests = [label "pipe" $ \(input :: [Int])-> runCoroutine (pipe (putList input) getList) == Just ([], input),
label "pour" prop_pour,
label "asis" prop_asis,
label "suppress" prop_suppress,
@@ -71,9 +73,15 @@
label "group" prop_group,
label "concatenate" prop_concatenate,
label "concatSeparate" prop_concatSeparate,
- label "uppercase ->>" $ \s-> runPipes (pipe (putList s) (consume $ uppercase >-> liftAtomicConsumer "getList" 1 getList))
+ label "uppercase ->>" $ \s-> runCoroutine (pipe
+ (putList s)
+ (consume $ with $
+ uppercase >-> atomic "getList" 1 (Consumer getList)))
== Just ([], map toUpper s),
- label "uppercase <<-" $ \s-> runPipes (pipe (produce $ liftAtomicProducer "putList" 1 (putList s) >-> uppercase) getList)
+ label "uppercase <<-" $ \s-> runCoroutine (pipe
+ (produce $ with $
+ atomic "putList" 1 (Producer (putList s)) >-> uppercase)
+ getList)
== Just ([], map toUpper s),
label "uppercase `join` asis" $ \s-> transducerOutput (uppercase `join` asis) s == map toUpper s ++ s,
label "prepend >-> append" (\(s :: String) prefix suffix->
@@ -91,22 +99,28 @@
label "ifs (substring X) uppercase asis" $
\s (LowercaseLetter c)-> transducerOutput (ifs (substring [c]) uppercase asis) s
== map (\x-> if x == c then toUpper x else x) s,
- label "parseSubstring" $ \s (c :: TestEnum)-> transducerOutput (parseSubstring [c] >-> select markedContent >-> unparse) s
+ label "parseSubstring" $ \s (c :: TestEnum)-> transducerOutput
+ (parseSubstring [c] >-> select markedContent >-> unparse)
+ s
== filter (==c) s,
label "uppercase `wherever` parseSubstring" $
- \s (LowercaseLetter c)-> transducerOutput (parseSubstring [c] >-> (liftComponent uppercase `wherever` markedContent)
- >-> unparse) s
+ \s (LowercaseLetter c)-> transducerOutput
+ (parseSubstring [c]
+ >-> (uppercaseContent `wherever` markedContent)
+ >-> unparse)
+ s
== map (\x-> if x == c then toUpper x else x) s,
label "parseRegions substring == parseSubstring" prop_substringVsParse,
label "count >-> toString >-> concatenate" $
\(s :: [TestEnum])-> transducerOutput (count >-> toString >-> concatenate) s == show (length s),
label "foreach whitespace asis (prepend \"[\" >-> append \"]\")" $
\s-> transducerOutput (foreach whitespace asis (prepend (fromList "[") >-> append (fromList "]"))) s
- == mapWords (("[" ++) . (++ "]")) s,
+ == mapWords (("[" ++) . (++ "]")) s,
label "foreach whitespace asis (count >-> toString >-> concatenate)" $
- \s-> transducerOutput (foreach whitespace asis (count >-> toString >-> concatenate)) s == mapWords (show . length) s,
+ \s-> transducerOutput (foreach whitespace asis (count >-> toString >-> concatenate)) s
+ == mapWords (show . length) s,
label "uppercase `wherever` (snot whitespace `having` substring X)" $
- \s1 s2-> not (null s1) && length s1 < length s2 ==> trivial (not (s1 `isInfixOf` s2)) $
+ \s1 s2-> not (null s1) && length s1 < length s2 ==> classify (not (s1 `isInfixOf` s2)) "trivial" $
transducerOutput (uppercase `wherever` (snot whitespace `having` substring s1)) s2
== mapWords (\w-> if s1 `isInfixOf` w then map toUpper w else w) s2,
label "(uppercase `wherever` (snot whitespace `havingOnly` letters))" $
@@ -168,7 +182,8 @@
label "last" $ prop_last . splitterFromTrace,
label "uptoFirst" $ prop_uptoFirst . splitterFromTrace,
label "lastAndAfter" $ prop_lastAndAfter . splitterFromTrace,
- label "followedBy prefix" $ \trace1 trace2 n-> prop_followedBy1 (splitterFromTrace trace1) (splitterFromTrace trace2) n,
+ label "followedBy prefix" $
+ \trace1 trace2 n-> prop_followedBy1 (splitterFromTrace trace1) (splitterFromTrace trace2) n,
label "followedBy startOf everything" $ \trace n-> prop_followedBy2 (splitterFromTrace trace) n,
label "substring followedBy substring 1" prop_followedBy3,
label "substring followedBy substring 2" prop_followedBy4,
@@ -182,29 +197,33 @@
label "XML.tokens" prop_XMLtokens1,
label "XML.tokens with attributes" prop_XMLtokens2,
label "XML.parseTokens >-> select elementContent >-> unparse" prop_XMLtokens3,
- label "XML.parseTokens >-> unparse" prop_XMLtokens4]
+ label "XML.parseTokens >-> unparse" prop_XMLtokens4,
+ label "nestedIn XML.elementContent" prop_nestedInXMLcontent,
+ label "select XML.elementContent while XML.element" prop_whileXMLelement]
prop_pour :: [Int] -> Bool
-prop_pour input = runPipes (pipeD "input" (putList input) (\source-> pipeD "output" (\sink-> pour source sink) getList))
+prop_pour input = runCoroutine (pipe (putList input) (\source-> pipe (\sink-> pour source sink) getList))
== Just ([], ((), input))
prop_asis :: [Int] -> Bool
prop_asis input = transducerOutput asis input == input
prop_suppress :: [Int] -> Bool
-prop_suppress input = null (transducerOutput (consumeBy suppress :: Transducer Identity Int ()) input)
+prop_suppress input = null (transducerOutput (consumeBy suppress :: TransducerComponent Identity Int ()) input)
prop_substitute :: [Int] -> [Maybe Int] -> Bool
prop_substitute input replacement = transducerOutput (substitute $ fromList replacement) input == replacement
prop_prepend :: [Int] -> [Int] -> Int -> Property
prop_prepend input prefix threads = threads > 0 ==>
- transducerOutput (usingThreads threads $ prepend $ fromList prefix) input == prefix ++ input
+ transducerOutput (usingThreads (prepend $ fromList prefix) threads) input
+ == prefix ++ input
prop_append :: [Int] -> [Int] -> Int -> Property
prop_append input suffix threads = threads > 0 ==>
- transducerOutput (usingThreads threads $ append $ fromList suffix) input == input ++ suffix
+ transducerOutput (usingThreads (append $ fromList suffix) threads) input
+ == input ++ suffix
prop_allTrue :: [Int] -> Bool
prop_allTrue input = splitterOutputs everything input == (input, [])
@@ -213,14 +232,13 @@
prop_allFalse input = splitterOutputs nothing input == ([], input)
prop_substring :: [TestEnum] -> [TestEnum] -> Property
-prop_substring input sublist = trivial
- (not (isInfixOf sublist input))
+prop_substring input sublist = classify (not (isInfixOf sublist input)) "trivial"
(transducerOutput (select (substring sublist)) input == sublists sublist input)
prop_substringVsParse :: [TestEnum] -> [TestEnum] -> Property
prop_substringVsParse input sublist = not (null sublist) && length sublist < length input
&& not (sublist `isInfixOf` (tail sublist ++ init sublist))
- ==> trivial (not (sublist `isInfixOf` input))
+ ==> classify (not (sublist `isInfixOf` input)) "trivial"
(transducerOutput (parseRegions (substring sublist)) input
== map unitFromOccurrence (transducerOutput (parseSubstring sublist) input))
where unitFromOccurrence (Content x) = Content x
@@ -235,14 +253,14 @@
prop_concatSeparate :: [[TestEnum]] -> [TestEnum] -> Bool
prop_concatSeparate input separator = transducerOutput (concatSeparate separator) input == intercalate separator input
-prop_snot :: Splitter Identity Int () -> [Int] -> Bool
+prop_snot :: SplitterComponent Identity Int () -> [Int] -> Bool
prop_snot splitter input = splitterOutputs (snot splitter) input == swap (splitterOutputs splitter input)
prop_andAssoc :: SplitterTrace -> SplitterTrace -> SplitterTrace -> [Int] -> Int -> Int -> Property
prop_andAssoc st1 st2 st3 input t1 t2
= t1 > 0 && t2 > 0
- ==> splitterOutputs (usingThreads t1 $ s1 C.&& (s2 C.&& s3)) input
- == splitterOutputs (usingThreads t2 $ (s1 C.&& s2) C.&& s3) input
+ ==> splitterOutputs (usingThreads (s1 C.&& (s2 C.&& s3)) t1) input
+ == splitterOutputs (usingThreads ((s1 C.&& s2) C.&& s3) t2) input
where s1 = splitterFromTrace st1
s2 = splitterFromTrace st2
s3 = splitterFromTrace st3
@@ -250,65 +268,68 @@
prop_orAssoc :: SplitterTrace -> SplitterTrace -> SplitterTrace -> [Int] -> Int -> Int -> Property
prop_orAssoc st1 st2 st3 input t1 t2
= t1 > 0 && t2 > 0
- ==> splitterOutputs (usingThreads t1 $ s1 C.|| (s2 C.|| s3)) input
- == splitterOutputs (usingThreads t2 $ (s1 C.|| s2) C.|| s3) input
+ ==> splitterOutputs (usingThreads (s1 C.|| (s2 C.|| s3)) t1) input
+ == splitterOutputs (usingThreads ((s1 C.|| s2) C.|| s3) t2) input
where s1 = splitterFromTrace st1
s2 = splitterFromTrace st2
s3 = splitterFromTrace st3
-prop_DeMorgan1 :: Splitter Identity Int () -> Splitter Identity Int () -> [Int] -> Int -> Int -> Property
+prop_DeMorgan1 :: SplitterComponent Identity Int () -> SplitterComponent Identity Int () -> [Int] -> Int -> Int -> Property
prop_DeMorgan1 s1 s2 input t1 t2
= t1 > 0 && t2 > 0
- ==> splitterOutputs (usingThreads t1 $ snot (s1 C.&& s2)) input
- == splitterOutputs (usingThreads t2 $ snot s1 C.|| snot s2) input
+ ==> splitterOutputs (usingThreads (snot (s1 C.&& s2)) t1) input
+ == splitterOutputs (usingThreads (snot s1 C.|| snot s2) t2) input
-prop_DeMorgan2 :: Splitter Identity Int () -> Splitter Identity Int () -> [Int] -> Int -> Int -> Property
+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 t1 $ snot (s1 C.|| s2)) input
- == splitterOutputs (usingThreads t2 $ snot s1 C.&& snot s2) input
+ ==> splitterOutputs (usingThreads (snot (s1 C.|| s2)) t1) input
+ == splitterOutputs (usingThreads (snot s1 C.&& snot s2) t2) input
-prop_and :: Splitter Identity Int () -> Splitter Identity Int () -> Int -> Bool
+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_or :: Splitter Identity Int () -> Splitter Identity Int () -> Int -> Bool
+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_even :: Splitter Identity TestEnum () -> [TestEnum] -> Bool
+prop_even :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool
prop_even splitter input = let splitOddEven [] = ([], [])
splitOddEven (head:tail) = let (evens, odds) = splitOddEven tail in (head:odds, evens)
in fst (splitterOutputs (even splitter) input)
- == concat (snd $ splitOddEven $ transducerOutput (foreach splitter group (consumeBy suppress)) input)
+ == concat (snd $ splitOddEven $
+ transducerOutput (foreach splitter group (consumeBy suppress)) input)
-prop_prefix_1 :: Splitter Identity TestEnum () -> [TestEnum] -> Bool
+prop_prefix_1 :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool
prop_prefix_1 splitter input = let (pfx, rest) = splitterOutputs (prefix splitter) input
(true, false) = splitterOutputs splitter input
in pfx ++ rest == input && pfx `isPrefixOf` true
-prop_prefix_2 :: Splitter Identity TestEnum () -> [TestEnum] -> Bool
+prop_prefix_2 :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool
prop_prefix_2 splitter input = let (prefix1, rest1) = splitterOutputs (prefix splitter) input
in case splitterOutputChunks splitter input
of (prefix2, True):rest2 -> prefix1 == prefix2 && rest1 == concat (map fst rest2)
(prefix2, False):rest2 -> prefix1 == [] && rest1 == prefix2 ++ concat (map fst rest2)
[] -> prefix1 ++ rest1 == []
-prop_suffix_1 :: Splitter Identity TestEnum () -> [TestEnum] -> Bool
+prop_suffix_1 :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool
prop_suffix_1 splitter input = let (sfx, rest) = splitterOutputs (suffix splitter) input
(true, false) = splitterOutputs splitter input
in rest ++ sfx == input && sfx `isSuffixOf` true
-prop_suffix_2 :: Splitter Identity TestEnum () -> [TestEnum] -> Bool
+prop_suffix_2 :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool
prop_suffix_2 splitter input = let (suffix1, rest1) = splitterOutputs (suffix splitter) input
in case reverse (splitterOutputChunks splitter input)
- of (suffix2, True):rest2 -> suffix1 == suffix2 && rest1 == concat (map fst (reverse rest2))
- (suffix2, False):rest2 -> suffix1 == [] && rest1 == concat (map fst (reverse rest2)) ++ suffix2
+ of (suffix2, True):rest2 -> suffix1 == suffix2
+ && rest1 == concat (map fst (reverse rest2))
+ (suffix2, False):rest2 -> suffix1 == []
+ && rest1 == concat (map fst (reverse rest2)) ++ suffix2
[] -> rest1 ++ suffix1 == []
-prop_first :: Splitter Identity TestEnum () -> [TestEnum] -> Bool
+prop_first :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool
prop_first splitter input = let (first1, rest1) = splitterOutputs (first splitter) input
in case splitterOutputChunks splitter input
of (first2, True):rest2 -> first1 == first2 && rest1 == concat (map fst rest2)
@@ -317,17 +338,17 @@
(prefix, False):[] -> first1 == [] && rest1 == prefix
[] -> first1 ++ rest1 == []
-prop_last :: Splitter Identity TestEnum () -> [TestEnum] -> Bool
+prop_last :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool
prop_last splitter input = let (last1, rest1) = splitterOutputs (last splitter) input
in -- trace (show (last1, rest1)) $ trace (show (splitterOutputChunks splitter input)) $
case reverse (splitterOutputChunks splitter input)
of (last2, True):rest2 -> last1 == last2 && rest1 == concat (map fst (reverse rest2))
- (suffix, False):(last2, True):rest2 -> last1 == last2
- && rest1 == concat (map fst (reverse rest2)) ++ suffix
+ (suffix, False):(last2, True):rest2
+ -> last1 == last2 && rest1 == concat (map fst (reverse rest2)) ++ suffix
(suffix, False):[] -> last1 == [] && rest1 == suffix
[] -> last1 ++ rest1 == []
-prop_uptoFirst :: Splitter Identity TestEnum () -> [TestEnum] -> Bool
+prop_uptoFirst :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool
prop_uptoFirst splitter input = let (first1, rest1) = splitterOutputs (uptoFirst splitter) input
in case splitterOutputChunks splitter input
of (first2, True):rest2 -> first1 == first2 && rest1 == concat (map fst rest2)
@@ -336,7 +357,7 @@
(prefix, False):[] -> first1 == [] && rest1 == prefix
[] -> first1 ++ rest1 == []
-prop_lastAndAfter :: Splitter Identity TestEnum () -> [TestEnum] -> Bool
+prop_lastAndAfter :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool
prop_lastAndAfter splitter input = let (last1, rest1) = splitterOutputs (lastAndAfter splitter) input
in case reverse (splitterOutputChunks splitter input)
of (last2, True):rest2 -> last1 == last2 && rest1 == concat (map fst (reverse rest2))
@@ -345,23 +366,23 @@
(suffix, False):[] -> last1 == [] && rest1 == suffix
[] -> last1 ++ rest1 == []
-prop_followedBy1 :: Splitter Identity Int () -> Splitter Identity Int () -> Int -> Bool
+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_followedBy2 :: Splitter Identity Int () -> Int -> Bool
+prop_followedBy2 :: SplitterComponent Identity Int () -> Int -> Bool
prop_followedBy2 s n = splitterOutputs (s `followedBy` startOf everything) l == splitterOutputs s l
where l = [1 .. abs n]
prop_followedBy3 :: [TestEnum] -> [TestEnum] -> [TestEnum] -> Property
-prop_followedBy3 l1 l2 l3 = trivial (not (isInfixOf l1 l3)) (fst (splitterOutputs (substring l1 `followedBy` substring l2) l3)
- == sublists (l1 ++ l2) l3)
+prop_followedBy3 l1 l2 l3 = classify (not (isInfixOf l1 l3)) "trivial" $
+ fst (splitterOutputs (substring l1 `followedBy` substring l2) l3)
+ == sublists (l1 ++ l2) l3
prop_followedBy4 :: [TestEnum] -> [TestEnum] -> [TestEnum] -> Property
prop_followedBy4 l1 l2 l3 = isInfixOf l1 l3
- ==> trivial (not (isInfixOf (l1 ++ l2) l3)) (fst (splitterOutputs (substring l1
- `followedBy` substring l2) l3)
- == sublists (l1 ++ l2) l3)
+ ==> 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
@@ -371,7 +392,7 @@
in splitterOutputs (substring [n1 .. n2] `followedBy` substring [n2 + 1 .. n3]) [0 .. n4]
== ([n1 .. n3], [0 .. n1 - 1] ++ [n3 + 1 .. n4])
-prop_followedBy6 :: Splitter Identity Int () -> Splitter Identity Int () -> Int -> Bool
+prop_followedBy6 :: 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)
@@ -389,26 +410,27 @@
== ([n1 .. n3], [0 .. n1 - 1] ++ [n3 + 1 .. n4])
-prop_between1 :: Splitter Identity Int () -> Int -> Bool
+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_between2 :: Splitter Identity Int () -> Int -> Bool
-prop_between2 splitter n = splitterOutputs (startOf everything ... endOf splitter) input == splitterOutputs (uptoFirst splitter) input
+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_XMLtokens1 :: [LowercaseLetter] -> String -> Property
prop_XMLtokens1 name content = name /= [] && intersect content "<&" == []
- ==> splitterOutputs XML.tokens (start ++ content ++ end) == (start ++ end, content)
+ ==> splitterOutputs xmlTokens (start ++ content ++ end) == (start ++ end, content)
where name' = map letterChar name
start = "<" ++ name' ++ ">"
end = ""
prop_XMLtokens2 :: [LowercaseLetter] -> [([LowercaseLetter], String)] -> String -> Property
prop_XMLtokens2 name attrs content = name /= [] && all validAttribute attrs && intersect content "<&" == []
- ==> splitterOutputs XML.tokens (start ++ content ++ end)
+ ==> splitterOutputs xmlTokens (start ++ content ++ end)
== (start ++ end, content)
where name' = map letterChar name
start = "<" ++ name' ++ concatMap attribute attrs ++ ">"
@@ -417,7 +439,7 @@
prop_XMLtokens3 :: [LowercaseLetter] -> [([LowercaseLetter], String)] -> String -> Property
prop_XMLtokens3 name attrs content = name /= [] && all validAttribute attrs && intersect content "<&" == []
==> transducerOutput
- (XML.parseTokens >-> select XML.elementContent >-> unparse)
+ (xmlParseTokens >-> select xmlElementContent >-> unparse)
(start ++ content ++ end)
== content
where name' = map letterChar name
@@ -426,74 +448,114 @@
prop_XMLtokens4 :: [LowercaseLetter] -> [([LowercaseLetter], String)] -> String -> Property
prop_XMLtokens4 name attrs content = name /= [] && all ((/= []) . fst) attrs
- ==> transducerOutput (XML.parseTokens >-> unparse) input == input
+ ==> transducerOutput (xmlParseTokens >-> unparse) input == input
where name' = map letterChar name
start = "<" ++ name' ++ concatMap attribute attrs ++ ">"
end = ""
content' = concatMap XML.escapeContentCharacter content
input = start ++ content' ++ end
-attribute (name, value) = " " ++ map letterChar name ++ "=\"" ++ concatMap XML.escapeAttributeCharacter value ++ "\""
+prop_nestedInXMLcontent :: [Either ([LowercaseLetter], [([LowercaseLetter], String)]) String] -> Bool
+prop_nestedInXMLcontent startTagsAndContent = transducerOutput
+ (xmlParseTokens
+ >-> select (snot xmlElement `nestedIn` xmlElementContent)
+ >-> unparse)
+ (nestXMLelements startTagsAndContent)
+ == concatMap
+ XML.escapeContentCharacter
+ (concat (rights startTagsAndContent))
+
+prop_whileXMLelement :: [Either ([LowercaseLetter], [([LowercaseLetter], String)]) String] -> Bool
+prop_whileXMLelement startTagsAndContent = transducerOutput
+ (xmlParseTokens
+ >-> (select xmlElementContent `while` xmlElement) >-> unparse)
+ (nestXMLelements startTagsAndContent)
+ == concatMap XML.escapeContentCharacter (concat (rights startTagsAndContent))
+-- == nest (map (either (Left . id) (Right . map toUpper)) startTagsAndContent)
+
+nestXMLelements [] = []
+nestXMLelements (Left (name, attrs) : rest) = "<" ++ name' ++ concatMap attribute attrs ++ ">"
+ ++ nestXMLelements rest ++ ""
+ where name' = 'a' : map letterChar name
+nestXMLelements (Right content : rest) = concatMap XML.escapeContentCharacter content ++ nestXMLelements rest
+
+attribute (name, value) = " b" ++ map letterChar name ++ "=\"" ++ concatMap XML.escapeAttributeCharacter value ++ "\""
validAttribute (name, value) = name /= [] && intersect value "<&\"" == []
-transducerOutput :: (Typeable x, Typeable y) => Transducer Identity x y -> [x] -> [y]
-transducerOutput t input = case runPipes (pipeD "transducerOutput input"
- (putList input)
- (\source-> pipeD "transducerOutput output"
+uppercaseContent :: (Functor f, Monad m) => TransducerComponent m (f Char) (f Char)
+uppercaseContent = atomic "uppercase" 1 (oneToOneTransducer $ fmap toUpper)
+
+transducerOutput :: TransducerComponent Identity x y -> [x] -> [y]
+transducerOutput t = transducerOutput' (with t)
+
+transducerOutput' :: Transducer Identity x y -> [x] -> [y]
+transducerOutput' t input = case runCoroutine (pipe
+ (putList input)
+ (\source-> pipe
(\sink-> transduce t source sink)
getList))
of Identity ([], ([], output)) -> output
-splitterOutputs :: (Typeable x, Typeable b) => Splitter Identity x b -> [x] -> ([x], [x])
-splitterOutputs s input = case runPipes (pipeD "splitterOutputs input"
- (putList input)
- (\source-> splitToConsumers s source
- getList
- getList
- consumeAndSuppress))
+splitterOutputs :: SplitterComponent Identity x b -> [x] -> ([x], [x])
+splitterOutputs s input = case runCoroutine (pipe
+ (putList input)
+ (\source-> splitToConsumers (with s) source
+ getList
+ getList
+ consumeAndSuppress))
of Identity ([], ([], true, false, ())) -> (true, false)
-splitterUnifiedOutput :: (Typeable x, Typeable b) => Splitter Identity x b -> [x] -> [Either (x, Bool) b]
-splitterUnifiedOutput s input = snd $ runIdentity
- $ runPipes (pipe
- (\sink-> pipe
- (putList input)
- (\source-> splitToConsumers s source
- (flip (pourMap (Left . (\x-> (x, True)))) sink)
- (flip (pourMap (Left . (\x-> (x, False)))) sink)
- (flip (pourMap Right) sink)))
- getList)
+splitterUnifiedOutput :: forall x b. SplitterComponent Identity x b -> [x] -> [Either (x, Bool) b]
+splitterUnifiedOutput s input =
+ snd $ runIdentity $
+ runCoroutine (pipe
+ (\sink-> pipe
+ (putList input)
+ (mapSplit s sink))
+ getList)
+ where mapSplit :: forall a d. AncestorFunctor a d =>
+ SplitterComponent Identity x b -> Sink Identity a (Either (x, Bool) b) -> Source Identity d x
+ -> Coroutine d Identity ([x], (), (), ())
+ mapSplit s sink source = let sink' = liftSink sink :: Sink Identity d (Either (x, Bool) b)
+ in splitToConsumers (with s) source
+ (flip (pourMap (Left . (\x-> (x, True)))) sink')
+ (flip (pourMap (Left . (\x-> (x, False)))) sink')
+ (flip (pourMap Right) sink')
-splitterOutputChunks :: (Typeable x, Typeable b) => Splitter Identity x b -> [x] -> [([x], Bool)]
+splitterOutputChunks :: SplitterComponent Identity x b -> [x] -> [([x], Bool)]
splitterOutputChunks s input = transducerOutput (foreach s
- (group >-> lift121Transducer "true" (\chunk-> (chunk, True)))
- (group >-> lift121Transducer "false" (\chunk-> (chunk, False))))
+ (group >-> atomic "true" 1 (oneToOneTransducer (\chunk-> (chunk, True))))
+ (group >-> atomic "true" 1 (oneToOneTransducer (\chunk-> (chunk, False)))))
input
-simpleSplitterFromTrace :: (Show x, Typeable x) => SimpleSplitterTrace -> Splitter Identity x ()
+simpleSplitterFromTrace :: SimpleSplitterTrace -> SplitterComponent Identity x ()
simpleSplitterFromTrace (init, last) = splitterFromTrace (fmap Just init, last)
-splitterFromTrace :: (Show x, Typeable x) => SplitterTrace -> Splitter Identity x ()
-splitterFromTrace trace1 = liftAtomicSplitter "splitterFromTrace" 1 $
- \source true false edge->
- let follow previous trace2@(head:tail) q = get source >>= maybe fail succeed
- where succeed x = let q' = q |> x
- in case head
- of Nothing -> follow previous tail q'
- Just Nothing -> when (not previous) (put edge () >> return ())
- >> follow False tail q'
- Just (Just True) -> when (not previous) (put edge () >> return ())
- >> putList (Foldable.toList (Seq.viewl q')) true
- >>= whenNull (follow True tail Seq.empty)
- Just (Just False) -> putList (Foldable.toList (Seq.viewl q')) false
- >>= whenNull (follow False tail Seq.empty)
- fail = if find (maybe False isJust) trace2 == Just (Just (Just True))
- then do when (not previous) (put edge () >> return ())
- result <- putList (Foldable.toList (Seq.viewl q)) true
- return result
- else putList (Foldable.toList (Seq.viewl q)) false
- in follow False (cycle (fst trace1 ++ [Just (Just $ snd trace1)])) Seq.empty
+splitterFromTrace :: SplitterTrace -> SplitterComponent Identity x ()
+splitterFromTrace trace = atomic "splitterFromTrace" 1 (splitterFromTrace' trace)
+splitterFromTrace' :: SplitterTrace -> Splitter Identity x ()
+splitterFromTrace' trace1
+ = Splitter $
+ \source true false edge->
+ let follow previous trace2@(head:tail) q = get source >>= maybe fail succeed
+ where succeed x = let q' = q |> x
+ in case head
+ of Nothing -> follow previous tail q'
+ Just Nothing -> when (not previous) (put edge () >> return ())
+ >> follow False tail q'
+ Just (Just True) -> when (not previous) (put edge () >> return ())
+ >> putList (Foldable.toList (Seq.viewl q')) true
+ >>= whenNull (follow True tail Seq.empty)
+ Just (Just False) -> putList (Foldable.toList (Seq.viewl q')) false
+ >>= whenNull (follow False tail Seq.empty)
+ fail = if find (maybe False isJust) trace2 == Just (Just (Just True))
+ then do when (not previous) (put edge () >> return ())
+ result <- putList (Foldable.toList (Seq.viewl q)) true
+ return result
+ else putList (Foldable.toList (Seq.viewl q)) false
+ in follow False (cycle (fst trace1 ++ [Just (Just $ snd trace1)])) Seq.empty
+
swap :: (x, y) -> (y, x)
swap (x, y) = (y, x)
@@ -504,12 +566,13 @@
type SplitterTrace = ([Maybe (Maybe Bool)], Bool)
-data TestEnum = One | Two | Three | Four | Five deriving (Enum, Eq, Show, Typeable)
+data TestEnum = One | Two | Three | Four | Five deriving (Enum, Eq, Show)
-newtype LowercaseLetter = LowercaseLetter{letterChar:: Char} deriving (Eq, Show, Typeable)
+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
coarbitrary enum = variant (case enum of {One -> 0; Two -> 1; Three -> 2; Four -> 3; Five -> 4})
instance Arbitrary Char where
@@ -520,9 +583,15 @@
arbitrary = fmap LowercaseLetter (choose ('a', 'z'))
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
+ coarbitrary c = coarbitrary (with c)
+
instance Arbitrary (Splitter Identity Int ()) where
- arbitrary = fmap splitterFromTrace arbitrary
- coarbitrary s gen = sized (\n-> coarbitrary (transducerOutput (ifs s
- (lift121Transducer "true" $ const True)
- (lift121Transducer "false" $ const False))
+ arbitrary = fmap splitterFromTrace' arbitrary
+--instance CoArbitrary (Splitter Identity Int ()) where
+ coarbitrary s gen = sized (\n-> coarbitrary (transducerOutput' (Combinator.ifs False s
+ (oneToOneTransducer $ const True)
+ (oneToOneTransducer $ const False))
[1..n]) gen)
diff --git a/scc.cabal b/scc.cabal
--- a/scc.cabal
+++ b/scc.cabal
@@ -1,14 +1,15 @@
Name: scc
-Version: 0.3
+Version: 0.4
Cabal-Version: >= 1.2
Build-Type: Simple
Synopsis: Streaming component combinators
-Category: Control, Combinators
+Category: Control, Combinators, Concurrency
+Tested-with: GHC
Description:
- SCC is a layered library of Streaming Component Combinators. The lowest layer defines a Pipe monad transformer that
- enables building of producer-consumer coroutine pairs. The next layer adds streaming component
- types, a number of primitive streaming components and a set of component combinators. Finally,
- there is an executable that exposes all functionality in a command-line shell.
+ SCC is a layered library of Streaming Component Combinators. The lowest layer defines the Coroutine monad transformer.
+ The next few layers add stream abstractions and nested producer-consumer coroutine pairs. On top of that are streaming
+ component types, a number of primitive streaming components and a set of component combinators. Finally, there is an
+ executable that exposes all framework functionality in a command-line shell.
.
The original library design is based on paper
.
@@ -16,29 +17,29 @@
License: GPL
License-file: LICENSE.txt
-Copyright: (c) 2008-2009 Mario Blazevic
+Copyright: (c) 2008-2010 Mario Blazevic
Author: Mario Blazevic
Maintainer: blamario@yahoo.com
+Homepage: http://trac.haskell.org/SCC/
Extra-source-files: grammar.bnf Makefile LICENSE.txt Test.hs
+-- Source-repository head
+-- type: darcs
+-- location: http://code.haskell.org/SCC/
Executable shsh
Main-is: Shell.hs
- Other-Modules: Control.Concurrent.SCC.Foundation, Control.Concurrent.SCC.ComponentTypes,
- Control.Concurrent.SCC.Combinators,
- Control.Concurrent.SCC.Components, Control.Concurrent.SCC.XMLComponents
- Build-Depends: base, containers, mtl, parallel, process, readline, parsec >= 3
- GHC-options: "-threaded"
-
-Executable test
- Main-is: Test.hs
- Other-Modules: Control.Concurrent.SCC.Foundation, Control.Concurrent.SCC.ComponentTypes,
- Control.Concurrent.SCC.Combinators,
- Control.Concurrent.SCC.Components, Control.Concurrent.SCC.XMLComponents
- Build-Depends: base, containers, mtl, parallel, QuickCheck < 2
- GHC-options: "-threaded"
+ Other-Modules: Control.Concurrent.Coroutine,
+ 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, parallel, process, readline, parsec >= 3.0 && < 4.0
+ GHC-options: -threaded
Library
- Exposed-Modules: Control.Concurrent.SCC.Foundation, Control.Concurrent.SCC.ComponentTypes,
- Control.Concurrent.SCC.Combinators,
- Control.Concurrent.SCC.Components, Control.Concurrent.SCC.XMLComponents
- Build-Depends: base, containers, mtl, parallel
+ Exposed-Modules: Control.Concurrent.Coroutine, 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, parallel
+ GHC-prof-options: -auto-all