scc 0.3 → 0.4
raw patch · 15 files changed
+3884/−3200 lines, 15 filesdep +transformersdep −QuickCheckdep −mtldep ~basedep ~parsec
Dependencies added: transformers
Dependencies removed: QuickCheck, mtl
Dependency ranges changed: base, parsec
Files
- Control/Concurrent/Configuration.hs +187/−0
- Control/Concurrent/Coroutine.hs +318/−0
- Control/Concurrent/SCC/Combinators.hs +1085/−1197
- Control/Concurrent/SCC/ComponentTypes.hs +0/−491
- Control/Concurrent/SCC/Components.hs +412/−321
- Control/Concurrent/SCC/Foundation.hs +0/−337
- Control/Concurrent/SCC/Primitives.hs +397/−0
- Control/Concurrent/SCC/Streams.hs +214/−0
- Control/Concurrent/SCC/Types.hs +299/−0
- Control/Concurrent/SCC/XML.hs +551/−0
- Control/Concurrent/SCC/XMLComponents.hs +0/−528
- Makefile +2/−1
- Shell.hs +201/−177
- Test.hs +193/−124
- scc.cabal +25/−24
+ Control/Concurrent/Configuration.hs view
@@ -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+ <http://www.gnu.org/licenses/>.+-}++{-# 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)
+ Control/Concurrent/Coroutine.hs view
@@ -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+ <http://www.gnu.org/licenses/>.+-}++-- | 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)
Control/Concurrent/SCC/Combinators.hs view
@@ -14,1200 +14,1088 @@ <http://www.gnu.org/licenses/>. -} -{-# LANGUAGE ScopedTypeVariables, Rank2Types, ImpredicativeTypes, KindSignatures, EmptyDataDecls,- MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, FlexibleInstances #-}---- | The "Combinators" module defines combinators applicable to 'Transducer' and 'Splitter' components defined in the--- "Control.Concurrent.SCC.ComponentTypes" module.--module Control.Concurrent.SCC.Combinators- (-- * Consumer, producer, and transducer combinators- splitterToMarker,- consumeBy, prepend, append, substitute,- PipeableComponentPair ((>->)), JoinableComponentPair (join, sequence),- -- * Pseudo-logic splitter combinators- -- | Combinators '>&' and '>|' are only /pseudo/-logic. While the laws of double negation and De Morgan's laws hold,- -- '>&' and '>|' are in general not commutative, associative, nor idempotent. In the special case when all argument- -- splitters are stateless, such as those produced by 'Components.liftStatelessSplitter', these combinators do satisfy- -- all laws of Boolean algebra.- snot, (>&), (>|),- -- ** Zipping logic combinators- -- | The '&&' and '||' combinators run the argument splitters in parallel and combine their logical outputs using- -- the corresponding logical operation on each output pair, in a manner similar to 'Prelude.zipWith'. They fully- -- satisfy the laws of Boolean algebra.- (&&), (||),- -- * Flow-control combinators- -- | The following combinators resemble the common flow-control programming language constructs. Combinators - -- 'wherever', 'unless', and 'select' are just the special cases of the combinator 'ifs'.- --- -- * /transducer/ ``wherever`` /splitter/ = 'ifs' /splitter/ /transducer/ 'Components.asis'- --- -- * /transducer/ ``unless`` /splitter/ = 'ifs' /splitter/ 'Components.asis' /transducer/- --- -- * 'select' /splitter/ = 'ifs' /splitter/ 'Components.asis' 'Components.suppress'- --- ifs, wherever, unless, select,- -- ** Recursive- while, nestedIn,- -- * Section-based combinators- -- | All combinators in this section use their 'Splitter' argument to determine the- -- structure of the input. Every contiguous portion of the input that gets passed to one or the other sink of the- -- splitter is treated as one section in the logical structure of the input stream. What is done with the section- -- depends on the combinator, but the sections, and therefore the logical structure of the input stream, are- -- determined by the argument splitter alone.- foreach, having, havingOnly, followedBy, even,- -- ** first and its variants- first, uptoFirst, prefix,- -- ** last and its variants- last, lastAndAfter, suffix,- -- ** positional splitters- startOf, endOf,- -- ** input ranges- (...),- -- * parser support- parseRegions, parseNestedRegions,- -- * grouping helpers- groupMarks)-where--import Control.Concurrent.SCC.Foundation-import Control.Concurrent.SCC.ComponentTypes--import Prelude hiding (even, last, sequence, (||), (&&))-import qualified Prelude-import Control.Exception (assert)-import Control.Monad (liftM, when)-import qualified Control.Monad as Monad-import Data.Maybe (isJust, isNothing, fromJust)-import Data.Typeable (Typeable)-import qualified Data.Foldable as Foldable-import qualified Data.Sequence as Seq-import Data.Sequence (Seq, (|>), (><), ViewL (EmptyL, (:<)))--import Debug.Trace (trace)---- | Converts a 'Consumer' into a 'Transducer' with no output.-consumeBy :: forall m x y r. (Monad m, Typeable x) => Consumer m x r -> Transducer m x y-consumeBy c = liftTransducer "consumeBy" (maxUsableThreads c) $- \threads-> let c' = usingThreads threads c- in (ComponentConfiguration [AnyComponent c'] (usedThreads c') (cost c'),- \ source _sink -> consume c' source >> return [])---- | Class 'PipeableComponentPair' applies to any two components that can be combined into a third component with the--- following properties:------ * The input of the result, if any, becomes the input of the first component.------ * The output produced by the first child component is consumed by the second child component.------ * The result output, if any, is the output of the second component.-class PipeableComponentPair (m :: * -> *) w c1 c2 c3 | c1 c2 -> c3, c1 c3 -> c2, c2 c3 -> c2,- c1 -> m w, c2 -> m w, c3 -> m- where (>->) :: c1 -> c2 -> c3--instance (ParallelizableMonad m, Typeable x)- => PipeableComponentPair m x (Producer m x ()) (Consumer m x ()) (Performer m ())- where p >-> c = liftPerformer ">->" (maxUsableThreads p `max` maxUsableThreads c) $- \threads-> let (configuration, p', c', parallel) = optimalTwoParallelConfigurations threads p c- performPipe = (if parallel then pipeP else pipe) (produce p') (consume c') >> return ()- in (configuration, performPipe)--instance (ParallelizableMonad m, Typeable x, Typeable y)- => PipeableComponentPair m y (Transducer m x y) (Consumer m y r) (Consumer m x r)- where t >-> c = liftConsumer ">->" (maxUsableThreads t `max` maxUsableThreads c) $- \threads-> let (configuration, t', c', parallel) = optimalTwoParallelConfigurations threads t c- consumePipe source = liftM snd $ (if parallel then pipeP else pipe)- (transduce t' source)- (consume c')- in (configuration, consumePipe)--instance (ParallelizableMonad m, Typeable x, Typeable y)- => PipeableComponentPair m x (Producer m x r) (Transducer m x y) (Producer m y r)- where p >-> t = liftProducer ">->" (maxUsableThreads t `max` maxUsableThreads p) $- \threads-> let (configuration, p', t', parallel) = optimalTwoParallelConfigurations threads p t- producePipe sink = liftM fst $ (if parallel then pipeP else pipe)- (produce p')- (\source-> transduce t' source sink)- in (configuration, producePipe)--instance ParallelizableMonad m => PipeableComponentPair m y (Transducer m x y) (Transducer m y z) (Transducer m x z)- where t1 >-> t2 = liftTransducer ">->" (maxUsableThreads t1 + maxUsableThreads t2) $- \threads-> let (configuration, t1', t2', parallel) = optimalTwoParallelConfigurations threads t1 t2- transducePipe source sink = liftM fst $ (if parallel then pipeP else pipe)- (transduce t1' source)- (\source-> transduce t2' source sink)- in (configuration, transducePipe)--class Component c => CompatibleSignature c cons (m :: * -> *) input output | c -> cons m--class AnyListOrUnit c--instance AnyListOrUnit [x]-instance AnyListOrUnit ()--instance (AnyListOrUnit x, AnyListOrUnit y) => CompatibleSignature (Performer m r) (PerformerType r) m x y-instance AnyListOrUnit y => CompatibleSignature (Consumer m x r) (ConsumerType r) m [x] y-instance AnyListOrUnit y => CompatibleSignature (Producer m x r) (ProducerType r) m y [x]-instance CompatibleSignature (Transducer m x y) TransducerType m [x] [y]--data PerformerType r-data ConsumerType r-data ProducerType r-data TransducerType---- | Class 'JoinableComponentPair' applies to any two components that can be combined into a third component with the--- following properties:------ * if both argument components consume input, the input of the combined component gets distributed to both--- components in parallel,------ * if both argument components produce output, the output of the combined component is a concatenation of the--- complete output from the first component followed by the complete output of the second component, and------ * the 'join' method may apply the components in any order, the 'sequence' method makes sure its first argument--- has completed before using the second one.-class (Monad m, CompatibleSignature c1 t1 m x y, CompatibleSignature c2 t2 m x y, CompatibleSignature c3 t3 m x y)- => JoinableComponentPair t1 t2 t3 m x y c1 c2 c3 | c1 c2 -> c3, c1 -> t1 m, c2 -> t2 m, c3 -> t3 m x y,- t1 m x y -> c1, t2 m x y -> c2, t3 m x y -> c3- where join :: c1 -> c2 -> c3- sequence :: c1 -> c2 -> c3- join = sequence--instance forall m x any r1 r2. (Monad m, Typeable x)- => JoinableComponentPair (ProducerType r1) (ProducerType r2) (ProducerType r2) m () [x] (Producer m x r1) (Producer m x r2) (Producer m x r2)- where sequence p1 p2 = liftProducer "sequence" (maxUsableThreads p1 `max` maxUsableThreads p2) $- \threads-> let (configuration, p1', p2') = optimalTwoSequentialConfigurations threads p1 p2- produceJoin sink = produce p1' sink >> produce p2' sink- in (configuration, produceJoin)--instance forall m x any. (ParallelizableMonad m, Typeable x)- => JoinableComponentPair (ConsumerType ()) (ConsumerType ()) (ConsumerType ()) m [x] () (Consumer m x ()) (Consumer m x ()) (Consumer m x ())- where join c1 c2 = liftConsumer "join" (maxUsableThreads c1 + maxUsableThreads c2) $- \threads-> let (configuration, c1', c2', parallel) = optimalTwoParallelConfigurations threads c1 c2- consumeJoin source = do (if parallel then pipeP else pipe)- (\sink1-> pipe (tee source sink1) (consume c2'))- (consume c1')- return ()- in (configuration, consumeJoin)- sequence c1 c2 = liftConsumer "sequence" (maxUsableThreads c1 `max` maxUsableThreads c2) $- \threads-> let (configuration, c1', c2') = optimalTwoSequentialConfigurations threads c1 c2- consumeJoin source = pipe- (\buffer-> pipe (tee source buffer) (consume c1'))- getList- >>= \(_, list)-> pipe (putList list) (consume c2')- >> return ()- in (configuration, consumeJoin)--instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)- => JoinableComponentPair TransducerType TransducerType TransducerType m [x] [y] (Transducer m x y) (Transducer m x y) (Transducer m x y)- where join t1 t2 = liftTransducer "join" (maxUsableThreads t1 + maxUsableThreads t2) $- \threads-> let (configuration, t1', t2', parallel) = optimalTwoParallelConfigurations threads t1 t2- transduce' source sink = pipe- (\buffer-> (if parallel then pipeP else pipe)- (\sink1-> pipe- (\sink2-> tee source sink1 sink2)- (\src-> transduce t2' src buffer))- (\source-> transduce t1' source sink))- getList- >>= \(_, list)-> putList list sink- >> getList source- in (configuration, transduce')- sequence t1 t2 = liftTransducer "sequence" (maxUsableThreads t1 `max` maxUsableThreads t2) $- \threads-> let (configuration, t1', t2') = optimalTwoSequentialConfigurations threads t1 t2- transduce' source sink = pipe- (\buffer-> pipe- (tee source buffer)- (\source-> transduce t1 source sink))- getList- >>= \(_, list)-> pipe- (\sink-> putList list sink- >>= whenNull- (pour source sink- >> return []))- (\source-> transduce t2 source sink)- >>= return . fst- in (configuration, transduce')---instance forall m r1 r2. ParallelizableMonad m- => JoinableComponentPair (PerformerType r1) (PerformerType r2) (PerformerType r2) m () () (Performer m r1) (Performer m r2) (Performer m r2)- where join p1 p2 = liftPerformer "join" (maxUsableThreads p1 + maxUsableThreads p2) $- \threads-> let (configuration, p1', p2', parallel) = optimalTwoParallelConfigurations threads p1 p2- in (configuration, if parallel then liftM snd $ perform p1' `parallelize` perform p2'- else perform p1' >> perform p2')- sequence p1 p2 = liftPerformer "sequence" (maxUsableThreads p1 `max` maxUsableThreads p2) $- \threads-> let (configuration, p1', p2') = optimalTwoSequentialConfigurations threads p1 p2- in (configuration, perform p1' >> perform p2')--instance forall m x r1 r2. (ParallelizableMonad m, Typeable x)- => JoinableComponentPair (PerformerType r1) (ProducerType r2) (ProducerType r2) m () [x] (Performer m r1) (Producer m x r2) (Producer m x r2)- where join pe pr = liftProducer "join" (maxUsableThreads pe + maxUsableThreads pr) $- \threads-> let (configuration, pe', pr', parallel) = optimalTwoParallelConfigurations threads pe pr- produceJoin sink = if parallel then liftM snd (perform pe' `parallelize` produce pr' sink)- else perform pe' >> produce pr' sink- in (configuration, produceJoin)- sequence pe pr = liftProducer "sequence" (maxUsableThreads pe `max` maxUsableThreads pr) $- \threads-> let (configuration, pe', pr') = optimalTwoSequentialConfigurations threads pe pr- produceJoin sink = perform pe' >> produce pr' sink- in (configuration, produceJoin)--instance forall m x r1 r2. (ParallelizableMonad m, Typeable x)- => JoinableComponentPair (ProducerType r1) (PerformerType r2) (ProducerType r2) m () [x] (Producer m x r1) (Performer m r2) (Producer m x r2)- where join pr pe = liftProducer "join" (maxUsableThreads pr + maxUsableThreads pe) $- \threads-> let (configuration, pr', pe', parallel) = optimalTwoParallelConfigurations threads pr pe- produceJoin sink = if parallel then liftM snd (produce pr' sink `parallelize` perform pe')- else produce pr' sink >> perform pe'- in (configuration, produceJoin)- sequence pr pe = liftProducer "sequence" (maxUsableThreads pr `max` maxUsableThreads pe) $- \threads-> let (configuration, pr', pe') = optimalTwoSequentialConfigurations threads pr pe- produceJoin sink = produce pr' sink >> perform pe'- in (configuration, produceJoin)--instance forall m x r1 r2. (ParallelizableMonad m, Typeable x)- => JoinableComponentPair (PerformerType r1) (ConsumerType r2) (ConsumerType r2) m [x] () (Performer m r1) (Consumer m x r2) (Consumer m x r2)- where join p c = liftConsumer "join" (maxUsableThreads p + maxUsableThreads c) $- \threads-> let (configuration, p', c', parallel) = optimalTwoParallelConfigurations threads p c- consumeJoin source = if parallel then liftM snd (perform p' `parallelize` consume c' source)- else perform p' >> consume c' source- in (configuration, consumeJoin)- sequence p c = liftConsumer "sequence" (maxUsableThreads p `max` maxUsableThreads c) $- \threads-> let (configuration, p', c') = optimalTwoSequentialConfigurations threads p c- consumeJoin source = perform p' >> consume c' source- in (configuration, consumeJoin)--instance forall m x r1 r2. (ParallelizableMonad m, Typeable x)- => JoinableComponentPair (ConsumerType r1) (PerformerType r2) (ConsumerType r2) m [x] () (Consumer m x r1) (Performer m r2) (Consumer m x r2)- where join c p = liftConsumer "join" (maxUsableThreads c + maxUsableThreads p) $- \threads-> let (configuration, c', p', parallel) = optimalTwoParallelConfigurations threads c p- consumeJoin source = if parallel then liftM snd (consume c' source `parallelize` perform p')- else consume c' source >> perform p'- in (configuration, consumeJoin)- sequence c p = liftConsumer "sequence" (maxUsableThreads c `max` maxUsableThreads p) $- \threads-> let (configuration, c', p') = optimalTwoSequentialConfigurations threads c p- consumeJoin source = consume c' source >> perform p'- in (configuration, consumeJoin)--instance forall m x y r. (ParallelizableMonad m, Typeable x, Typeable y)- => JoinableComponentPair (PerformerType r) TransducerType TransducerType m [x] [y] (Performer m r) (Transducer m x y) (Transducer m x y)- where join p t = liftTransducer "join" (maxUsableThreads p + maxUsableThreads t) $- \threads-> let (configuration, p', t', parallel) = optimalTwoParallelConfigurations threads p t- join' source sink = if parallel then liftM snd (perform p'- `parallelize` transduce t' source sink)- else perform p' >> transduce t' source sink- in (configuration, join')- sequence p t = liftTransducer "sequence" (maxUsableThreads p `max` maxUsableThreads t) $- \threads-> let (configuration, p', t') = optimalTwoSequentialConfigurations threads p t- join' source sink = perform p' >> transduce t' source sink- in (configuration, join')--instance forall m x y r. (ParallelizableMonad m, Typeable x, Typeable y)- => JoinableComponentPair TransducerType (PerformerType r) TransducerType m [x] [y] (Transducer m x y) (Performer m r) (Transducer m x y)- where join t p = liftTransducer "join" (maxUsableThreads t + maxUsableThreads p) $- \threads-> let (configuration, t', p', parallel) = optimalTwoParallelConfigurations threads t p- join' source sink = if parallel then liftM fst (transduce t' source sink- `parallelize` perform p')- else do result <- transduce t' source sink- perform p'- return result- in (configuration, join')- sequence t p = liftTransducer "sequence" (maxUsableThreads t `max` maxUsableThreads p) $- \threads-> let (configuration, t', p') = optimalTwoSequentialConfigurations threads t p- join' source sink = do result <- transduce t' source sink- perform p'- return result- in (configuration, join')--instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)- => JoinableComponentPair (ProducerType ()) TransducerType TransducerType m [x] [y] (Producer m y ()) (Transducer m x y) (Transducer m x y)- where join p t = liftTransducer "join" (maxUsableThreads p + maxUsableThreads t) $- \threads-> let (configuration, p', t', parallel) = optimalTwoParallelConfigurations threads p t- join' source sink = if parallel- then do ((_, rest), out) <- pipe- (\buffer-> produce p' sink `parallelize`- transduce t' source buffer)- getList- putList out sink- return rest - else produce p' sink >> transduce t' source sink- in (configuration, join')- sequence p t = liftTransducer "sequence" (maxUsableThreads p `max` maxUsableThreads t) $- \threads-> let (configuration, p', t') = optimalTwoSequentialConfigurations threads p t- join' source sink = produce p' sink >> transduce t' source sink- in (configuration, join')--instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)- => JoinableComponentPair TransducerType (ProducerType ()) TransducerType m [x] [y] (Transducer m x y) (Producer m y ()) (Transducer m x y)- where join t p = liftTransducer "join" (maxUsableThreads t `max` maxUsableThreads p) $- \threads-> let (configuration, t', p', parallel) = optimalTwoParallelConfigurations threads t p- join' source sink = if parallel- then do ((rest, ()), out) <- pipe- (\buffer-> transduce t' source sink- `parallelize` produce p' buffer)- getList- putList out sink- return rest - else do result <- transduce t' source sink- produce p' sink- return result- in (configuration, join')- sequence t p = liftTransducer "sequence" (maxUsableThreads t `max` maxUsableThreads p) $- \threads-> let (configuration, t', p') = optimalTwoSequentialConfigurations threads t p- join' source sink = do result <- transduce t' source sink- produce p' sink- return result- in (configuration, join')--instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)- => JoinableComponentPair (ConsumerType ()) TransducerType TransducerType m [x] [y] (Consumer m x ()) (Transducer m x y) (Transducer m x y)- where join c t = liftTransducer "join" (maxUsableThreads c + maxUsableThreads t) $- \threads-> let (configuration, c', t', parallel) = optimalTwoParallelConfigurations threads c t- join' source sink = liftM (snd . fst) $- (if parallel then pipeP else pipe)- (\sink1-> pipe- (tee source sink1)- (\source-> transduce t' source sink))- (consume c')- in (configuration, join')- sequence c t = liftTransducer "sequence" (maxUsableThreads c `max` maxUsableThreads t) $- \threads-> let (configuration, c', t') = optimalTwoSequentialConfigurations threads c t- sequence' source sink = pipe- (\buffer-> pipe- (tee source buffer)- (consume c'))- getList- >>= \(_, list)-> pipe- (\sink-> putList list sink- >>= whenNull (pour source sink- >> return []))- (\source-> transduce t' source sink)- >>= return . fst- in (configuration, sequence')--instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)- => JoinableComponentPair TransducerType (ConsumerType ()) TransducerType m [x] [y] (Transducer m x y) (Consumer m x ()) (Transducer m x y)- where join t c = join c t- sequence t c = liftTransducer "sequence" (maxUsableThreads t `max` maxUsableThreads c) $- \threads-> let (configuration, t', c') = optimalTwoSequentialConfigurations threads t c- sequence' source sink = pipe- (\buffer-> pipe- (tee source buffer)- (\source-> transduce t' source sink))- getList- >>= \(_, list)-> pipe- (\sink-> putList list sink- >>= whenNull (pour source sink- >> return []))- (consume c')- >>= return . fst- in (configuration, sequence')--instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)- => JoinableComponentPair (ProducerType ()) (ConsumerType ()) TransducerType m [x] [y] (Producer m y ()) (Consumer m x ()) (Transducer m x y)- where join p c = liftTransducer "sequence" (maxUsableThreads p + maxUsableThreads c) $- \threads-> let (configuration, p', c', parallel) = optimalTwoParallelConfigurations threads p c- join' source sink = if parallel then produce p' sink >> consume c' source >> return []- else parallelize (produce p' sink) (consume c' source) >> return []- in (configuration, join')- sequence p c = liftTransducer "sequence" (maxUsableThreads p `max` maxUsableThreads c) $- \threads-> let (configuration, p', c') = optimalTwoSequentialConfigurations threads p c- join' source sink = produce p' sink >> consume c' source >> return []- in (configuration, join')--instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)- => JoinableComponentPair (ConsumerType ()) (ProducerType ()) TransducerType m [x] [y] (Consumer m x ()) (Producer m y ()) (Transducer m x y)- where join c p = join p c- sequence c p = liftTransducer "sequence" (maxUsableThreads c `max` maxUsableThreads p) $- \threads-> let (configuration, c', p') = optimalTwoSequentialConfigurations threads c p- join' source sink = consume c' source >> produce p' sink >> return []- in (configuration, join')---- | Combinator 'prepend' converts the given producer to transducer that passes all its input through unmodified, except--- | for prepending the output of the argument producer to it.--- | 'prepend' /prefix/ = 'join' ('substitute' /prefix/) 'asis'-prepend :: forall m x r. (Monad m, Typeable x) => Producer m x r -> Transducer m x x-prepend prefix = liftTransducer "prepend" (maxUsableThreads prefix) $- \threads-> let prefix' = usingThreads threads prefix- prepend' source sink = produce prefix' sink >> pour source sink >> return []- in (ComponentConfiguration [AnyComponent prefix] threads (cost prefix'), prepend')---- | Combinator 'append' converts the given producer to transducer that passes all its input through unmodified, finally--- | appending to it the output of the argument producer.--- | 'append' /suffix/ = 'join' 'asis' ('substitute' /suffix/)-append :: forall m x r. (Monad m, Typeable x) => Producer m x r -> Transducer m x x-append suffix = liftTransducer "append" (maxUsableThreads suffix) $- \threads-> let suffix' = usingThreads threads suffix- append' source sink = pour source sink >> produce suffix' sink >> return []- in (ComponentConfiguration [AnyComponent suffix] threads (cost suffix'), append')---- | The 'substitute' combinator converts its argument producer to a transducer that produces the same output, while--- | consuming its entire input and ignoring it.-substitute :: forall m x y r. (Monad m, Typeable x, Typeable y) => Producer m y r -> Transducer m x y-substitute feed = liftTransducer "substitute" (maxUsableThreads feed) $- \threads-> let feed' = usingThreads threads feed- substitute' source sink = consumeAndSuppress source >> produce feed' sink >> return []- in (ComponentConfiguration [AnyComponent feed] threads (cost feed'), substitute')---- | The 'snot' (streaming not) combinator simply reverses the outputs of the argument splitter.--- In other words, data that the argument splitter sends to its /true/ sink goes to the /false/ sink of the result, and vice versa.-snot :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x b-snot splitter = liftSplitter "not" (maxUsableThreads splitter) $- \threads-> let splitter' = usingThreads threads splitter- not source true false edge = liftM fst $- pipe- (split splitter source false true)- consumeAndSuppress- in (ComponentConfiguration [AnyComponent splitter'] threads (cost splitter'), not)---- | The '>&' combinator sends the /true/ sink output of its left operand to the input of its right operand for further--- splitting. Both operands' /false/ sinks are connected to the /false/ sink of the combined splitter, but any input--- value to reach the /true/ sink of the combined component data must be deemed true by both splitters.-(>&) :: (ParallelizableMonad m, Typeable x, Typeable b1, Typeable b2) => Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)-s1 >& s2 = liftSplitter ">&" (maxUsableThreads s1 + maxUsableThreads s2) $- \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2- s source true false edge = liftM (fst . fst . fst . fst) $- pipe- (\edges->- pipe- (\edge1-> pipe- (\edge2-> (if parallel then pipeP else pipe)- (\true-> split s1' source true false edge1)- (\source-> split s2' source true false edge2))- (flip (pourMap Right) edges))- (flip (pourMap Left) edges))- (flip intersectRegions edge)- in (configuration, s)--intersectRegions source sink = next Nothing Nothing- where next lastLeft lastRight = get source- >>= maybe- (return ())- (either- (flip pair lastRight . Just)- (pair lastLeft . Just))- pair l@(Just x) r@(Just y) = put sink (x, y)- >>= flip when (next Nothing Nothing)- pair l r = next l r---- | A '>|' combinator's input value can reach its /false/ sink only by going through both argument splitters' /false/--- sinks.-(>|) :: forall m x b1 b2. (ParallelizableMonad m, Typeable x, Typeable b1, Typeable b2)- => Splitter m x b1 -> Splitter m x b2 -> Splitter m x (Either b1 b2)-s1 >| s2 = liftSplitter ">|" (maxUsableThreads s1 + maxUsableThreads s2) $- \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2- s source true false edge = liftM (fst . fst . fst) $- pipe- (\edge1-> pipe- (\edge2-> (if parallel then pipeP else pipe)- (\false-> split s1' source true false edge1)- (\source-> split s2' source true false edge2))- (flip (pourMap Right) edge))- (flip (pourMap Left) edge)- in (configuration, s)---- | Combinator '&&' is a pairwise logical conjunction of two splitters run in parallel on the same input.-(&&) :: (ParallelizableMonad m, Typeable x, Typeable b1, Typeable b2) => Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)-s1 && s2 = liftSplitter "&&" (maxUsableThreads s1 + maxUsableThreads s2) $- \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2- s source true false edge = liftM (\(x, y)-> y ++ x) $- (if parallel then pipeP else pipe)- (transduce (splittersToPairMarker s1' s2') source)- (\source-> let split l r = get source- >>= maybe- (return [])- (test l r)- test l r (Left (x, t1, t2))- = put (if t1 Prelude.&& t2 then true else false) x- >>= cond- (split- (if t1 then l else Nothing)- (if t2 then r else Nothing))- (return [x])- test _ Nothing (Right (Left l)) = split (Just l) Nothing- test _ (Just r) (Right (Left l))- = put edge (l, r) >> split (Just l) (Just r)- test Nothing _ (Right (Right r)) = split Nothing (Just r)- test (Just l) _ (Right (Right r))- = put edge (l, r) >> split (Just l) (Just r)- in split Nothing Nothing)- in (configuration, s)---- | Combinator '||' is a pairwise logical disjunction of two splitters run in parallel on the same input.-(||) :: (ParallelizableMonad m, Typeable x, Typeable b1, Typeable b2)- => Splitter m x b1 -> Splitter m x b2 -> Splitter m x (Either b1 b2)-(||) = zipSplittersWith (Prelude.||) pour--ifs :: (ParallelizableMonad m, Typeable x, Typeable b, BranchComponent cc m x [x]) => Splitter m x b -> cc -> cc -> cc-ifs s = combineBranches "if" (cost s) (\ parallel c1 c2 -> \source-> splitInputToConsumers parallel s source c1 c2)--wherever :: (ParallelizableMonad m, Typeable x, Typeable b) => Transducer m x x -> Splitter m x b -> Transducer m x x-wherever t s = liftTransducer "wherever" (maxUsableThreads s + maxUsableThreads t) $- \threads-> let (configuration, s', t', parallel) = optimalTwoParallelConfigurations threads s t- wherever' source sink = splitInputToConsumers parallel s source- (\source-> transduce t source sink)- (\source-> pour source sink >> return [])- in (configuration, wherever')--unless :: (ParallelizableMonad m, Typeable x, Typeable b) => Transducer m x x -> Splitter m x b -> Transducer m x x-unless t s = liftTransducer "unless" (maxUsableThreads s + maxUsableThreads t) $- \threads-> let (configuration, s', t', parallel) = optimalTwoParallelConfigurations threads s t- unless' source sink = splitInputToConsumers parallel s source- (\source-> pour source sink >> return [])- (\source-> transduce t source sink)- in (configuration, unless')--select :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Transducer m x x-select s = liftTransducer "select" (maxUsableThreads s) $- \threads-> let s' = usingThreads threads s- transduce' source sink = splitInputToConsumers False s' source- (\source-> pour source sink >> return [])- (\source-> consumeAndSuppress source >> return [])- in (ComponentConfiguration [AnyComponent s'] threads (cost s' + 1), transduce')---- | Converts a splitter into a parser.-parseRegions :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Parser m x b-parseRegions s = liftTransducer "parseRegions" (maxUsableThreads s) $- \threads-> let s' = usingThreads threads s- transduce' source sink = liftM (\(x, y)-> y ++ x) $- pipe- (transduce (splitterToMarker s') source)- (\source-> wrapRegions source sink)- wrapRegions source sink = let wrap0 mb = get source- >>= maybe- (maybe (return True) flush mb >> return [])- (wrap1 mb)- wrap1 Nothing (Left (x, _)) = put sink (Content x)- >>= cond (wrap0 Nothing) (return [x])- wrap1 (Just p) (Left (x, False)) = flush p- >> put sink (Content x)- >>= cond- (wrap0 Nothing)- (return [x])- wrap1 (Just (b, t)) (Left (x, True))- = (if t then return True else put sink (Markup (Start b)))- >> put sink (Content x)- >>= cond (wrap0 (Just (b, True))) (return [x])- wrap1 (Just p) (Right b') = flush p >> wrap0 (Just (b', False))- wrap1 Nothing (Right b) = wrap0 (Just (b, False))- flush (b, t) = put sink $ Markup $ (if t then End else Point) b- in wrap0 Nothing- in (ComponentConfiguration [AnyComponent s'] threads (cost s' + 1), transduce')---- | Converts a boundary-marking splitter into a parser.-parseNestedRegions :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x (Boundary b) -> Parser m x b-parseNestedRegions s = liftTransducer "parseNestedRegions" (maxUsableThreads s) $- \threads-> let s' = usingThreads threads s- transduce' source sink = liftM (\(w, (), (), _)-> w) $- splitToConsumers s' source- (flip (pourMap Content) sink)- (flip (pourMap Content) sink)- (flip (pourMap Markup) sink)- in (ComponentConfiguration [AnyComponent s'] threads (cost s' + 1), transduce')---- | The recursive combinator 'while' feeds the true sink of the argument splitter back to itself, modified by the--- argument transducer. Data fed to the splitter's false sink is passed on unmodified.-while :: (ParallelizableMonad m, Typeable x, Typeable b) => Transducer m x x -> Splitter m x b -> Transducer m x x-while t s = liftTransducer "while" (maxUsableThreads t + maxUsableThreads s) $- \threads-> let (configuration, s', while'', parallel) = optimalTwoParallelConfigurations threads s while'- transduce' source sink = splitInputToConsumers parallel s' source- (\source-> transduce while' source sink)- (\source-> pour source sink >> return [])- while' = t >-> while t s- in (configuration, transduce')---- | The recursive combinator 'nestedIn' combines two splitters into a mutually recursive loop acting as a single splitter.--- The true sink of one of the argument splitters and false sink of the other become the true and false sinks of the loop.--- The other two sinks are bound to the other splitter's source.--- The use of 'nestedIn' makes sense only on hierarchically structured streams. If we gave it some input containing--- a flat sequence of values, and assuming both component splitters are deterministic and stateless,--- an input value would either not loop at all or it would loop forever.-nestedIn :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x b -> Splitter m x b-nestedIn s1 s2 = liftSplitter "nestedIn" (maxUsableThreads s1 + maxUsableThreads s2) $- \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2- s source true false edge- = liftM fst $- (if parallel then pipeP else pipe)- (\false-> split s1' source true false edge)- (\source-> pipe- (\true-> pipe (split s2' source true false) consumeAndSuppress)- (\source-> get source- >>= maybe- (return ([], []))- (\x-> pipe- (\sink-> put sink x- >>= cond- (pour source sink- >> return [])- (return [x]))- (\source-> split- (nestedIn s1' s2')- source true false edge))))- in (configuration,s)---- | The 'foreach' combinator is similar to the combinator 'ifs' in that it combines a splitter and two transducers into--- another transducer. However, in this case the transducers are re-instantiated for each consecutive portion of the--- input as the splitter chunks it up. Each contiguous portion of the input that the splitter sends to one of its two--- sinks gets transducered through the appropriate argument transducer as that transducer's whole input. As soon as the--- contiguous portion is finished, the transducer gets terminated.-foreach :: (ParallelizableMonad m, Typeable x, Typeable b, BranchComponent cc m x [x]) => Splitter m x b -> cc -> cc -> cc-foreach s = combineBranches "foreach" (cost s)- (\ parallel c1 c2 source-> liftM fst $ (if parallel then pipeP else pipe)- (transduce (splitterToMarker s) source)- (\source-> groupMarks source (maybe c2 (const c1))))---- | The 'having' combinator combines two pure splitters into a pure splitter. One splitter is used to chunk the input--- into contiguous portions. Its /false/ sink is routed directly to the /false/ sink of the combined splitter. The--- second splitter is instantiated and run on each portion of the input that goes to first splitter's /true/ sink. If--- the second splitter sends any output at all to its /true/ sink, the whole input portion is passed on to the /true/--- sink of the combined splitter, otherwise it goes to its /false/ sink.-having :: (ParallelizableMonad m, Typeable x, Typeable b1, Typeable b2)- => Splitter m x b1 -> Splitter m x b2 -> Splitter m x b1-having s1 s2 = liftSplitter "having" (maxUsableThreads s1 + maxUsableThreads s2) $- \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2- s source true false edge = liftM fst $- (if parallel then pipeP else pipe)- (transduce (splitterToMarker s1') source)- (flip groupMarks test)- where test Nothing chunk = pour chunk false >> return []- test (Just mb) chunk = pipe- (\sink1-> pipe (tee chunk sink1) getList)- (\chunk-> splitToConsumers s2' chunk- (liftM isJust . get)- consumeAndSuppress- (liftM isJust . get))- >>= \(((), prefix), (_, anyTrue, (), anyEdge))->- if anyTrue Prelude.|| anyEdge- then maybe (return True) (put edge) mb- >> putList prefix true- >>= whenNull (pour chunk true >> return [])- else putList prefix false- >>= whenNull (pour chunk false >> return [])- in (configuration, s)---- | The 'havingOnly' combinator is analogous to the 'having' combinator, but it succeeds and passes each chunk of the--- input to its /true/ sink only if the second splitter sends no part of it to its /false/ sink.-havingOnly :: (ParallelizableMonad m, Typeable x, Typeable b1, Typeable b2)- => Splitter m x b1 -> Splitter m x b2 -> Splitter m x b1-havingOnly s1 s2 = liftSplitter "havingOnly" (maxUsableThreads s1 + maxUsableThreads s2) $- \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2- s source true false edge = liftM fst $- (if parallel then pipeP else pipe)- (transduce (splitterToMarker s1') source)- (flip groupMarks test)- where test Nothing chunk = pour chunk false >> return []- test (Just mb) chunk = pipe- (\sink1-> pipe (tee chunk sink1) getList)- (\chunk-> splitToConsumers s2' chunk- consumeAndSuppress- (liftM isJust . get)- consumeAndSuppress)- >>= \(((), prefix), (_, (), anyFalse, ()))->- if anyFalse- then putList prefix false- >>= whenNull (pour chunk false >> return [])- else maybe (return True) (put edge) mb- >> putList prefix true- >>= whenNull (pour chunk true >> return [])- in (configuration, s)---- | The result of combinator 'first' behaves the same as the argument splitter up to and including the first portion of--- the input which goes into the argument's /true/ sink. All input following the first true portion goes into the--- /false/ sink.-first :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x b-first splitter = liftSplitter "first" (maxUsableThreads splitter) $- \threads-> let splitter' = usingThreads threads splitter- configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)- s source true false edge- = liftM (\(x, y)-> y ++ x) $- pipeD "first" (transduce (splitterToMarker splitter') source)- (\source-> let get1 (Left (x, False)) = pass false x get1- get1 (Left (x, True)) = pass true x get2- get1 (Right b) = put edge b- >> get source- >>= maybe (return []) get2- get2 b@Right{} = get3 b- get2 (Left (x, True)) = pass true x get2- get2 (Left (x, False)) = pass false x get3- get3 (Left (x, _)) = pass false x get3- get3 (Right _) = get source >>= maybe (return []) get3- pass sink x next = put sink x- >>= cond- (get source >>= maybe (return []) next)- (return [x])- in get source >>= maybe (return []) get1)- in (configuration, s)---- | The result of combinator 'uptoFirst' takes all input up to and including the first portion of the input which goes--- into the argument's /true/ sink and feeds it to the result splitter's /true/ sink. All the rest of the input goes--- into the /false/ sink. The only difference between 'first' and 'uptoFirst' combinators is in where they direct the--- /false/ portion of the input preceding the first /true/ part.-uptoFirst :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x b-uptoFirst splitter = liftSplitter "uptoFirst" (maxUsableThreads splitter) $- \threads-> let splitter' = usingThreads threads splitter- configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)- s source true false edge- = liftM (\(x, y)-> y ++ x) $- pipeD "uptoFirst" (transduce (splitterToMarker splitter') source)- (\source-> let get1 q (Left (x, False)) = let q' = q |> x- in get source- >>= maybe- (putQueue q' false)- (get1 q')- get1 q p@(Left (_, True)) = putQueue q true- >>= whenNull (get2 p)- get1 q (Right b) = putQueue q true- >>= whenNull (put edge b- >> get source- >>= maybe (return []) get2)- get2 b@Right{} = get3 b- get2 (Left (x, True)) = pass true x get2- get2 (Left (x, False)) = pass false x get3- get3 (Left (x, _)) = pass false x get3- get3 (Right _) = get source >>= maybe (return []) get3- pass sink x next = put sink x- >>= cond- (get source >>= maybe (return []) next)- (return [x])- in get source >>= maybe (return []) (get1 Seq.empty))- in (configuration, s)---- | The result of the combinator 'last' is a splitter which directs all input to its /false/ sink, up to the last--- portion of the input which goes to its argument's /true/ sink. That portion of the input is the only one that goes to--- the resulting component's /true/ sink. The splitter returned by the combinator 'last' has to buffer the previous two--- portions of its input, because it cannot know if a true portion of the input is the last one until it sees the end of--- the input or another portion succeeding the previous one.-last :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x b-last splitter = liftSplitter "last" (maxUsableThreads splitter) $- \threads-> let splitter' = usingThreads threads splitter- configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)- s source true false edge- = liftM (\(x, y)-> y ++ x) $- pipeD "last" (transduce (splitterToMarker splitter') source)- (\source-> let get1 (Left (x, False)) = put false x- >>= cond (get source- >>= maybe (return []) get1)- (return [x])- get1 p@(Left (x, True)) = get2 Nothing Seq.empty p- get1 (Right b) = pass (get2 (Just b) Seq.empty)- get2 mb q (Left (x, True)) = let q' = q |> x- in get source- >>= maybe- (flush mb q')- (get2 mb q')- get2 mb q p = get3 mb q Seq.empty p- get3 mb qt qf (Left (x, False)) = let qf' = qf |> x- in get source- >>= maybe- (flush mb qt >> putQueue qf' false)- (get3 mb qt qf')- get3 mb qt qf p = do rest1 <- putQueue qt false- rest2 <- putQueue qf false - if null rest1 Prelude.&& null rest2- then get1 p- else return (rest1 ++ rest2)- flush mb q = maybe (return True) (put edge) mb- >> putQueue q true- pass succeed = get source >>= maybe (return []) succeed- in pass get1)- in (configuration, s)---- | The result of the combinator 'lastAndAfter' is a splitter which directs all input to its /false/ sink, up to the--- last portion of the input which goes to its argument's /true/ sink. That portion and the remainder of the input is fed--- to the resulting component's /true/ sink. The difference between 'last' and 'lastAndAfter' combinators is where they--- feed the /false/ portion of the input, if any, remaining after the last /true/ part.-lastAndAfter :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x b-lastAndAfter splitter = liftSplitter "lastAndAfter" (maxUsableThreads splitter) $- \threads-> let splitter' = usingThreads threads splitter- configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)- s source true false edge- = liftM (\(x, y)-> y ++ x) $- pipe- (transduce (splitterToMarker splitter') source)- (\source-> let get1 (Left (x, False)) = put false x- >>= cond (pass get1) (return [x])- get1 p@(Left (x, True)) = get2 Nothing Seq.empty p- get1 (Right b) = pass (get2 (Just b) Seq.empty)- get2 mb q (Left (x, True)) = let q' = q |> x- in get source- >>= maybe- (flush mb q')- (get2 mb q')- get2 mb q p = get3 mb q p- get3 mb q (Left (x, False)) = let q' = q |> x- in get source- >>= maybe- (flush mb q')- (get3 mb q')- get3 _ q p@(Left (x, True)) = putQueue q false- >>= whenNull (get1 p)- get3 _ q b'@Right{} = putQueue q false- >>= whenNull (get1 b')- flush mb q = maybe (return True) (put edge) mb- >> putQueue q true- pass succeed = get source >>= maybe (return []) succeed- in pass get1)- in (configuration, s)---- | The 'prefix' combinator feeds its /true/ sink only the prefix of the input that its argument feeds to its /true/ sink.--- All the rest of the input is dumped into the /false/ sink of the result.-prefix :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x b-prefix splitter = liftSplitter "prefix" (maxUsableThreads splitter) $- \threads-> let splitter' = usingThreads threads splitter- configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)- s source true false edge- = liftM (\(x, y)-> y ++ x) $- pipeD "prefix" (transduce (splitterToMarker splitter') source)- (\source-> let get0 p@Left{} = get1 p- get0 (Right b) = put edge b >> get source >>= maybe (return []) get1- get1 (Left (x, False)) = pass false x get2- get1 (Left (x, True)) = pass true x get1- get1 (Right b) = get source >>= maybe (return []) get2- get2 (Left (x, _)) = pass false x get2- get2 Right{} = get source >>= maybe (return []) get2- pass sink x next = put sink x- >>= cond- (get source >>= maybe (return []) next)- (return [x])- in get source >>= maybe (return []) get0)- in (configuration, s)---- | The 'suffix' combinator feeds its /true/ sink only the suffix of the input that its argument feeds to its /true/ sink.--- All the rest of the input is dumped into the /false/ sink of the result.-suffix :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x b-suffix splitter = liftSplitter "suffix" (maxUsableThreads splitter) $- \threads-> let splitter' = usingThreads threads splitter- configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)- s source true false edge- = liftM (\(x, y)-> y ++ x) $- pipeD "suffix" (transduce (splitterToMarker splitter') source)- (\source-> let get1 (Left (x, False)) = put false x >>= cond (p get1) (return [x])- get1 (Left (x, True)) = get2 Nothing (Seq.singleton x)- get1 (Right b) = get2 (Just b) Seq.empty- get2 mb q = get source- >>= maybe- (maybe (return True) (put edge) mb >> putQueue q true)- (get3 mb q)- get3 mb q (Left (x, True)) = get2 mb (q |> x)- get3 mb q p@(Left (x, False)) = putQueue q false- >>= \rest-> if null rest- then get1 p- else return (rest ++ [x])- get3 mb q (Right b) = putQueue q false- >>= whenNull (get2 (Just b) Seq.empty)- p succeed = get source >>= maybe (return []) succeed- in p get1)- in (configuration, s)---- | The 'even' combinator takes every input section that its argument /splitter/ deems /true/, and feeds even ones into--- its /true/ sink. The odd sections and parts of input that are /false/ according to its argument splitter are fed to--- 'even' splitter's /false/ sink.-even :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x b-even splitter = liftSplitter "even" (maxUsableThreads splitter) $- \threads-> let splitter' = usingThreads threads splitter- configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)- s source true false edge- = liftM (\(x, y)-> y ++ x) $- pipeD "even"- (transduce (splitterToMarker splitter') source)- (\source-> let get1 (Left (x, False)) = put false x- >>= cond (next get1) (return [x])- get1 p@(Left (x, True)) = get2 p- get1 (Right b) = next get2- get2 (Left (x, True)) = put false x- >>= cond (next get2) (return [x])- get2 p@(Left (x, False)) = get3 p- get2 (Right b) = put edge b >> next get4- get3 (Left (x, False)) = put false x- >>= cond (next get3) (return [x])- get3 p@(Left (x, True)) = get4 p- get3 (Right b) = put edge b >> next get4- get4 (Left (x, True)) = put true x- >>= cond (next get4) (return [x])- get4 p@(Left (x, False)) = get1 p- get4 (Right b) = next get2- next g = get source >>= maybe (return []) g- in next get1)- in (configuration, s)---- | Splitter 'startOf' issues an empty /true/ section at the beginning of every section considered /true/ by its--- | argument splitter, otherwise the entire input goes into its /false/ sink.-startOf :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x (Maybe b)-startOf splitter = liftSplitter "startOf" (maxUsableThreads splitter) $- \threads-> let splitter' = usingThreads threads splitter- configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)- s source true false edge = liftM (\(x, y)-> y ++ x) $- pipeD "startOf"- (transduce (splitterToMarker splitter') source)- (\source-> let get1 (Left (x, False)) = put false x- >>= cond- (next get1)- (return [x])- get1 p@(Left (x, True)) = put edge Nothing >> get2 p- get1 (Right b) = put edge (Just b)- >> next get2- get2 (Left (x, True)) = put false x- >>= cond- (next get2)- (return [x])- get2 p = get1 p- next g = get source >>= maybe (return []) g- in next get1)- in (configuration, s)---- | Splitter 'endOf' issues an empty /true/ section at the end of every section considered /true/ by its argument--- | splitter, otherwise the entire input goes into its /false/ sink.-endOf :: (ParallelizableMonad m, Typeable x, Typeable b) => Splitter m x b -> Splitter m x (Maybe b)-endOf splitter = liftSplitter "endOf" (maxUsableThreads splitter) $- \threads-> let splitter' = usingThreads threads splitter- configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)- s source true false edge = liftM (\(x, y)-> y ++ x) $- pipeD "endOf"- (transduce (splitterToMarker splitter') source)- (\source-> let get1 (Left (x, False)) = put false x- >>= cond- (next get1)- (return [x])- get1 p@(Left (x, True)) = get2 Nothing p- get1 (Right b) = next (get2 $ Just b)- get2 mb (Left (x, True))- = put false x- >>= cond (next $ get2 mb) (return [x])- get2 mb p@(Left (x, False)) = put edge mb >> get1 p- get2 mb (Right b) = put edge mb >> next (get2 $ Just b)- next g = get source >>= maybe (return []) g- in next get1)- in (configuration, s)---- | Combinator 'followedBy' treats its argument 'Splitter's as patterns components and returns a 'Splitter' that--- matches their concatenation. A section of input is considered /true/ by the result iff its prefix is considered--- /true/ by argument /s1/ and the rest of the section is considered /true/ by /s2/. The splitter /s2/ is started anew--- after every section split to /true/ sink by /s1/.-followedBy :: forall m x b1 b2. (ParallelizableMonad m, Typeable x, Typeable b1, Typeable b2)- => Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)-followedBy s1 s2 = liftSplitter "followedBy" (maxUsableThreads s1 + maxUsableThreads s2) $- \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2- in (configuration, followedBy' parallel s1' s2')- where followedBy' parallel s1 s2 source true false edge- = liftM (\(x, y)-> y ++ x) $- (if parallel then pipeP else pipe)- (transduce (splitterToMarker s1) source)- (\source-> let get0 q = case Seq.viewl q- of Seq.EmptyL -> get source >>= maybe (return []) get1- (Left (x, False)) :< rest -> put false x- >>= cond- (get0 rest)- (return- $ concatMap (either ((:[]) . fst) (const []))- $ Foldable.toList $ Seq.viewl q)- (Left (x, True)) :< rest -> get2 Nothing Seq.empty q- (Right b) :< rest -> get2 (Just b) Seq.empty rest- get1 (Left (x, False)) = put false x- >>= cond (get source >>= maybe (return []) get1)- (return [x])- get1 p@(Left (x, True)) = get2 Nothing Seq.empty (Seq.singleton p)- get1 (Right b) = get2 (Just b) Seq.empty Seq.empty- get2 mb q q' = case Seq.viewl q'- of Seq.EmptyL -> get source- >>= maybe (testEnd mb q) (get2 mb q . Seq.singleton)- (Left (x, True)) :< rest -> get2 mb (q |> x) rest- (Left (x, False)) :< rest -> get3 mb q q'- Right{} :< rest -> get3 mb q q'- get3 mb q q' = do ((q1, q2), n) <- pipe (get7 Seq.empty q') (test mb q)- case n of Nothing -> putQueue q false- >>= whenNull (get0 (q1 >< q2))- Just 0 -> get0 (q1 >< q2)- Just n -> get8 (Just mb) n (q1 >< q2)- get7 q1 q2 sink = canPut sink- >>= cond (case Seq.viewl q2- of Seq.EmptyL -> get source- >>= maybe (return (q1, q2))- (\p-> either- (put sink . fst)- (const $ return True)- p- >> get7 (q1 |> p) q2 sink)- p :< rest -> either (put sink . fst) (const $ return True) p- >> get7 (q1 |> p) rest sink)- (return (q1, q2))- testEnd mb q = do ((), n) <- pipeD "testEnd" (const $ return ()) (test mb q)- case n of Nothing -> putQueue q false- _ -> return []- test mb q source = liftM snd $- pipeD "follower"- (transduce (splitterToMarker s2) source)- (\source-> let get4 (Left (_, False)) = return Nothing- get4 p@(Left (_, True)) = putQueue q true- >> get5 0 p- get4 p@(Right b) = maybe- (return True) (\b1-> put edge (b1, b)) mb- >> putQueue q true- >> get6 0- get5 n (Left (x, True)) = put true x >> get6 (succ n)- get5 n _ = return (Just n)- get6 n = get source- >>= maybe- (return $ Just n)- (get5 n)- in get source >>= maybe (return Nothing) get4)- get8 Nothing 0 q = get0 q- get8 (Just mb) 0 q = get2 mb Seq.empty q- get8 mmb n q = case Seq.viewl q of Left (x, False) :< rest -> get8 Nothing (pred n) rest- Left (x, True) :< rest- -> get8 (maybe (Just Nothing) Just mmb) (pred n) rest- Right b :< rest -> get8 (Just (Just b)) n rest- in get0 Seq.empty)---- | Combinator '...' tracks the running balance of difference between the number of preceding starts of sections--- considered /true/ according to its first argument and the ones according to its second argument. The combinator--- passes to /true/ all input values for which the difference balance is positive. This combinator is typically used--- with 'startOf' and 'endOf' in order to count entire input sections and ignore their lengths.-(...) :: forall m x b1 b2. (ParallelizableMonad m, Typeable x, Typeable b1, Typeable b2)- => Splitter m x b1 -> Splitter m x b2 -> Splitter m x b1-s1 ... s2 = liftSplitter "..." (maxUsableThreads s1 + maxUsableThreads s2) $- \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2- s source true false edge- = liftM (\(x, y)-> y ++ x) $- (if parallel then pipeP else pipe)- (transduce (splittersToPairMarker s1' s2') source)- (\source-> let next n = get source >>= maybe (return []) (state n)- pass n x = (if n > 0 then put true x else put false x)- >>= cond (next n) (return [x])- pass' n x = (if n >= 0 then put true x else put false x)- >>= cond (next n) (return [x])- state n (Left (x, True, False)) = pass (succ n) x- state n (Left (x, False, True)) = pass' (pred n) x- state n (Left (x, True, True)) = pass' n x- state n (Left (x, False, False)) = pass n x- state 0 (Right (Left b)) = put edge b >> next 1- state n (Right (Left _)) = next (succ n)- state n (Right (Right _)) = next (pred n)- in next 0)- in (configuration, s)---- Helper functions---- | Converts a 'Control.Concurrent.SCC.ComponentTypes.Splitter' into a--- 'Control.Concurrent.SCC.ComponentTypes.Transducer'. Every input value @x@ that the argument splitter sends to its--- /true/ sink is converted to @Left (x, True)@, every @y@ sent to the splitter's /false/ sink becomes @Left (y,--- False)@, and any value @e@ the splitter puts in its /edge/ sink becomes @Right e@.-splitterToMarker :: forall m x b. (ParallelizableMonad m, Typeable x, Typeable b)- => Splitter m x b -> Transducer m x (Either (x, Bool) b)-splitterToMarker s = liftTransducer "splitterToMarker" (maxUsableThreads s) $- \threads-> let s' = usingThreads threads s- t source sink = liftM (\(x, y, z, _)-> z ++ y ++ x) $- splitToConsumers s' source- (mark (\x-> Left (x, True)))- (mark (\x-> Left (x, False)))- (mark Right)- where mark f source = canPut sink- >>= cond- (get source- >>= maybe (return [])- (\x-> put sink (f x)- >>= cond (mark f source) (return [x])))- (return [])- in (ComponentConfiguration [AnyComponent s'] threads (cost s' + 1), t)---splittersToPairMarker :: forall m x b1 b2. (ParallelizableMonad m, Typeable x, Typeable b1, Typeable b2)- => Splitter m x b1 -> Splitter m x b2- -> Transducer m x (Either (x, Bool, Bool) (Either b1 b2))-splittersToPairMarker s1 s2- = liftTransducer "splittersToPairMarker" (maxUsableThreads s1 + maxUsableThreads s2) $- \threads-> let (configuration, s1', s2', parallelize) = optimalTwoParallelConfigurations threads s1 s2- t source sink = liftM (\(((_, _), (x, _, _, _)), _)-> x) $- pipeD "splittersToPairMarker synchronize"- (\sync-> (if parallelize then pipeP else pipe)- (\sink1-> pipe- (tee source sink1)- (\source2-> splitToConsumers s2' source2- (flip (pourMap (\x-> Left ((x, True), False))) sync)- (flip (pourMap (\x-> Left ((x, False), False))) sync)- (flip (pourMap (Right . Right)) sync)))- (\source1-> splitToConsumers s1' source1- (flip (pourMap (\x-> Left ((x, True), True))) sync)- (flip (pourMap (\x-> Left ((x, False), True))) sync)- (flip (pourMap (Right. Left)) sync)))- (synchronizeMarks Nothing sink)- synchronizeMarks :: Maybe (Seq (Either (x, Bool) (Either b1 b2)), Bool)- -> Sink c (Either (x, Bool, Bool) (Either b1 b2))- -> Source c (Either ((x, Bool), Bool) (Either b1 b2))- -> Pipe c m [x]- synchronizeMarks state sink source = get source- >>= maybe- (assert (isNothing state) (return []))- (handleMark state sink source)- handleMark :: Maybe (Seq (Either (x, Bool) (Either b1 b2)), Bool)- -> Sink c (Either (x, Bool, Bool) (Either b1 b2))- -> Source c (Either ((x, Bool), Bool) (Either b1 b2))- -> Either ((x, Bool), Bool) (Either b1 b2) -> Pipe c m [x]- handleMark Nothing sink source (Right b) = put sink (Right b)- >> synchronizeMarks Nothing sink source- handleMark Nothing sink source (Left (p, first))- = synchronizeMarks (Just (Seq.singleton (Left p), first)) sink source- handleMark state@(Just (q, first)) sink source (Left (p, first')) | first == first'- = synchronizeMarks (Just (q |> Left p, first)) sink source- handleMark state@(Just (q, True)) sink source (Right b@Left{})- = synchronizeMarks (Just (q |> Right b, True)) sink source- handleMark state@(Just (q, False)) sink source (Right b@Right{})- = synchronizeMarks (Just (q |> Right b, False)) sink source- handleMark state sink source (Right b) = put sink (Right b) >> synchronizeMarks state sink source- handleMark state@(Just (q, pos')) sink source mark@(Left ((x, t), pos))- = case Seq.viewl q- of Seq.EmptyL -> synchronizeMarks (Just (Seq.singleton (Left (x, t)), pos)) sink source- Right b :< rest -> put sink (Right b)- >>= cond- (handleMark- (if Seq.null rest then Nothing else Just (rest, pos'))- sink- source- mark)- (returnQueuedList q)- Left (y, t') :< rest -> put sink (Left $ if pos then (y, t, t') else (y, t', t))- >>= cond- (synchronizeMarks- (if Seq.null rest then Nothing else Just (rest, pos'))- sink- source)- (returnQueuedList q)- returnQueuedList q = return $ concatMap (either ((:[]) . fst) (const [])) $ Foldable.toList $ Seq.viewl q- in (configuration, t)--zipSplittersWith :: (ParallelizableMonad m, Typeable x, Typeable b1, Typeable b2, Typeable b)- => (Bool -> Bool -> Bool)- -> (forall c. Source c (Either b1 b2) -> Sink c b -> Pipe c m ())- -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x b-zipSplittersWith f boundaries s1 s2- = liftSplitter "zip" (maxUsableThreads s1 + maxUsableThreads s2) $- \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2- s source true false edge = liftM (\((x, y), _)-> y ++ x) $- pipe- (\edge'->- (if parallel then pipeP else pipe)- (transduce (splittersToPairMarker s1' s2') source)- (\source-> let split = get source- >>= maybe- (return [])- (either- test- (\b-> put edge' b >> split))- test (x, t1, t2) = put (if f t1 t2 then true else false) x- >>= cond split (return [x])- in split))- (flip boundaries edge)- in (configuration, s)--- | Runs the second argument on every contiguous region of input source (typically produced by 'splitterToMarker')--- whose all values either match @Left (_, True)@ or @Left (_, False)@.-groupMarks :: forall c m x b r. (ParallelizableMonad m, Typeable x, Typeable b)- => Source c (Either (x, Bool) b) -> (Maybe (Maybe b) -> Source c x -> Pipe c m r) -> Pipe c m ()-groupMarks source getConsumer = start- where start = getSuccess source (either startContent startRegion)- startContent (x, False) = pipe (\sink-> pass False sink x) (getConsumer Nothing)- >>= maybe (return ()) (either startContent startRegion) . fst- startContent (x, True) = pipe (\sink-> pass True sink x) (getConsumer $ Just Nothing)- >>= maybe (return ()) (either startContent startRegion) . fst- startRegion b = pipe (next True) (getConsumer (Just $ Just b))- >>= maybe (return ()) (either startContent startRegion) . fst- pass t sink x = put sink x >> next t sink- next t sink = get source >>= maybe (return Nothing) (continue t sink)- continue t sink (Left (x, t')) | t == t' = pass t sink x- continue t sink p = return (Just p)+{-# 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+
− Control/Concurrent/SCC/ComponentTypes.hs
@@ -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- <http://www.gnu.org/licenses/>.--}--{-# 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
Control/Concurrent/SCC/Components.hs view
@@ -14,383 +14,474 @@ <http://www.gnu.org/licenses/>. -} --- | 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
− Control/Concurrent/SCC/Foundation.hs
@@ -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- <http://www.gnu.org/licenses/>.--}---- | 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
+ Control/Concurrent/SCC/Primitives.hs view
@@ -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+ <http://www.gnu.org/licenses/>.+-}++-- | 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
+ Control/Concurrent/SCC/Streams.hs view
@@ -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+ <http://www.gnu.org/licenses/>.+-}++-- | 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
+ Control/Concurrent/SCC/Types.hs view
@@ -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+ <http://www.gnu.org/licenses/>.+-}++-- | 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
+ Control/Concurrent/SCC/XML.hs view
@@ -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+ <http://www.gnu.org/licenses/>.+-}++-- | 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 "<?" true+ >>= whenNull (put edge (Start ProcessingInstructionText)+ >> processingInstruction)+ tag '!' = dispatchOnString source+ (\other-> put edge (Point (ErrorToken ("Expecting <![CDATA[ or <!--, received "+ ++ show ("<![" ++ other))))+ >> return ("<!" ++ other))+ [("--",+ \match-> put edge (Start Comment)+ >> putList match true+ >>= whenNull (put edge (Start CommentText)+ >> comment)),+ ("[CDATA[",+ \match-> put edge (Start StartMarkedSectionCDATA)+ >> putList match true+ >>= whenNull (put edge (End StartMarkedSectionCDATA)+ >> markedSection))]+ tag '/' = {-# SCC "EndTag" #-}+ do put edge (Start EndTag)+ put true '<'+ put true '/'+ x <- next (name ElementName)+ put true x+ when (x /= '>')+ (put edge (Point (ErrorToken ("Invalid character " ++ show x ++ " in end tag")))+ >> return ())+ put edge (End EndTag)+ return []+ tag x | isNameStart x+ = {-# SCC "StartTag" #-}+ do put edge (Start StartTag)+ put true '<'+ y <- name ElementName x+ z <- attributes y+ w <- if z == '/'+ then put true z >> put edge (Point EmptyTag)+ >> get source+ >>= 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 "<![CDATA[" #-}+ dispatchOnString source+ (\other-> if null other+ then (put edge (Point (ErrorToken "Unterminated marked section"))+ >> return [])+ else putList other true >>= whenNull markedSection)+ [("]]>",+ \match-> put edge (Start EndMarkedSection)+ >> putList match true+ >>= whenNull (put edge (End EndMarkedSection)+ >> getContent))]+ entity = do put edge (Start EntityReferenceToken)+ put true '&'+ x <- next (name EntityName)+ when (x /= ';') (put edge (Point (ErrorToken ("Invalid character " ++ show x+ ++ " ends entity name.")))+ >> return ())+ put true x+ put edge (End EntityReferenceToken)+ name token x | isNameStart x = {-# SCC "name" #-} + do put edge (Start token)+ put true x+ next (nameTail token)+ name _ x = do put edge (Point (ErrorToken ("Invalid character " ++ show x ++ " in attribute value.")))+ return x+ nameTail token x = if isNameChar x || x == ':'+ then put true x >> next (nameTail token)+ else put edge (End token) >> return x+ next f = {-# SCC "next" #-} get' source >>= f+ in getContent++-- | The XML token parser. This parser converts plain text to parsed text, which is a precondition for using the+-- remaining XML components.+parseTokens :: 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)
− Control/Concurrent/SCC/XMLComponents.hs
@@ -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- <http://www.gnu.org/licenses/>.--}---- | Module "XMLComponents" defines primitive components for parsing and manipulating XML.--{-# LANGUAGE DeriveDataTypeable, PatternGuards #-}--module Control.Concurrent.SCC.XMLComponents (--- * Types-Token (..),--- * Parsing XML-tokens, parseTokens, expandEntity,--- * Showing XML-escapeAttributeCharacter, escapeContentCharacter,--- * Splitters-element, elementContent, elementName, attribute, attributeName, attributeValue,--- * Splitter combinators-elementHavingTag, havingText, havingOnlyText-)-where--import Control.Exception (assert)-import Control.Monad (liftM, when)-import Data.Char-import Data.Dynamic (Typeable)-import qualified Data.Map as Map-import Data.Maybe (fromJust, isJust, mapMaybe)-import Data.List (find, stripPrefix)-import qualified Data.Sequence as Seq-import Data.Sequence ((|>))-import Numeric (readDec, readHex)-import Debug.Trace (trace)--import Control.Concurrent.SCC.Foundation-import Control.Concurrent.SCC.ComponentTypes-import Control.Concurrent.SCC.Components (unparse)-import Control.Concurrent.SCC.Combinators ((>->), groupMarks, having, havingOnly, parseNestedRegions, splitterToMarker)---data Token = StartTag | EndTag | EmptyTag- | ElementName | AttributeName | AttributeValue- | EntityReferenceToken | EntityName- | ProcessingInstruction | ProcessingInstructionText- | Comment | CommentText- | StartMarkedSectionCDATA | EndMarkedSection- | ErrorToken String- deriving (Eq, Show, Typeable)---- | Escapes a character for inclusion into an XML attribute value.-escapeAttributeCharacter :: Char -> String-escapeAttributeCharacter '"' = """-escapeAttributeCharacter '\t' = "	"-escapeAttributeCharacter '\n' = " "-escapeAttributeCharacter '\r' = " "-escapeAttributeCharacter x = escapeContentCharacter x---- | Escapes a character for inclusion into the XML data content.-escapeContentCharacter :: Char -> String-escapeContentCharacter '<' = "<"-escapeContentCharacter '&' = "&"-escapeContentCharacter x = [x]---- | Converts an XML entity name into the text value it represents: @expandEntity \"lt\" = \"<\"@.-expandEntity :: String -> String-expandEntity "lt" = "<"-expandEntity "gt" = ">"-expandEntity "quot" = "\""-expandEntity "apos" = "'"-expandEntity "amp" = "&"-expandEntity ('#' : 'x' : codePoint) = [chr (fst $ head $ readHex codePoint)]-expandEntity ('#' : codePoint) = [chr (fst $ head $ readDec codePoint)]--isNameStart x = isLetter x || x == '_'-isNameChar x = isAlphaNum x || x == '_' || x == '-'---- | The 'tokens' splitter distinguishes XML markup from data content. It is used by 'parseTokens'.-tokens :: (ParallelizableMonad m) => Splitter m Char (Boundary Token)-tokens = liftAtomicSplitter "XML.tokens" 1 $- \source true false edge->- let getContent = get source- >>= maybe (return []) content- content '<' = get source- >>= maybe (return "<") (\x-> tag x >> get source >>= maybe (return []) content)- content '&' = entity >> next content- content x = put false x- >>= cond getContent (return [x])- tag '?' = put edge (Start ProcessingInstruction)- >> putList "<?" true- >>= whenNull (put edge (Start ProcessingInstructionText)- >> processingInstruction)- tag '!' = dispatchOnString source- (\other-> put edge (Point (ErrorToken ("Expecting <![CDATA[ or <!--, received "- ++ show ("<![" ++ other))))- >> return ("<!" ++ other))- [("--",- \match-> put edge (Start Comment)- >> putList match true- >>= whenNull (put edge (Start CommentText)- >> comment)),- ("[CDATA[",- \match-> put edge (Start StartMarkedSectionCDATA)- >> putList match true- >>= whenNull (put edge (End StartMarkedSectionCDATA)- >> markedSection))]- tag '/' = {-# SCC "EndTag" #-}- do put edge (Start EndTag)- put true '<'- put true '/'- x <- next (name ElementName)- put true x- when (x /= '>') (put edge (Point (ErrorToken ("Invalid character " ++ show x ++ " in end tag")))- >> return ())- put edge (End EndTag)- return []- tag x | isNameStart x- = {-# SCC "StartTag" #-}- do put edge (Start StartTag)- put true '<'- y <- name ElementName x- z <- attributes y- w <- if z == '/'- then put true z >> put edge (Point EmptyTag) >> get' source- else return z- put true w- when (w /= '>') (put edge (Point (ErrorToken ("Invalid character " ++ show w- ++ " in start tag")))- >> return ())- put edge (End StartTag)- return []- attributes x | isSpace x = put true x >> next attributes- attributes x | isNameStart x = do y <- name AttributeName x- when (y /= '=') (put edge (Point (ErrorToken ("Invalid character " ++ show y- ++ " following attribute name")))- >> return ())- q <- if y == '"' || y == '\'' then return y else put true y >> get' source- when- (q /= '"' && q /= '\'')- (put edge (Point (ErrorToken ("Invalid quote character " ++ show q)))- >> return ())- put true q- put edge (Start AttributeValue)- next (attributeValue q)- next attributes- attributes x = return x- attributeValue q x | q == x = do put edge (End AttributeValue)- put true x- attributeValue q '<' = do put edge (Start (ErrorToken "Invalid character '<' in attribute value."))- put true '<'- put edge (End (ErrorToken "Invalid character '<' in attribute value."))- next (attributeValue q)- attributeValue q '&' = entity >> next (attributeValue q)- attributeValue q x = put true x >> next (attributeValue q)- processingInstruction = {-# SCC "PI" #-}- dispatchOnString source- (\other-> if null other- then (put edge (Point (ErrorToken "Unterminated processing instruction"))- >> return [])- else putList other true >>= whenNull processingInstruction)- [("?>",- \match-> put edge (End ProcessingInstructionText)- >> putList match true- >>= whenNull (put edge (End ProcessingInstruction)- >> getContent))]- comment = {-# SCC "comment" #-}- dispatchOnString source- (\other-> if null other- then (put edge (Point (ErrorToken "Unterminated comment"))- >> return [])- else putList other true >>= whenNull comment)- [("-->",- \match-> put edge (End CommentText)- >> putList match true- >>= whenNull (put edge (End Comment)- >> getContent))]- markedSection = {-# SCC "<![CDATA[" #-}- dispatchOnString source- (\other-> if null other- then (put edge (Point (ErrorToken "Unterminated marked section"))- >> return [])- else putList other true >>= whenNull markedSection)- [("]]>",- \match-> put edge (Start EndMarkedSection)- >> putList match true- >>= whenNull (put edge (End EndMarkedSection)- >> getContent))]- entity = do put edge (Start EntityReferenceToken)- put true '&'- x <- next (name EntityName)- when (x /= ';') (put edge (Point (ErrorToken ("Invalid character " ++ show x- ++ " ends entity name.")))- >> return ())- put true x- put edge (End EntityReferenceToken)- name token x | isNameStart x = {-# SCC "name" #-} - do put edge (Start token)- put true x- next (nameTail token)- name _ x = do put edge (Point (ErrorToken ("Invalid character " ++ show x ++ " in attribute value.")))- return x- nameTail token x = if isNameChar x || x == ':'- then put true x >> next (nameTail token)- else put edge (End token) >> return x- next f = {-# SCC "next" #-} get' source >>= f- in getContent---- | The XML token parser. This parser converts plain text to parsed text, which is a precondition for using the--- remaining XML components.-parseTokens :: (ParallelizableMonad m) => Parser m Char Token-parseTokens = parseNestedRegions tokens--dispatchOnString :: Monad m => Source c Char -> (String -> Pipe c m r) -> [(String, String -> Pipe c m r)] -> Pipe c m r-dispatchOnString source failure fullCases = dispatch fullCases id- where dispatch cases consumed- = case find (null . fst) cases- of Just ("", rhs) -> rhs (consumed "")- Nothing -> get source- >>= maybe- (failure (consumed ""))- (\x-> case mapMaybe (startingWith x) cases- of [] -> failure (consumed [x])- subcases -> dispatch (subcases ++ fullCases) (consumed . (x :)))- startingWith x (y:rest, rhs) | x == y = Just (rest, rhs)- | otherwise = Nothing--getElementName :: Monad m => Source c (Markup Char Token) -> ([Markup Char Token] -> [Markup Char Token])- -> Pipe c m ([Markup Char Token], Maybe String)-getElementName source f = get source- >>= maybe- (return (f [], Nothing))- (\x-> case x of Markup (Start ElementName) -> getRestOfRegion ElementName source (f . (x:)) id- Markup (Point ErrorToken{}) -> getElementName source (f . (x:))- Content{} -> getElementName source (f . (x:))- _ -> error ("Expected an ElementName, received " ++ show x))--getRestOfRegion :: Monad m => Token -> Source c (Markup Char Token)- -> ([Markup Char Token] -> [Markup Char Token]) -> (String -> String)- -> Pipe c m ([Markup Char Token], Maybe String)-getRestOfRegion token source f g = get source- >>= maybe- (return (f [], Nothing))- (\x-> case x of Markup (End token) -> return (f [x], Just (g ""))- Content y -> getRestOfRegion token source (f . (x:)) (g . (y:))- _ -> error ("Expected rest of " ++ show token ++ ", received " ++ show x))--pourRestOfRegion :: Monad m- => Token -> Source c (Markup Char Token) -> Sink c (Markup Char Token) -> Sink c (Markup Char Token)- -> Pipe c m (Maybe [Markup Char Token])-pourRestOfRegion token source sink endSink- = get source- >>= maybe- (return $ Just [])- (\x-> case x- of Markup (End token') | token == token' -> put endSink x- >>= cond (return Nothing) (return $ Just [x])- Content y -> put sink x- >>= cond (pourRestOfRegion token source sink endSink) (return $ Just [x])- _ -> error ("Expected rest of " ++ show token ++ ", received " ++ show x))--pourRestOfTag :: Monad m => Source c (Markup Char Token) -> Sink c (Markup Char Token) -> Pipe c m Bool-pourRestOfTag source sink = get source- >>= maybe- (return True)- (\x-> put sink x- >> case x of Markup (End StartTag) -> return True- Markup (End EndTag) -> return True- Markup (Point EmptyTag) -> pourRestOfTag source sink >> return False- _ -> pourRestOfTag source sink)--findEndTag :: Monad m => Source c (Markup Char Token) -> Sink c (Markup Char Token) -> Sink c (Markup Char Token) -> String- -> Pipe c m [Markup Char Token]-findEndTag source sink endSink name = find where- find = get source- >>= maybe- (return [])- (\x-> case x- of Markup (Start EndTag) -> do (tokens, mn) <- getElementName source (x :)- maybe- (return tokens)- (\name'-> if name == name'- then putList tokens endSink- >>= whenNull- (pourRestOfTag source endSink- >> return [])- else putList tokens sink- >>= whenNull- (pourRestOfTag source sink- >> find))- mn- Markup (Start StartTag) -> do (tokens, mn) <- getElementName source (x :)- maybe- (return tokens)- (\name'-> putList tokens sink- >>= whenNull- (if name == name'- then pourRestOfTag source sink- >>= cond- (findEndTag source sink sink name)- (return [])- >>= whenNull find- else pourRestOfTag source sink- >> find))- mn- _ -> put sink x- >>= cond find (return [x]))--findStartTag :: Monad m => Source c (Markup Char Token) -> Sink c (Markup Char Token)- -> Pipe c m (Either [Markup Char Token] (Markup Char Token))-findStartTag source sink = get source- >>= maybe- (return $ Left [])- (\x-> case x of Markup (Start StartTag) -> return $ Right x- _ -> put sink x- >>= cond (findStartTag source sink) (return $ Left [x]))---- | Splits all top-level elements with all their content to /true/, all other input to /false/.-element :: (Monad m) => Splitter m (Markup Char Token) ()-element = liftAtomicSplitter "element" 1 $- \source true false edge->- let split0 = findStartTag source false- >>= either return- (\x-> put edge ()- >> put true x- >>= cond- (do (tokens, mn) <- getElementName source id- maybe- (putList tokens true)- (\name-> putList tokens true- >>= whenNull- (pourRestOfTag source true- >>= cond- (split1 name)- split0))- mn)- (return [x]))- split1 name = findEndTag source true true name- >>= whenNull split0- in split0---- | Splits the content of all top-level elements to /true/, their tags and intervening input to /false/.-elementContent :: (Monad m) => Splitter m (Markup Char Token) ()-elementContent = liftAtomicSplitter "elementContent" 1 $- \source true false edge->- let split0 = findStartTag source false- >>= either return- (\x-> put false x- >>= cond- (do (tokens, mn) <- getElementName source id- maybe- (putList tokens false)- (\name-> putList tokens false- >>= whenNull (pourRestOfTag source false- >>= cond- (put edge ()- >> split1 name)- split0))- mn)- (return [x]))- split1 name = findEndTag source true false name- >>= whenNull split0- in split0---- | Similiar to @('Control.Concurrent.SCC.Combinators.having' 'element')@, except it runs the argument splitter--- only on each element's start tag, not on the entire element with its content.-elementHavingTag :: (ParallelizableMonad m, Typeable b)- => Splitter m (Markup Char Token) b -> Splitter m (Markup Char Token) b-elementHavingTag test- = liftSplitter "elementHavingTag" (maxUsableThreads test) $- \threads-> let test' = usingThreads threads test- configuration = ComponentConfiguration [AnyComponent test'] threads (cost test' + 2)- split source true false edge = split0 where- split0 = findStartTag source false- >>= either return- (\x-> do (tokens, mn) <- getElementName source (x :)- maybe- (return tokens)- (\name-> do (hasContent, rest) <- pipe (pourRestOfTag source) getList- let tag = tokens ++ rest- (_, (unconsumed, maybeTrue, (), maybeEdge))- <- pipe- (putList tag)- (\tag-> splitToConsumers- test'- tag- get- consumeAndSuppress- get)- if isJust maybeTrue || isJust maybeEdge- then maybe (return True) (put edge) maybeEdge- >> putList tag true- >>= whenNull (split1 hasContent true name)- else putList tag false- >>= whenNull (split1 hasContent false name))- mn)- split1 hasContent sink name = if hasContent- then findEndTag source sink sink name >>= whenNull split0- else split0- in (configuration, split)---- | Splits every attribute specification to /true/, everything else to /false/.-attribute :: (ParallelizableMonad m) => Splitter m (Markup Char Token) ()-attribute = liftAtomicSplitter "attribute" 1 $- \source true false edge->- let split0 = get source- >>= maybe- (return [])- (\x-> case x of Markup (Start AttributeName)- -> put edge ()- >> put true x- >>= cond- (pourRestOfRegion AttributeName source true true- >>= maybe split1 return)- (return [x])- _ -> put false x- >>= cond split0 (return [x]))- split1 = get source- >>= maybe- (return [])- (\x-> case x of Markup (Start AttributeValue)- -> put true x- >>= cond- (pourRestOfRegion AttributeValue source true true- >>= maybe split0 return)- (return [x])- _ -> put true x- >>= cond split1 (return [x]))- in split0---- | Splits every element name, including the names of nested elements and names in end tags, to /true/, all the rest of--- input to /false/.-elementName :: (ParallelizableMonad m) => Splitter m (Markup Char Token) ()-elementName = liftAtomicSplitter "elementName" 1 (splitSimpleRegions ElementName)---- | Splits every attribute name to /true/, all the rest of input to /false/.-attributeName :: (ParallelizableMonad m) => Splitter m (Markup Char Token) ()-attributeName = liftAtomicSplitter "attributeName" 1 (splitSimpleRegions AttributeName)---- | Splits every attribute value, excluding the quote delimiters, to /true/, all the rest of input to /false/.-attributeValue :: (ParallelizableMonad m) => Splitter m (Markup Char Token) ()-attributeValue = liftAtomicSplitter "attributeValue" 1 (splitSimpleRegions AttributeValue)--splitSimpleRegions token source true false edge = split- where split = get source- >>= maybe- (return [])- (\x-> case x of Markup (Start token') | token == token'- -> put false x- >>= cond- (put edge ()- >> pourRestOfRegion token source true false- >>= maybe split return)- (return [x])- _ -> put false x- >>= cond split (return [x]))---- | Behaves like 'Control.Concurrent.SCC.Combinators.having', but the right-hand splitter works on plain instead of--- marked-up text. This allows regular 'Char' splitters to be applied to parsed XML.-havingText :: (ParallelizableMonad m, Typeable b1, Typeable b2)- => Splitter m (Markup Char Token) b1 -> Splitter m Char b2 -> Splitter m (Markup Char Token) b1-havingText chunker tester- = liftSplitter "havingText" (maxUsableThreads chunker + maxUsableThreads tester) $- \threads-> let (configuration, chunker', tester', parallel) = optimalTwoParallelConfigurations threads chunker tester- split source true false edge- = liftM fst $- (if parallel then pipeP else pipe)- (transduce (splitterToMarker chunker') source)- (flip groupMarks test)- where test Nothing chunk = pour chunk false >> return []- test (Just mb) chunk = pipe- (\sink1-> pipe (tee chunk sink1) getList)- (\chunk-> liftM snd $- pipe- (transduce unparse chunk)- (\chunk-> splitToConsumers tester' chunk- (liftM isJust . get)- consumeAndSuppress- (liftM isJust . get)))- >>= \(((), prefix), (_, anyTrue, (), anyEdge))->- if anyTrue || anyEdge- then maybe (return True) (put edge) mb- >> putList prefix true- >>= whenNull (pour chunk true >> return [])- else putList prefix false- >>= whenNull (pour chunk false >> return [])- in (configuration, split)---- | Behaves like 'Control.Concurrent.SCC.Combinators.havingOnly', but the right-hand splitter works on plain instead of--- marked-up text. This allows regular 'Char' splitters to be applied to parsed XML.-havingOnlyText :: (ParallelizableMonad m, Typeable b1, Typeable b2)- => Splitter m (Markup Char Token) b1 -> Splitter m Char b2 -> Splitter m (Markup Char Token) b1-havingOnlyText chunker tester- = liftSplitter "havingOnlyText" (maxUsableThreads chunker + maxUsableThreads tester) $- \threads-> let (configuration, chunker', tester', parallel) = optimalTwoParallelConfigurations threads chunker tester- split source true false edge- = liftM fst $- (if parallel then pipeP else pipe)- (transduce (splitterToMarker chunker') source)- (flip groupMarks test)- where test Nothing chunk = pour chunk false >> return []- test (Just mb) chunk = pipe- (\sink1-> pipe (tee chunk sink1) getList)- (\chunk-> liftM snd $- pipe- (transduce unparse chunk)- (\chunk-> splitToConsumers tester' chunk- consumeAndSuppress- (liftM isJust . get)- consumeAndSuppress))- >>= \(((), prefix), (_, (), anyFalse, ()))->- if anyFalse- then putList prefix false- >>= whenNull (pour chunk false >> return [])- else maybe (return True) (put edge) mb- >> putList prefix true- >>= whenNull (pour chunk true >> return [])- in (configuration, split)
Makefile view
@@ -1,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
Shell.hs view
@@ -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
Test.hs view
@@ -1,5 +1,5 @@ {- - Copyright 2008 Mario Blazevic+ Copyright 2008-2009 Mario Blazevic This file is part of the Streaming Component Combinators (SCC) project. @@ -14,21 +14,23 @@ <http://www.gnu.org/licenses/>. -} -{-# 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 = "</" ++ name' ++ ">" prop_XMLtokens2 :: [LowercaseLetter] -> [([LowercaseLetter], String)] -> String -> Property prop_XMLtokens2 name attrs content = name /= [] && all validAttribute attrs && intersect content "<&" == []- ==> splitterOutputs XML.tokens (start ++ content ++ end)+ ==> 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 = "</" ++ name' ++ ">" 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 ++ "</" ++ name' ++ ">"+ 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)
scc.cabal view
@@ -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 <http://conferences.idealliance.org/extreme/html/2006/Blazevic01/EML2006Blazevic01.html> .@@ -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