scc 0.6 → 0.6.1
raw patch · 11 files changed
+676/−680 lines, 11 files
Files
- Control/Concurrent/Configuration.hs +24/−23
- Control/Concurrent/SCC/Coercions.hs +0/−3
- Control/Concurrent/SCC/Combinators.hs +208/−210
- Control/Concurrent/SCC/Configurable.hs +5/−6
- Control/Concurrent/SCC/Primitives.hs +61/−66
- Control/Concurrent/SCC/Streams.hs +36/−38
- Control/Concurrent/SCC/Types.hs +18/−19
- Control/Concurrent/SCC/XML.hs +152/−163
- Makefile +10/−6
- Shell.hs +155/−139
- scc.cabal +7/−7
Control/Concurrent/Configuration.hs view
@@ -36,7 +36,7 @@ import GHC.Conc (numCapabilities) -- | 'AnyComponent' is an existential type wrapper around a 'Component'.-data AnyComponent = forall a. AnyComponent {component :: Component a}+data AnyComponent = forall a. AnyComponent (Component a) -- | A 'Component' carries a value and metadata about the value. It can be configured to use a specific number of -- threads.@@ -85,14 +85,14 @@ -- | 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'+toComponent nm maxThreads using = usingThreads' 1+ where usingThreads' n = let (configuration, c') = using n+ in Component nm (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))+atomic nm cost1 x = toComponent nm 1 (\_threads-> (ComponentConfiguration [] 1 cost1, x)) -- | Function 'optimalTwoAlternatingConfigurations' configures two components that are meant to alternate in processing -- of the data stream.@@ -140,9 +140,10 @@ -- | 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) $+lift :: Int {- ^ combinator cost -} -> String {- ^ name -} -> (c1 -> c2) {- ^ combinator -} -> Component c1 + -> Component c2+lift wrapperCost combinatorName combinator c =+ toComponent combinatorName (maxUsableThreads c) $ \threads-> let c' = usingThreads c threads in (ComponentConfiguration [AnyComponent c'] (usedThreads c') (cost c' + wrapperCost), combinator (with c'))@@ -150,8 +151,8 @@ -- | 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) $+liftSequentialPair combinatorName combinator c1 c2 =+ toComponent combinatorName (maxUsableThreads c1 `max` maxUsableThreads c2) $ \threads-> let (configuration, c1', c2') = optimalTwoSequentialConfigurations threads c1 c2 in (configuration, combinator (with c1') (with c2')) @@ -159,8 +160,8 @@ -- 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) $+liftParallelPair combinatorName combinator c1 c2 =+ toComponent combinatorName (maxUsableThreads c1 + maxUsableThreads c2) $ \threads-> let (configuration, c1', c2', parallel) = optimalTwoParallelConfigurations threads c1 c2 in (configuration, combinator parallel (with c1') (with c2')) @@ -168,26 +169,26 @@ -- 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) $+parallelRouterAndBranches combinatorName combinator router c1 c2 =+ toComponent combinatorName (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'))+ \newThreads-> let (cfg', c1', c2') = optimalTwoAlternatingConfigurations newThreads 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 -> c2) -> Component c1 -> Component c2-recursiveComponentTree name combinator c =- toComponent name numCapabilities $+recursiveComponentTree combinatorName combinator c =+ toComponent combinatorName numCapabilities $ \threads-> let optimalRecursion :: Int -> Int -> (ComponentConfiguration, c2)- optimalRecursion oldThreads threads- | oldThreads == threads = let final = combinator False (with $ usingThreads c threads) final- in (ComponentConfiguration [] threads (cost c), final)+ optimalRecursion oldThreads newThreads+ | oldThreads == newThreads = let final = combinator False (with $ usingThreads c newThreads) final+ in (ComponentConfiguration [] newThreads (cost c), final) | otherwise =- let (configuration, c', r', parallel) = optimalTwoParallelConfigurations threads c r- r = toComponent name (threads - 1) (optimalRecursion threads)+ let (configuration, c', r', parallel) = optimalTwoParallelConfigurations newThreads c r+ r = toComponent combinatorName (newThreads - 1) (optimalRecursion newThreads) in (configuration, combinator parallel (with c') (with r')) in optimalRecursion 0 threads
Control/Concurrent/SCC/Coercions.hs view
@@ -34,9 +34,6 @@ import Control.Monad (liftM) import Data.Text (Text, pack, unpack) -import Control.Monad.Coroutine-import Control.Monad.Parallel (MonadParallel(..))- import Control.Concurrent.SCC.Streams import Control.Concurrent.SCC.Types
Control/Concurrent/SCC/Combinators.hs view
@@ -72,19 +72,15 @@ ) where -import Prelude hiding (even, last, sequence)-import Control.Category ((>>>))-import qualified Control.Category as Category+import Prelude hiding (even, last, sequence, head) import Control.Monad (liftM, when)-import qualified Control.Monad as Monad import Control.Monad.Trans.Class (lift)-import Data.Maybe (isJust, isNothing, fromJust, mapMaybe)+import Data.Maybe (isJust, mapMaybe) import qualified Data.Foldable as Foldable import qualified Data.Sequence as Seq import Data.Sequence (Seq, (|>), (><), ViewL (EmptyL, (:<))) import Control.Monad.Coroutine-import Control.Monad.Parallel (MonadParallel(..)) import Control.Concurrent.SCC.Streams import Control.Concurrent.SCC.Types@@ -128,7 +124,7 @@ instance Monad m => PipeableComponentPair m y (Transducer m x y) (Transducer m y z) (Transducer m x z) where compose binder t1 t2 = isolateTransducer $ \source sink-> - pipeG binder (transduce t1 source) (\source-> transduce t2 source sink)+ pipeG binder (transduce t1 source) (\source'-> transduce t2 source' sink) >> return () class CompatibleSignature c cons (m :: * -> *) input output | c -> cons m@@ -186,15 +182,15 @@ where join binder t1 t2 = isolateTransducer $ \source sink-> pipe (\buffer-> teeConsumers binder- (\source-> transduce t1 source sink)- (\source-> transduce t2 source buffer)+ (\source'-> transduce t1 source' sink)+ (\source'-> transduce t2 source' buffer) source) getList >>= \(_, list)-> putList list sink >> return () sequence t1 t2 = isolateTransducer $ \source sink-> teeConsumers sequentialBinder (flip (transduce t1) sink) getList source- >>= \(_, list)-> pipe (putList list) (\source-> transduce t2 source sink)+ >>= \(_, list)-> pipe (putList list) (\source'-> transduce t2 source' sink) >> return () instance forall m r1 r2. Monad m =>@@ -242,7 +238,7 @@ Transducer $ \ source sink -> liftBinder binder (const . return) (transduce t source sink) (lift (perform p)) sequence t p = Transducer $ \ source sink -> do result <- transduce t source sink- lift (perform p)+ _ <- lift (perform p) return result instance forall m x y. Monad m =>@@ -270,11 +266,11 @@ (Consumer m x ()) (Transducer m x y) (Transducer m x y) where join binder c t = isolateTransducer $ \source sink->- teeConsumers binder (consume c) (\source-> transduce t source sink) source+ teeConsumers binder (consume c) (\source'-> transduce t source' sink) source >> return () sequence c t = isolateTransducer $ \source sink-> teeConsumers sequentialBinder (consume c) getList source- >>= \(_, list)-> pipe (putList list) (\source-> transduce t source sink)+ >>= \(_, list)-> pipe (putList list) (\source'-> transduce t source' sink) >> return () instance forall m x y. Monad m =>@@ -282,7 +278,7 @@ (Transducer m x y) (Consumer m x ()) (Transducer m x y) where join binder t c = join binder c t sequence t c = isolateTransducer $ \source sink->- teeConsumers sequentialBinder (\source-> transduce t source sink) getList source+ teeConsumers sequentialBinder (\source'-> transduce t source' sink) getList source >>= \(_, list)-> pipe (putList list) (consume c) >> return () @@ -303,13 +299,13 @@ -- input through unmodified, except for prepending the output of the argument producer to it. The following law holds: @ -- 'prepend' /prefix/ = 'join' ('substitute' /prefix/) 'Control.Category.id' @ prepend :: forall m x r. Monad m => Producer m x r -> Transducer m x x-prepend prefix = Transducer $ \ source sink -> produce prefix sink >> pour source sink+prepend prefixProducer = Transducer $ \ source sink -> produce prefixProducer sink >> pour source sink -- | Combinator 'append' converts the given producer to a 'Control.Concurrent.SCC.Types.Transducer' that passes all its -- input through unmodified, finally appending the output of the argument producer to it. The following law holds: @ -- 'append' /suffix/ = 'join' 'Control.Category.id' ('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 ()+append suffixProducer = Transducer $ \ source sink -> pour source sink >> produce suffixProducer sink >> return () -- | The 'substitute' combinator converts its argument producer to a 'Control.Concurrent.SCC.Types.Transducer' that -- produces the same output, while consuming its entire input and ignoring it.@@ -319,7 +315,9 @@ -- | 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)+sNot splitter = isolateSplitter s+ where s :: forall d. Functor d => Source m d x -> Sink m d x -> Sink m d x -> Sink m d b -> Coroutine d m ()+ s source true false _edge = split splitter source false true (nullSink :: Sink m d b) -- | The 'sAnd' combinator sends the /true/ sink output of its left operand to the input of its right operand for -- further splitting. Both operands' /false/ sinks are connected to the /false/ sink of the combined splitter, but any@@ -330,18 +328,19 @@ liftM (fst . fst) $ pipe (\edges-> pipeG binder- (\true-> split s1 source true false (mapSink Left edges))- (\source-> split s2 source true false (mapSink Right edges)))+ (\true'-> split s1 source true' false (mapSink Left edges))+ (\source'-> split s2 source' true false (mapSink Right edges))) (flip intersectRegions edge) +intersectRegions :: forall m a1 a2 d b1 b2. Monad m => OpenTransducer m a1 a2 d (Either b1 b2) (b1, b2) () intersectRegions source sink = next Nothing Nothing where next lastLeft lastRight = getWith (either (flip pair lastRight . Just) (pair lastLeft . Just)) source- pair l@(Just x) r@(Just y) = put sink (x, y)- >> next Nothing Nothing+ pair (Just x) (Just y) = put sink (x, y)+ >> next Nothing Nothing pair l r = next l r -- | A 'sOr' combinator's input value can reach its /false/ sink only by going through both argument splitters' /false/@@ -351,8 +350,8 @@ isolateSplitter $ \ source true false edge -> liftM fst $ pipeG binder- (\false-> split s1 source true false (mapSink Left edge))- (\source-> split s2 source true false (mapSink Right edge))+ (\false'-> split s1 source true false' (mapSink Left edge))+ (\source'-> split s2 source' true false (mapSink Right edge)) -- | Combinator 'pAnd' is a pairwise logical conjunction of two splitters run in parallel on the same input. pAnd :: forall m x b1 b2. Monad m => PairBinder m -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x (b1, b2)@@ -360,19 +359,19 @@ isolateSplitter $ \ source true false edge -> pipeG binder (transduce (splittersToPairMarker binder s1 s2) source)- (\source-> let split l r = getWith (test l r) source- test l r (Left (x, t1, t2)) = - (if t1 && t2 then put true x else put false x)- >> split (if t1 then l else Nothing) (if t2 then r else Nothing)- test _ Nothing (Right (Left l)) = split (Just l) Nothing- test _ (Just r) (Right (Left l)) = put edge (l, r) >> split (Just l) (Just r)- test Nothing _ (Right (Right r)) = split Nothing (Just r)- test (Just l) _ (Right (Right r)) = put edge (l, r) >> split (Just l) (Just r)- in split Nothing Nothing)+ (\source'-> let next l r = getWith (test l r) source'+ test l r (Left (x, t1, t2)) = + (if t1 && t2 then put true x else put false x)+ >> next (if t1 then l else Nothing) (if t2 then r else Nothing)+ test _ Nothing (Right (Left l)) = next (Just l) Nothing+ test _ (Just r) (Right (Left l)) = put edge (l, r) >> next (Just l) (Just r)+ test Nothing _ (Right (Right r)) = next Nothing (Just r)+ test (Just l) _ (Right (Right r)) = put edge (l, r) >> next (Just l) (Just r)+ in next Nothing Nothing) >> return () -- | Combinator 'pOr' is a pairwise logical disjunction of two splitters run in parallel on the same input.-pOr :: forall c m x b1 b2. Monad m => PairBinder m -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x (Either b1 b2)+pOr :: forall m x b1 b2. Monad m => PairBinder m -> Splitter m x b1 -> Splitter m x b2 -> Splitter m x (Either b1 b2) pOr = zipSplittersWith (||) pour ifs :: forall c m x b. (Monad m, Branching c m x ()) => PairBinder m -> Splitter m x b -> c -> c -> c@@ -380,7 +379,7 @@ where if' :: forall d. PairBinder m -> (forall a d'. AncestorFunctor d d' => OpenConsumer m a d' x ()) -> (forall a d'. AncestorFunctor d d' => OpenConsumer m a d' x ()) -> forall a. OpenConsumer m a d x ()- if' binder c1 c2 source = splitInputToConsumers binder s source c1 c2+ if' binder' c1' c2' source = splitInputToConsumers binder' s source c1' c2' wherever :: forall m x b. Monad m => PairBinder m -> Transducer m x x -> Splitter m x b -> Transducer m x x wherever binder t s = isolateTransducer wherever'@@ -394,15 +393,17 @@ unless binder t s = wherever binder t (sNot s) select :: forall m x b. Monad m => Splitter m x b -> Transducer m x x-select s = isolateTransducer $ \source sink-> suppressProducer (suppressProducer . split s source sink)+select s = isolateTransducer t + where t :: forall d. Functor d => Source m d x -> Sink m d x -> Coroutine d m ()+ t source sink = split s source sink (nullSink :: Sink m d x) (nullSink :: Sink m d b) -- | 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-> pipe (transduce (splitterToMarker s) source)- (\source-> concatMapAccumStream wrap Nothing source sink - >>= maybe (return ()) (put sink . flush))+ (\source'-> concatMapAccumStream wrap Nothing source' sink + >>= maybe (return ()) (put sink . flush)) >> return () where wrap Nothing (Left (x, _)) = (Nothing, [Content x]) wrap (Just p) (Left (x, False)) = (Nothing, [flush p, Content x])@@ -421,11 +422,11 @@ PairBinder m -> Splitter m x (Boundary b) -> Transducer m x y -> Transducer m x (Markup b y) parseEachNestedRegion binder s t = isolateTransducer $ \source sink->- let transformContent source = transduce t source (mapSink Content sink)+ let transformContent contentSource = transduce t contentSource (mapSink Content sink) in pipeG binder (transduce (splitterToMarker s) source)- (\source-> groupMarks source (maybe transformContent (\mark group-> maybe (return ()) (put sink . Markup) mark- >> transformContent group)))+ (flip groupMarks (maybe transformContent (\mark group-> maybe (return ()) (put sink . Markup) mark+ >> transformContent group))) >> return () -- | The recursive combinator 'while' feeds the true sink of the argument splitter back to itself, modified by the@@ -436,11 +437,11 @@ where while' :: forall d. Functor d => Source m d x -> Sink m d x -> Coroutine d m () while' source sink = pipeG binder- (\true-> split s source true sink (nullSink :: Sink m d b))- (\source-> peek source- >>= maybe - (return ())- (\_-> transduce (compose binder t whileRest) source sink))+ (\true'-> split s source true' sink (nullSink :: Sink m d b))+ (\source'-> peek source'+ >>= maybe + (return ())+ (\_-> transduce (compose binder t whileRest) source' sink)) >> return () -- | The recursive combinator 'nestedIn' combines two splitters into a mutually recursive loop acting as a single@@ -455,13 +456,13 @@ isolateSplitter $ \ source true false edge -> liftM fst $ pipeG binder- (\false-> split s1 source true false edge)- (\source-> pipe- (\true-> splitInput s2 source true false)- (\source-> peek source- >>= maybe- (return ())- (\_-> split nestedRest source true false edge)))+ (\false'-> split s1 source true false' edge)+ (\source'-> pipe+ (\true'-> splitInput s2 source' true' false)+ (\source''-> peek source''+ >>= maybe+ (return ())+ (\_-> split nestedRest source'' true false edge))) -- | The 'foreach' combinator is similar to the combinator 'ifs' in that it combines a splitter and two transducers into -- another transducer. However, in this case the transducers are re-instantiated for each consecutive portion of the@@ -474,11 +475,11 @@ (forall a d'. AncestorFunctor d d' => OpenConsumer m a d' x ()) -> (forall a d'. AncestorFunctor d d' => OpenConsumer m a d' x ()) -> forall a. OpenConsumer m a d x ()- foreach' binder c1 c2 source =+ foreach' binder' c1' c2' source = liftM fst $- pipeG binder+ pipeG binder' (transduce (splitterToMarker s) (liftSource source :: Source m d x))- (\source-> groupMarks source (maybe c2 (const c1)))+ (\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@@ -488,7 +489,7 @@ having :: forall m x y b1 b2. (Monad m, Coercible x y) => PairBinder m -> Splitter m x b1 -> Splitter m y b2 -> Splitter m x b1 having binder s1 s2 = isolateSplitter s- where s :: forall a2 d. Functor d => Source m d x -> Sink m d x -> Sink m d x -> Sink m d b1 -> Coroutine d m ()+ where s :: forall d. Functor d => Source m d x -> Sink m d x -> Sink m d x -> Sink m d b1 -> Coroutine d m () s source true false edge = pipeG binder (transduce (splitterToMarker s1) source) (flip groupMarks test)@@ -499,16 +500,15 @@ (_, maybeFound) <- pipe (produce $ adaptProducer $ Producer $ putList chunkBuffer) (findsTrueIn s2) if isJust maybeFound - then maybe (return ()) (put edge) mb >> putList chunkBuffer true- else putList chunkBuffer false- return ()+ then maybe (return ()) (put edge) mb >> putList chunkBuffer true >> return ()+ else putList chunkBuffer false >> return () -- | The 'havingOnly' combinator is analogous to the 'having' combinator, but it succeeds and passes each chunk of the -- input to its /true/ sink only if the second splitter sends no part of it to its /false/ sink. havingOnly :: forall m x y b1 b2. (Monad m, Coercible x y) => PairBinder m -> Splitter m x b1 -> Splitter m y b2 -> Splitter m x b1 havingOnly binder s1 s2 = isolateSplitter s- where s :: forall a2 d. Functor d => Source m d x -> Sink m d x -> Sink m d x -> Sink m d b1 -> Coroutine d m ()+ where s :: forall d. Functor d => Source m d x -> Sink m d x -> Sink m d x -> Sink m d b1 -> Coroutine d m () s source true false edge = pipeG binder (transduce (splitterToMarker s1) source) (flip groupMarks test)@@ -519,9 +519,8 @@ (_, anyFalse) <- pipe (produce $ adaptProducer $ Producer $ putList chunkBuffer) (findsFalseIn s2) if anyFalse- then putList chunkBuffer false- else maybe (return ()) (put edge) mb >> putList chunkBuffer true- return ()+ then putList chunkBuffer false >> return ()+ else maybe (return ()) (put edge) mb >> putList chunkBuffer true >> return () -- | The result of combinator 'first' behaves the same as the argument splitter up to and including the first portion of -- the input which goes into the argument's /true/ sink. All input following the first true portion goes into the@@ -529,12 +528,13 @@ first :: forall m x b. Monad m => Splitter m x b -> Splitter m x b first splitter = wrapMarkedSplitter splitter $ \source true false edge-> - pourUntil (either snd (const True)) source (mapSink (\(Left (x, False))-> x) false)- >>= maybe- (return ())- (\x-> either (const $ return ()) (\b-> put edge b >> get source >> return ()) x- >> pourWhile (either snd (const False)) source (mapSink (\(Left (x, True))-> x) true)- >> mapMaybeStream (either (Just . fst) (const Nothing)) source false)+ let true' = mapSink (\(Left (x, True))-> x) true+ in pourUntil (either snd (const True)) source (mapSink (\(Left (x, False))-> x) false)+ >>= maybe+ (return ())+ (\x-> either (const $ return ()) (\b-> put edge b >> get source >> return ()) x+ >> pourWhile (either snd (const False)) source true'+ >> mapMaybeStream (either (Just . fst) (const Nothing)) source false) -- | 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@@ -543,13 +543,14 @@ uptoFirst :: forall m x b. Monad m => Splitter m x b -> Splitter m x b uptoFirst splitter = wrapMarkedSplitter splitter $ \source true false edge->- do (prefix, mx) <- getUntil (either snd (const True)) source- let prefix' = map (\(Left (x, False))-> x) prefix + do (pfx, mx) <- getUntil (either snd (const True)) source+ let prefix' = map (\(Left (x, False))-> x) pfx+ true' = mapSink (\(Left (x, True))-> x) true maybe (putList prefix' false >> return ()) (\x-> putList prefix' true >> either (const $ return ()) (\b-> put edge b >> get source >> return ()) x- >> pourWhile (either snd (const False)) source (mapSink (\(Left (x, True))-> x) true)+ >> pourWhile (either snd (const False)) source true' >> mapMaybeStream (either (Just . fst) (const Nothing)) source false) mx @@ -564,14 +565,14 @@ let true' = mapSink (\(Left (x, _))-> x) true false' = mapSink (\(Left (x, _))-> x) false split1 Nothing = return []- split1 (Just (Left (x, True))) = split2 Nothing+ split1 (Just (Left ~(_, True))) = split2 Nothing split1 (Just (Right b)) = get source >> split2 (Just b) split2 mb = getUntil (either (not . snd) (const True)) source >>= split3 mb split3 mb (trues, Nothing) = maybe (return ()) (put edge) mb >> putList trues true'- split3 mb (trues, Just (Left (_, False))) = getUntil (either snd (const True)) source >>= split4 mb trues- split3 mb (trues, b@(Just Right{})) = putList trues false' >> split1 b+ split3 mb (trues, Just (Left ~(_, False))) = getUntil (either snd (const True)) source >>= split4 mb trues+ split3 _ (trues, b@(Just Right{})) = putList trues false' >> split1 b split4 mb ts (fs, Nothing) = maybe (return ()) (put edge) mb >> putList ts true' >> putList fs false'- split4 mb ts (fs, x@Just{}) = putList ts false' >> putList fs false' >> split1 x+ split4 _ ts (fs, x@Just{}) = putList ts false' >> putList fs false' >> split1 x in pourUntil (either snd (const True)) source false' >>= split1 >> return () -- | The result of the combinator 'lastAndAfter' is a splitter which directs all input to its /false/ sink, up to the@@ -585,14 +586,14 @@ let true' = mapSink (\(Left (x, _))-> x) true false' = mapSink (\(Left (x, _))-> x) false split1 Nothing = return []- split1 (Just (Left (x, True))) = split2 Nothing+ split1 (Just (Left ~(_, True))) = split2 Nothing split1 (Just (Right b)) = get source >> split2 (Just b) split2 mb = getUntil (either (not . snd) (const True)) source >>= split3 mb split3 mb (trues, Nothing) = maybe (return ()) (put edge) mb >> putList trues true'- split3 mb (trues, Just (Left (_, False))) = getUntil (either snd (const True)) source >>= split4 mb trues- split3 mb (trues, b@(Just Right{})) = putList trues false' >> split1 b+ split3 mb (trues, Just (Left ~(_, False))) = getUntil (either snd (const True)) source >>= split4 mb trues+ split3 _ (trues, b@(Just Right{})) = putList trues false' >> split1 b split4 mb ts (fs, Nothing) = maybe (return ()) (put edge) mb >> putList ts true' >> putList fs true'- split4 mb ts (fs, x@Just{}) = putList ts false' >> putList fs false' >> split1 x+ split4 _ ts (fs, x@Just{}) = putList ts false' >> putList fs false' >> split1 x in pourUntil (either snd (const True)) source false' >>= split1 >> return () -- | The 'prefix' combinator feeds its /true/ sink only the prefix of the input that its argument feeds to its /true/@@ -603,11 +604,11 @@ peek source >>= maybe (return ())- (\x-> either (return . snd) (\x-> put edge x >> get source >> return True) x- >>= flip when (pourWhile (either snd (const False))- source - (mapSink (\(Left (x, True))-> x) true))- >> mapMaybeStream (either (Just . fst) (const Nothing)) source false)+ (\x0-> either (return . snd) (\x-> put edge x >> get source >> return True) x0+ >>= flip when (pourWhile (either snd (const False))+ source + (mapSink (\(Left (x, True))-> x) true))+ >> mapMaybeStream (either (Just . fst) (const Nothing)) source false) -- | 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.@@ -619,11 +620,11 @@ false' = mapSink (\(Left (x, _))-> x) false split0 = pourUntil (either snd (const True)) source false' >>= split1 split1 Nothing = return []- split1 (Just (Left (x, True))) = split2 Nothing+ split1 (Just Left{}) = split2 Nothing split1 (Just (Right b)) = get source >> split2 (Just b) split2 mb = getUntil (either (not . snd) (const True)) source >>= split3 mb split3 mb (trues, Nothing) = maybe (return ()) (put edge) mb >> putList trues true'- split3 mb (trues, Just{}) = putList trues false' >> split0+ split3 _ (trues, Just{}) = putList trues false' >> split0 in split0 >> return () -- | The 'even' combinator takes every input section that its argument /splitter/ deems /true/, and feeds even ones into@@ -632,34 +633,35 @@ even :: forall m x b. Monad m => Splitter m x b -> Splitter m x b even splitter = wrapMarkedSplitter splitter $ \source true false edge->- let split 1 (Left (x, False)) = put false x >> return 1- split 1 p@(Left (x, True)) = split 2 p- split 1 (Right b) = return 2- split 2 (Left (x, True)) = put false x >> return 2- split 2 p@(Left (x, False)) = split 3 p- split 2 (Right b) = put edge b >> return 4- split 3 (Left (x, False)) = put false x >> return 3- split 3 p@(Left (x, True)) = split 4 p- split 3 (Right b) = put edge b >> return 4- split 4 (Left (x, True)) = put true x >> return 4- split 4 p@(Left (x, False)) = split 1 p- split 4 (Right b) = return 2- in foldMStream_ split 1 source+ let true' = mapSink (\(Left (x, _))-> x) true+ false' = mapSink (\(Left (x, _))-> x) false+ split0 = pourUntil (either snd (const True)) source false' >>= split1+ split1 Nothing = return ()+ split1 (Just (Left ~(_, True))) = split2+ split1 (Just Right{}) = get source >> split2+ split2 = pourUntil (either (not . snd) (const True)) source false' >>= split3+ split3 Nothing = return ()+ split3 (Just (Left ~(_, False))) = pourUntil (either snd (const True)) source false' >>= split4+ split3 r@(Just Right{}) = split4 r+ split4 Nothing = return ()+ split4 (Just (Left ~(_, True))) = split5+ split4 (Just (Right b)) = put edge b >> get source >> split5+ split5 = pourWhile (either snd (const False)) source true' >> split0+ in split0 -- | Splitter 'startOf' issues an empty /true/ section at the beginning of every section considered /true/ by its -- argument splitter, otherwise the entire input goes into its /false/ sink. startOf :: forall m x b. Monad m => Splitter m x b -> Splitter m x (Maybe b) startOf splitter = wrapMarkedSplitter splitter $- \source true false edge->- let true' = mapSink (\(Left (x, _))-> x) true- false' = mapSink (\(Left (x, _))-> x) false+ \source _true false edge->+ let false' = mapSink (\(Left (x, _))-> x) false split0 = pourUntil (either snd (const True)) source false' >>= split1 split1 Nothing = return ()- split1 (Just (Left (x, True))) = put edge Nothing >> split2+ split1 (Just (Left ~(_, True))) = put edge Nothing >> split2 split1 (Just (Right b)) = put edge (Just b) >> get source >> split2 split2 = pourUntil (either (not . snd) (const True)) source false' >>= split3 split3 Nothing = return ()- split3 (Just (Left (x, False))) = split0+ split3 (Just (Left ~(_, False))) = split0 split3 mb@(Just Right{}) = split1 mb in split0 @@ -667,17 +669,16 @@ -- splitter, otherwise the entire input goes into its /false/ sink. endOf :: forall m x b. Monad m => Splitter m x b -> Splitter m x (Maybe b) endOf splitter = wrapMarkedSplitter splitter $- \source true false edge->- let true' = mapSink (\(Left (x, _))-> x) true- false' = mapSink (\(Left (x, _))-> x) false+ \source _true false edge->+ let false' = mapSink (\(Left (x, _))-> x) false split0 = pourUntil (either snd (const True)) source false' >>= split1 split1 Nothing = return ()- split1 (Just (Left (x, True))) = split2 Nothing+ split1 (Just (Left ~(_, True))) = split2 Nothing split1 (Just (Right b)) = get source >> split2 (Just b) split2 mb = pourUntil (either (not . snd) (const True)) source false' >>= (put edge mb >>) . split3 split3 Nothing = return ()- split3 (Just (Left (x, False))) = split0+ split3 (Just (Left ~(_, False))) = split0 split3 mb@(Just Right{}) = split1 mb in split0 @@ -690,70 +691,71 @@ isolateSplitter $ \ source true false edge -> pipeG binder (transduce (splitterToMarker s1) source)- (\source-> let get0 q = case Seq.viewl q- of Seq.EmptyL -> split0- (Left (x, False)) :< rest -> put false x- >> get0 rest- (Left (x, True)) :< rest -> get2 Nothing Seq.empty q- (Right b) :< rest -> get2 (Just b) Seq.empty rest- false' = mapSink (\(Left (x, _))-> x) false- true' = mapSink (\(Left (x, _))-> x) true- split0 = pourUntil (either snd (const True)) source false'- >>= maybe - (return ()) - (either (const $ split1 Nothing) (\b-> get source >> split1 (Just b)))- split1 mb = do (list, mx) <- getUntil (either (not . snd) (const True)) source- let list' = Seq.fromList $ map (\(Left (x, True))-> x) list- maybe- (testEnd mb (Seq.fromList $ map (\(Left (x, True))-> x) list))- ((get source >>) . get3 mb list' . Seq.singleton)- mx- get2 mb q q' = case Seq.viewl q'- of Seq.EmptyL -> get source- >>= maybe (testEnd mb q) (get2 mb q . Seq.singleton)- (Left (x, True)) :< rest -> get2 mb (q |> x) rest- (Left (x, False)) :< rest -> get3 mb q q'- Right{} :< rest -> get3 mb q q'- get3 mb q q' = do let list = mapMaybe - (either (Just . fst) (const Nothing)) - (Foldable.toList $ Seq.viewl q')- (q'', n) <- pipe (\sink-> putList list sink >> get7 q' sink) (test mb q)- case n of Nothing -> putQueue q false >> get0 q''- Just 0 -> get0 q''- Just n -> get8 (Just mb) n q''- get7 q sink = do list <- getWhile (either (const True) (const False)) source- rest <- putList (map (\(Left (x, _))-> x) list) sink- let q' = q >< Seq.fromList list- if null rest - then get source >>= maybe (return q') (\x-> get7 (q' |> x) sink)- else return q'- testEnd mb q = do ((), n) <- pipe (const $ return ()) (test mb q)- case n of Nothing -> putQueue q false >> return ()- _ -> return ()- test mb q source = liftM snd $- pipe- (transduce (splitterToMarker s2) source)- (\source-> let test0 (Left (_, False)) = get source >> return Nothing- test0 (Left (_, True)) = test1- test0 (Right b') = maybe - (return ()) - (\b-> put edge (b, b')) - mb- >> get source- >> test1- test1 = putQueue q true- >> getWhile (either snd (const False)) source- >>= \list-> putList list true'- >> get source- >> return (Just $ length list)- in peek source >>= maybe (return Nothing) test0)- get8 Nothing 0 q = get0 q- get8 (Just mb) 0 q = get2 mb Seq.empty q- get8 mmb n q = case Seq.viewl q of Left (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 split0)+ (\source'-> let get0 q = case Seq.viewl q+ of Seq.EmptyL -> split0+ (Left (x, False)) :< rest -> put false x >> get0 rest+ (Left (_, True)) :< _ -> get2 Nothing Seq.empty q+ (Right b) :< rest -> get2 (Just b) Seq.empty rest+ false' = mapSink (\(Left (x, _))-> x) false+ true' = mapSink (\(Left (x, _))-> x) true+ split0 = pourUntil (either snd (const True)) source' false'+ >>= maybe + (return ()) + (either (const $ split1 Nothing) (\b-> get source' >> split1 (Just b)))+ split1 mb = do (list, mx) <- getUntil (either (not . snd) (const True)) source'+ let list' = Seq.fromList $ map (\(Left (x, True))-> x) list+ maybe+ (testEnd mb (Seq.fromList $ map (\(Left (x, True))-> x) list))+ ((get source' >>) . get3 mb list' . Seq.singleton)+ mx+ get2 mb q q' = case Seq.viewl q'+ of Seq.EmptyL -> get source'+ >>= maybe (testEnd mb q) (get2 mb q . Seq.singleton)+ (Left (x, True)) :< rest -> get2 mb (q |> x) rest+ (Left (_, False)) :< _ -> get3 mb q q'+ Right{} :< _ -> get3 mb q q'+ get3 mb q q' = do let list = mapMaybe + (either (Just . fst) (const Nothing)) + (Foldable.toList $ Seq.viewl q')+ (q'', mn) <- pipe (\sink-> putList list sink >> get7 q' sink) (test mb q)+ case mn of Nothing -> putQueue q false >> get0 q''+ Just 0 -> get0 q''+ Just n -> get8 (Just mb) n q''+ get7 q sink = do list <- getWhile (either (const True) (const False)) source'+ rest <- putList (map (\(Left (x, _))-> x) list) sink+ let q' = q >< Seq.fromList list+ if null rest + then get source' >>= maybe (return q') (\x-> get7 (q' |> x) sink)+ else return q'+ testEnd mb q = do ((), n) <- pipe (const $ return ()) (test mb q)+ case n of Nothing -> putQueue q false >> return ()+ _ -> return ()+ test mb q source'' = liftM snd $+ pipe+ (transduce (splitterToMarker s2) source'')+ (\source'''-> let test0 (Left (_, False)) = get source''' + >> return Nothing+ test0 (Left (_, True)) = test1+ test0 (Right b') = maybe + (return ()) + (\b-> put edge (b, b')) + mb+ >> get source'''+ >> test1+ test1 = putQueue q true+ >> getWhile (either snd (const False)) source'''+ >>= \list-> putList list true'+ >> get source'''+ >> return (Just $ length list)+ in peek source''' >>= maybe (return Nothing) test0)+ get8 Nothing 0 q = get0 q+ get8 (Just mb) 0 q = get2 mb Seq.empty q+ get8 mmb n q = case Seq.viewl q + of Left (_, False) :< rest -> get8 Nothing (pred n) rest+ Left (_, True) :< rest -> get8 (maybe (Just Nothing) Just mmb) (pred n) rest+ Right b :< rest -> get8 (Just (Just b)) n rest+ EmptyL -> error "Expecting a non-empty queue!" + in split0) >> return () -- | Combinator 'between' tracks the running balance of difference between the number of preceding starts of sections@@ -775,7 +777,7 @@ state 0 (Right (Left b)) = put edge b >> return 1 state n (Right (Left _)) = return (succ n) state n (Right (Right _)) = return (pred n)- in foldMStream_ state 0)+ in foldMStream_ state (0 :: Int)) >> return () -- Helper functions@@ -789,7 +791,7 @@ wrapMarkedSplitter splitter splitMarked = isolateSplitter $ \ source true false edge -> pipe (transduce (splitterToMarker splitter) source)- (\source-> splitMarked source true false edge)+ (\source'-> splitMarked source' true false edge) >> return () splitterToMarker :: forall m x b. Monad m => Splitter m x b -> Transducer m x (Either (x, Bool) b)@@ -802,40 +804,39 @@ splittersToPairMarker :: forall m x b1 b2. Monad m => PairBinder m -> Splitter m x b1 -> Splitter m x b2 -> Transducer m x (Either (x, Bool, Bool) (Either b1 b2)) splittersToPairMarker binder s1 s2 =- let t :: forall d. Functor d => Source m d x -> Sink m d (Either (x, Bool, Bool) (Either b1 b2)) -> Coroutine d m ()- t source sink = - pipe- (\sync-> teeConsumers binder- (\source1-> split s1 source1- (mapSink (\x-> Left ((x, True), True)) sync)- (mapSink (\x-> Left ((x, False), True)) sync)- (mapSink (Right. Left) sync))- (\source2-> split s2 source2- (mapSink (\x-> Left ((x, True), False)) sync)- (mapSink (\x-> Left ((x, False), False)) sync)- (mapSink (Right . Right) sync))- source)- (synchronizeMarks sink)- >> return ()- synchronizeMarks :: forall m a1 a2 d. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d) =>+ let synchronizeMarks :: forall a1 a2 d. (AncestorFunctor a1 d, AncestorFunctor a2 d) => Sink m a1 (Either (x, Bool, Bool) (Either b1 b2)) -> Source m a2 (Either ((x, Bool), Bool) (Either b1 b2)) -> Coroutine d m (Maybe (Seq (Either (x, Bool) (Either b1 b2)), Bool)) synchronizeMarks sink source = foldMStream handleMark Nothing source where handleMark Nothing (Right b) = put sink (Right b) >> return Nothing- handleMark Nothing (Left (p, first)) = return (Just (Seq.singleton (Left p), first))- handleMark state@(Just (q, first)) (Left (p, first')) | first == first' = return (Just (q |> Left p, first))- handleMark state@(Just (q, True)) (Right b@Left{}) = return (Just (q |> Right b, True))- handleMark state@(Just (q, False)) (Right b@Right{}) = return (Just (q |> Right b, False))+ handleMark Nothing (Left (p, head)) = return (Just (Seq.singleton (Left p), head))+ handleMark (Just (q, head)) (Left (p, head')) | head == head' = return (Just (q |> Left p, head))+ handleMark (Just (q, True)) (Right b@Left{}) = return (Just (q |> Right b, True))+ handleMark (Just (q, False)) (Right b@Right{}) = return (Just (q |> Right b, False)) handleMark state (Right b) = put sink (Right b) >> return state- handleMark state@(Just (q, pos')) mark@(Left ((x, t), pos))+ handleMark (Just (q, pos')) mark@(Left (p@(_, t), pos)) = case Seq.viewl q- of Seq.EmptyL -> return (Just (Seq.singleton (Left (x, t)), pos))+ of Seq.EmptyL -> return (Just (Seq.singleton (Left p), pos)) Right b :< rest -> put sink (Right b) >> handleMark (if Seq.null rest then Nothing else Just (rest, pos')) mark Left (y, t') :< rest -> put sink (Left $ if pos then (y, t, t') else (y, t', t)) >> return (if Seq.null rest then Nothing else Just (rest, pos'))- in isolateTransducer t+ in isolateTransducer $+ \source sink->+ pipe+ (\sync-> teeConsumers binder+ (\source1-> split s1 source1+ (mapSink (\x-> Left ((x, True), True)) sync)+ (mapSink (\x-> Left ((x, False), True)) sync)+ (mapSink (Right. Left) sync))+ (\source2-> split s2 source2+ (mapSink (\x-> Left ((x, True), False)) sync)+ (mapSink (\x-> Left ((x, False), False)) sync)+ (mapSink (Right . Right) sync))+ source)+ (synchronizeMarks sink)+ >> return () zipSplittersWith :: forall m x b1 b2 b. Monad m => (Bool -> Bool -> Bool) -> @@ -845,13 +846,13 @@ zipSplittersWith f boundaries binder s1 s2 = isolateSplitter $ \ source true false edge -> pipe- (\edge->+ (\edge'-> pipeG binder (transduce (splittersToPairMarker binder s1 s2) source) (mapMStream_ (either (\(x, t1, t2)-> if f t1 t2 then put true x else put false x)- (put edge))))+ (put edge')))) (flip boundaries edge) >> return () @@ -866,11 +867,7 @@ startContent (_, False) = pipe (next False) (getConsumer Nothing) startContent (_, True) = pipe (next True) (getConsumer $ Just Nothing) startRegion b = get source >> pipe (next True) (getConsumer (Just $ Just b))- next t sink = pourUntil (either (\(x, t')-> t /= t') (const True)) source (mapSink (\(Left (x, t))-> x) sink)---- | 'suppressProducer' runs the /producer/ argument with a new sink, suppressing everything 'put' in the sink.-suppressProducer :: forall m a x r. (Functor a, Monad m) => (Sink m a x -> Coroutine a m r) -> Coroutine a m r-suppressProducer producer = producer (nullSink :: Sink m a x)+ next t sink = pourUntil (either (\(_, t')-> t /= t') (const True)) source (mapSink (\(Left (x, _))-> x) sink) splitInput :: forall m a1 a2 a3 d x b. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d) => Splitter m x b -> Source m a1 x -> Sink m a2 x -> Sink m a3 x -> Coroutine d m ()@@ -899,10 +896,11 @@ get >>= \((), maybeFalse)-> return (isJust maybeFalse) -teeConsumers :: forall m a d x r1 r2. Monad m- => PairBinder m -> (forall a. OpenConsumer m a (SinkFunctor d x) x r1)- -> (forall a. OpenConsumer m a (SourceFunctor d x) x r2)- -> OpenConsumer m a d x (r1, r2)+teeConsumers :: forall m a d x r1 r2. Monad m => + PairBinder m + -> (forall a'. OpenConsumer m a' (SinkFunctor d x) x r1)+ -> (forall a'. OpenConsumer m a' (SourceFunctor d x) x r2)+ -> OpenConsumer m a d x (r1, r2) teeConsumers binder c1 c2 source = pipeG binder consume1 c2 where consume1 sink = c1 (teeSource sink source' :: Source m (SinkFunctor d x) x) source' :: Source m d x
Control/Concurrent/SCC/Configurable.hs view
@@ -32,14 +32,13 @@ import Prelude hiding (appendFile, even, id, last, sequence, (||), (&&)) import qualified Control.Category-import Control.Monad (liftM)-import Data.Text (Text, unpack)+import Data.Text (Text) import System.IO (Handle) import Control.Monad.Coroutine import Control.Monad.Parallel (MonadParallel(..)) -import qualified Control.Concurrent.SCC.Streams+import Control.Concurrent.SCC.Streams import Control.Concurrent.SCC.Types import Control.Concurrent.SCC.Coercions (Coercible) import qualified Control.Concurrent.SCC.Coercions as Coercion@@ -48,7 +47,7 @@ import qualified Control.Concurrent.SCC.XML as XML import Control.Concurrent.SCC.Primitives (OccurenceTag) import Control.Concurrent.SCC.XML (XMLToken)-import Control.Concurrent.Configuration hiding (liftParallelPair, parallelRouterAndBranches, recursiveComponentTree)+import Control.Concurrent.Configuration (Component, atomic, lift, liftSequentialPair) import qualified Control.Concurrent.Configuration as Configuration -- * Configurable component types@@ -222,13 +221,13 @@ -- | SplitterComponent 'markedWith' passes input sections marked-up with the appropriate tag to its /true/ sink, and the -- rest of the input to its /false/ sink. The argument /select/ determines if the tag is appropriate. markedWith :: (Monad m, Eq y) => (y -> Bool) -> SplitterComponent m (Markup y x) ()-markedWith select = atomic "markedWith" 1 (Primitive.markedWith select)+markedWith selector = atomic "markedWith" 1 (Primitive.markedWith selector) -- | SplitterComponent 'contentMarkedWith' passes the content of input sections marked-up with the appropriate tag to -- its /true/ sink, and the rest of the input to its /false/ sink. The argument /select/ determines if the tag is -- appropriate. contentMarkedWith :: (Monad m, Eq y) => (y -> Bool) -> SplitterComponent m (Markup y x) ()-contentMarkedWith select = atomic "contentMarkedWith" 1 (Primitive.contentMarkedWith select)+contentMarkedWith selector = atomic "contentMarkedWith" 1 (Primitive.contentMarkedWith selector) -- | SplitterComponent 'one' feeds all input values to its /true/ sink, treating every value as a separate section. one :: Monad m => SplitterComponent m x ()
Control/Concurrent/SCC/Primitives.hs view
@@ -46,29 +46,22 @@ ) where -import Prelude hiding (appendFile)+import Prelude hiding (appendFile, head, tail) -import Control.Category ((>>>)) import Control.Exception (assert) import Control.Monad (liftM, when, unless) import Control.Monad.Trans.Class (lift)-import qualified Control.Monad as Monad import Data.ByteString (ByteString)-import Data.Char (isAlpha, isDigit, isPrint, isSpace, toLower, toUpper)-import Data.List (delete, isPrefixOf, stripPrefix)-import Data.Maybe (fromJust)+import Data.Char (isAlpha, isDigit, isSpace, toLower, toUpper)+import Data.List (delete, stripPrefix) import qualified Data.ByteString as ByteString import qualified Data.Foldable as Foldable import qualified Data.Sequence as Seq-import Data.Sequence (Seq, (|>), (><), ViewL (EmptyL, (:<)), ViewR (EmptyR, (:>)))-import Debug.Trace (trace)-import System.IO (Handle, IOMode (ReadMode, WriteMode, AppendMode), openFile, hClose,- getLine, hGetLine, hPutStr, hFlush, hIsEOF, hClose, putStr, isEOF, stdout)+import Data.Sequence (Seq, (|>), (><), ViewL (EmptyL, (:<)))+import System.IO (Handle, IOMode (ReadMode, WriteMode, AppendMode), + openFile, hClose, hGetLine, hPutStr, hIsEOF, hClose, isEOF) import Control.Cofunctor.Ticker (tickPrefixOf)-import Control.Monad.Coroutine-import Control.Monad.Coroutine.SuspensionFunctors-import Control.Monad.Coroutine.Nested import Control.Concurrent.SCC.Streams import Control.Concurrent.SCC.Types@@ -103,9 +96,9 @@ -- | Feeds the given sink from the open binary file /handle/. The argument /chunkSize/ determines the size of the chunks -- read from the handle. fromBinaryHandle :: Handle -> Int -> Producer IO ByteString ()-fromBinaryHandle handle chunkSize = Producer produce- where produce sink = lift (ByteString.hGet handle chunkSize) - >>= \chunk-> unless (ByteString.null chunk) (tryPut sink chunk >>= flip when (produce sink))+fromBinaryHandle handle chunkSize = Producer p+ where p sink = lift (ByteString.hGet handle chunkSize) + >>= \chunk-> unless (ByteString.null chunk) (tryPut sink chunk >>= flip when (p sink)) -- | Creates the named text file and writes the entire given source to it. toFile :: String -> Consumer IO Char ()@@ -138,7 +131,7 @@ 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 :: forall m x. Monad m => Consumer m x () suppress = Consumer (\(src :: Source m a x)-> pour src (nullSink :: Sink m a x)) -- | The 'erroneous' consumer reports an error if any input reaches it.@@ -155,7 +148,7 @@ -- | The 'count' transducer counts all its input values and outputs the final tally. count :: forall m x. Monad m => Transducer m x Integer-count = Transducer (\source sink-> foldStream (\count _-> succ count) 0 source >>= put sink)+count = Transducer (\source sink-> foldStream (\n _-> succ n) 0 source >>= put sink) -- | Converts each input value @x@ to @show x@. toString :: forall m x. (Monad m, Show x) => Transducer m x String@@ -195,27 +188,28 @@ -- 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 loop = peek source >>= maybe (return ()) (( >> loop) . line)- line c = put boundaries ()- >> if c == '\r' || c == '\n' - then lineEnd c - else pourUntil (\x-> x == '\n' || x == '\r') source true - >>= maybe (return ()) lineEnd+ let loop = peek source >>= maybe (return ()) (( >> loop) . lineChar)+ lineChar c = put boundaries ()+ >> if c == '\r' || c == '\n' + then lineEnd c + else pourUntil (\x-> x == '\n' || x == '\r') source true + >>= maybe (return ()) lineEnd lineEnd '\n' = pourTicked (tickPrefixOf "\n\r") source false lineEnd '\r' = pourTicked (tickPrefixOf "\r\n") source false+ lineEnd _ = error "Newline characters only please!" in loop -- | Splitter 'everything' feeds its entire input into its /true/ sink. everything :: forall m x. Monad m => Splitter m x ()-everything = Splitter (\source true false edge-> put edge () >> pour source true)+everything = Splitter (\source true _false edge-> put edge () >> pour source true) -- | Splitter 'nothing' feeds its entire input into its /false/ sink. nothing :: forall m x. Monad m => Splitter m x ()-nothing = Splitter (\source true false edge-> pour source false)+nothing = Splitter (\source _true false _edge-> pour source false) -- | Splitter 'one' feeds all input values to its /true/ sink, treating every value as a separate section. one :: forall m x. Monad m => Splitter m x ()-one = Splitter (\source true false edge-> mapMStream_ (\x-> put edge () >> put true x) source)+one = Splitter (\source true _false edge-> mapMStream_ (\x-> put edge () >> put true x) source) -- | Splitter 'marked' passes all marked-up input sections to its /true/ sink, and all unmarked input to its -- /false/ sink.@@ -234,7 +228,7 @@ 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 s@(_, truth) (Markup (Point _)) = (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)@@ -263,14 +257,14 @@ -- | 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 :: forall m x. (Monad m, Eq x) => [x] -> Parser m x OccurenceTag parseSubstring [] = Transducer $ \ source sink -> put sink marker >> mapMStream_ (\x-> put sink (Content x) >> put sink marker) source where marker = Markup (Point (toEnum 1))-parseSubstring list+parseSubstring list@(first:_) = Transducer $ \ source sink ->- let findFirst = pourUntil (== head list) source (mapSink Content sink)+ let findFirst = pourUntil (== first) source (mapSink Content sink) >>= maybe (return ()) (const test) test = getTicked (tickPrefixOf list) source >>= \prefix-> let Just rest = stripPrefix prefix list@@ -280,30 +274,30 @@ >> put sink head >> fallback 0 (Seq.fromList tail |> Markup (End (toEnum 0))) else getNext 0 rest (Seq.fromList $ map Content prefix)- getNext id rest q = get source- >>= maybe- (flush q)- (advance id rest q)- 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')))- >> put sink qh- >> (fallback id' (qt |> Markup (End (toEnum id'))))- else getNext id tail q'- else fallback id q'- fallback id q = case Seq.viewl q- of EmptyL -> findFirst- head@(Markup (End id')) :< tail -> put sink head- >> fallback- (if id == fromEnum id' then 0 else id)- tail- view@(head@Content{} :< tail) -> case stripPrefix (remainingContent q) list- of Just rest -> getNext id rest q- Nothing -> put sink head- >> fallback id tail+ getNext i rest q = get source+ >>= maybe (flush q) (advance i rest q)+ advance _ [] _ _ = error "Can't advance on an empty list!"+ advance i (head:tail) q x = let q' = q |> Content x+ qh@Content{} :< qt = Seq.viewl q'+ i' = succ i+ in if x == head+ then if null tail+ then put sink (Markup (Start (toEnum i')))+ >> put sink qh+ >> (fallback i' (qt |> Markup (End (toEnum i'))))+ else getNext i tail q'+ else fallback i q'+ fallback i q = case Seq.viewl q+ of EmptyL -> findFirst+ head@(Markup (End i')) :< tail -> put sink head+ >> fallback+ (if i == fromEnum i' then 0 else i)+ tail+ head@Content{} :< tail -> case stripPrefix (remainingContent q) list+ of Just rest -> getNext i rest q+ Nothing -> put sink head+ >> fallback i tail+ _ -> error "Only content and ends can be fallen back on!" flush q = putQueue q sink >> return () remainingContent :: Seq (Markup OccurenceTag x) -> [x] remainingContent q = extractContent (Seq.viewl q)@@ -316,10 +310,10 @@ -- by an edge. substring :: forall m x. (Monad m, Eq x) => [x] -> Splitter m x () substring [] = Splitter $ \ source true false edge -> split one source false true edge >> put edge ()-substring list+substring list@(first:_) = Splitter $ \ source true false edge ->- let findFirst = pourUntil (== head list) source false+ let findFirst = pourUntil (== first) source false >>= maybe (return ()) (const test) test = getTicked (tickPrefixOf list) source >>= \prefix-> let Just rest = stripPrefix prefix list@@ -331,15 +325,16 @@ >>= maybe (putQueue qt true >> putQueue qf false >> return ()) (advance rest qt qf)- advance rest@(head:tail) qt qf x = let qf' = qf |> x- view@(qqh :< qqt) = Seq.viewl (qt >< qf')- in if x == head- then if null tail- then put edge ()- >> put true qqh- >> fallback qqt Seq.empty- else getNext tail qt qf'- else fallback qt qf'+ advance [] _ _ _ = error "Can't advance on an empty list!"+ advance (head:tail) qt qf x = let qf' = qf |> x+ qqh :< qqt = Seq.viewl (qt >< qf')+ in if x == head+ then if null tail+ then put edge ()+ >> put true qqh+ >> fallback qqt Seq.empty+ else getNext tail qt qf'+ else fallback qt qf' fallback qt qf = case Seq.viewl (qt >< qf) of EmptyL -> findFirst view@(head :< tail) -> case stripPrefix (Foldable.toList view) list
Control/Concurrent/SCC/Streams.hs view
@@ -74,13 +74,11 @@ where import qualified Control.Monad-import qualified Data.List-import qualified Data.Maybe import Control.Monad (liftM, when, unless, foldM) import Data.Foldable (toList)-import Data.Maybe (isJust, mapMaybe)-import Data.List (concatMap)+import Data.Maybe (mapMaybe)+import Data.List (mapAccumL) import Data.Sequence (Seq, viewl) import Control.Cofunctor.Ticker@@ -113,7 +111,7 @@ -- keep being called until it returns @False@ or the current chunk gets completely consumed. If the current chunk is -- empty on call, a new one is obtained from the source. The intervening 'Coroutine' computations suspend all the way -- to the 'pipe' function invocation that created the source.- foldChunk :: forall s d. AncestorFunctor a d => Ticker x -> Coroutine d m ([x], Either x (Ticker x))+ foldChunk :: forall d. AncestorFunctor a d => Ticker x -> Coroutine d m ([x], Either x (Ticker x)) } -- | A disconnected sink that ignores all values 'put' into it.@@ -179,9 +177,9 @@ -- | Consumes values from the /source/ as long as the /ticker/ accepts them. getTicked :: forall m a d x. (Monad m, AncestorFunctor a d) => Ticker x -> Source m a x -> Coroutine d m [x] getTicked ticker source = loop return ticker- where loop cont ticker = foldChunk source ticker- >>= \(chunk, result)-> if null chunk then cont chunk- else either (const $ cont chunk) (loop (cont . (chunk ++))) result+ where loop cont t = foldChunk source t+ >>= \(chunk, result)-> if null chunk then cont chunk+ else either (const $ cont chunk) (loop (cont . (chunk ++))) result -- | Consumes values from the /source/ as long as each satisfies the predicate, then returns their list. getWhile :: forall m a d x. (Monad m, AncestorFunctor a d) => (x -> Bool) -> Source m a x -> Coroutine d m [x]@@ -208,9 +206,8 @@ pourTicked :: forall m a1 a2 d x . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d) => Ticker x -> Source m a1 x -> Sink m a2 x -> Coroutine d m () pourTicked ticker source sink = loop ticker- where loop ticker = foldChunk source ticker- >>= \(chunk, next)-> - unless (null chunk) (putChunk sink chunk >> either (const $ return ()) loop next)+ where loop t = foldChunk source t+ >>= \(chunk, next)-> unless (null chunk) (putChunk sink chunk >> either (const $ return ()) loop next) -- | Like 'pour', copies data from the /source/ to the /sink/, but only as long as it satisfies the predicate. pourWhile :: forall m a1 a2 d x . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)@@ -237,10 +234,10 @@ mapSink :: forall m a x y. Monad m => (x -> y) -> Sink m a y -> Sink m a x mapSink f sink = Sink{putChunk= \xs-> putChunk sink (map f xs) >>= \rest-> return (dropExcept (length rest) xs)}- where dropExcept :: forall x. Int -> [x] -> [x]+ where dropExcept :: forall z. Int -> [z] -> [z] dropExcept 0 _ = []- dropExcept n xs = snd (drop' xs)- where drop' :: [x] -> (Int, [x])+ dropExcept n list = snd (drop' list)+ where drop' :: [z] -> (Int, [z]) drop' [] = (0, []) drop' (x:xs) = let r@(len, tl) = drop' xs in if len < n then (succ len, x:tl) else r @@ -256,23 +253,23 @@ concatMapStream f source sink = loop where loop = getChunk source >>= nullOrElse (return ()) ((>> loop) . putChunk sink . concatMap f) --- | 'mapAccumStream' is similar to 'Data.List.mapAccumL' except it reads the values from a 'Source' instead of a list+-- | 'mapAccumStream' is similar to 'mapAccumL' except it reads the values from a 'Source' instead of a list -- and writes the mapped values into a 'Sink' instead of returning another list. mapAccumStream :: forall m a1 a2 d x y acc . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d) => (acc -> x -> (acc, y)) -> acc -> Source m a1 x -> Sink m a2 y -> Coroutine d m acc-mapAccumStream f acc source sink = foldMStreamChunks (\acc xs-> dispatch $ Data.List.mapAccumL f acc xs) acc source- where dispatch (acc, ys) = putChunk sink ys >> return acc+mapAccumStream f acc source sink = foldMStreamChunks (\a xs-> dispatch $ mapAccumL f a xs) acc source+ where dispatch (a, ys) = putChunk sink ys >> return a -- | 'concatMapAccumStream' is a love child of 'concatMapStream' and 'mapAccumStream': it threads the accumulator like -- the latter, but its argument function returns not a single value, but a list of values to write into the sink. concatMapAccumStream :: forall m a1 a2 d x y acc . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d) => (acc -> x -> (acc, [y])) -> acc -> Source m a1 x -> Sink m a2 y -> Coroutine d m acc-concatMapAccumStream f acc source sink = foldMStreamChunks (\acc xs-> dispatch $ concatMapAccumL f acc xs) acc source- where dispatch (acc, ys) = putChunk sink ys >> return acc- concatMapAccumL _ s [] = (s, [])- concatMapAccumL f s (x:xs) = (s'', y ++ ys)+concatMapAccumStream f acc source sink = foldMStreamChunks (\a xs-> dispatch $ concatMapAccumL a xs) acc source+ where dispatch (a, ys) = putChunk sink ys >> return a+ concatMapAccumL s [] = (s, [])+ concatMapAccumL s (x:xs) = (s'', y ++ ys) where (s', y ) = f s x- (s'', ys) = concatMapAccumL f s' xs+ (s'', ys) = concatMapAccumL s' xs -- | Like 'mapStream' except it runs the argument function on whole chunks read from the input. mapStreamChunks :: forall m a1 a2 d x y . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)@@ -308,7 +305,7 @@ -- | Similar to 'Data.List.foldl', but reads the values from a 'Source' instead of a list. foldStream :: forall m a d x acc . (Monad m, AncestorFunctor a d) => (acc -> x -> acc) -> acc -> Source m a x -> Coroutine d m acc-foldStream f s source = loop s+foldStream f acc source = loop acc where loop s = getChunk source >>= nullOrElse (return s) (loop . foldl f s) -- | 'foldMStream' is similar to 'Control.Monad.foldM' except it draws the values from a 'Source' instead of a list and@@ -316,7 +313,7 @@ foldMStream :: forall m a d x acc . (Monad m, AncestorFunctor a d) => (acc -> x -> Coroutine d m acc) -> acc -> Source m a x -> Coroutine d m acc foldMStream f acc source = loop acc- where loop acc = getChunk source >>= nullOrElse (return acc) ((loop =<<) . foldM f acc)+ where loop a = getChunk source >>= nullOrElse (return a) ((loop =<<) . foldM f a) -- | A variant of 'foldMStream' that discards the final result value. foldMStream_ :: forall m a d x acc . (Monad m, AncestorFunctor a d)@@ -327,14 +324,14 @@ foldMStreamChunks :: forall m a d x acc . (Monad m, AncestorFunctor a d) => (acc -> [x] -> Coroutine d m acc) -> acc -> Source m a x -> Coroutine d m acc foldMStreamChunks f acc source = loop acc- where loop acc = getChunk source >>= nullOrElse (return acc) ((loop =<<) . f acc)+ where loop a = getChunk source >>= nullOrElse (return a) ((loop =<<) . f a) -- | 'unfoldMStream' is a version of 'Data.List.unfoldr' that writes the generated values into a 'Sink' instead of -- returning a list. unfoldMStream :: forall m a d x acc . (Monad m, AncestorFunctor a d) => (acc -> Coroutine d m (Maybe (x, acc))) -> acc -> Sink m a x -> Coroutine d m acc unfoldMStream f acc sink = loop acc- where loop acc = f acc >>= maybe (return acc) (\(x, acc')-> put sink x >> loop acc')+ where loop a = f a >>= maybe (return a) (\(x, acc')-> put sink x >> loop acc') -- | 'unmapMStream_' is opposite of 'mapMStream_'; it takes a 'Sink' instead of a 'Source' argument and writes the -- generated values into it.@@ -355,6 +352,7 @@ => (x -> Bool) -> Source m a1 x -> Sink m a2 x -> Sink m a3 x -> Coroutine d m () partitionStream f source true false = mapMStreamChunks_ partitionChunk source where partitionChunk (x:rest) = partitionTo (f x) x rest+ partitionChunk [] = error "Chunks cannot be empty!" partitionTo False x chunk = let (falses, rest) = break f chunk in putChunk false (x:falses) >> case rest of y:ys -> partitionTo True y ys@@ -379,9 +377,9 @@ (MonadParallel m, AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d) => (x -> y -> Coroutine d m z) -> Source m a1 x -> Source m a2 y -> Sink m a3 z -> Coroutine d m () parZipWithMStream f source1 source2 sink = loop- where loop = bindM2 zip (get source1) (get source2)- zip (Just x) (Just y) = f x y >>= put sink >> loop- zip _ _ = return ()+ where loop = bindM2 zipMaybe (get source1) (get source2)+ zipMaybe (Just x) (Just y) = f x y >>= put sink >> loop+ zipMaybe _ _ = return () -- | 'tee' is similar to 'pour' except it distributes every input value from its source argument into its both sink -- arguments.@@ -396,9 +394,9 @@ -- second sink. teeSink :: forall m a1 a2 a3 x . (Monad m, AncestorFunctor a1 a3, AncestorFunctor a2 a3) => Sink m a1 x -> Sink m a2 x -> Sink m a3 x-teeSink s1 s2 = Sink{putChunk= tee}- where tee :: forall d. AncestorFunctor a3 d => [x] -> Coroutine d m [x]- tee x = putChunk s1' x >> putChunk s2' x+teeSink s1 s2 = Sink{putChunk= teeChunk}+ where teeChunk :: forall d. AncestorFunctor a3 d => [x] -> Coroutine d m [x]+ teeChunk x = putChunk s1' x >> putChunk s2' x s1' :: Sink m a3 x s1' = liftSink s1 s2' :: Sink m a3 x@@ -408,11 +406,11 @@ -- providing it back. teeSource :: forall m a1 a2 a3 x . (Monad m, AncestorFunctor a1 a3, AncestorFunctor a2 a3) => Sink m a1 x -> Source m a2 x -> Source m a3 x-teeSource sink source = Source{foldChunk= tee}- where tee :: forall d. AncestorFunctor a3 d => Ticker x -> Coroutine d m ([x], Either x (Ticker x))- tee t = do p@(chunk, next) <- foldChunk source' t- if null chunk then return [] else putChunk sink' chunk- return p+teeSource sink source = Source{foldChunk= teeChunk}+ where teeChunk :: forall d. AncestorFunctor a3 d => Ticker x -> Coroutine d m ([x], Either x (Ticker x))+ teeChunk t = do p@(chunk, _) <- foldChunk source' t+ _ <- if null chunk then return [] else putChunk sink' chunk+ return p sink' :: Sink m a3 x sink' = liftSink sink source' :: Source m a3 x@@ -440,5 +438,5 @@ putQueue q sink = putList (toList (viewl q)) sink nullOrElse :: a -> ([x] -> a) -> [x] -> a-nullOrElse null _ [] = null+nullOrElse nullCase _ [] = nullCase nullOrElse _ f list = f list
Control/Concurrent/SCC/Types.hs view
@@ -44,7 +44,6 @@ import qualified Control.Category as Category import Control.Monad.Coroutine-import Control.Monad.Parallel (MonadParallel(..)) import Control.Concurrent.SCC.Streams @@ -100,51 +99,51 @@ instance Functor (Markup y) where fmap f (Content x) = Content (f x)- fmap f (Markup b) = Markup b+ fmap _ (Markup b) = Markup b instance (Show x , Show y) => Show (Markup y x) where- showsPrec p (Content x) s = shows x s- showsPrec p (Markup b) s = '[' : shows b (']' : s)+ showsPrec _ (Content x) s = shows x s+ showsPrec _ (Markup b) s = '[' : shows b (']' : s) instance Monad m => Category (Transducer m) where id = Transducer pour t1 . t2 = isolateTransducer $ \source sink-> - pipe (transduce t2 source) (\source-> transduce t1 source sink)+ pipe (transduce t2 source) (\source'-> transduce t1 source' sink) >> return () -- | Creates a proper 'Consumer' from a function that is, but can't be proven to be, an 'OpenConsumer'. isolateConsumer :: forall m x r. Monad m => (forall d. Functor d => Source m d x -> Coroutine d m r) -> Consumer m x r-isolateConsumer consume = Consumer consume'+isolateConsumer c = 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'+ in c source' -- | Creates a proper 'Producer' from a function that is, but can't be proven to be, an 'OpenProducer'. isolateProducer :: forall m x r. Monad m => (forall d. Functor d => Sink m d x -> Coroutine d m r) -> Producer m x r-isolateProducer produce = Producer produce'+isolateProducer p = 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'+ in p sink' -- | Creates a proper 'Transducer' from a function that is, but can't be proven to be, an 'OpenTransducer'. isolateTransducer :: forall m x y. Monad m => (forall d. Functor d => Source m d x -> Sink m d y -> Coroutine d m ()) -> Transducer m x y-isolateTransducer transduce = Transducer transduce'+isolateTransducer t = 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'+ in t source' sink' -- | Creates a proper 'Splitter' from a function that is, but can't be proven to be, an 'OpenSplitter'. isolateSplitter :: forall m x b. Monad m => (forall d. Functor d => Source m d x -> Sink m d x -> Sink m d x -> Sink m d b -> Coroutine d m ()) -> Splitter m x b-isolateSplitter split = Splitter split'+isolateSplitter s = Splitter split' where split' :: forall a1 a2 a3 a4 d. OpenSplitter m a1 a2 a3 a4 d x b () split' source true false edge = let source' :: Source m d x source' = liftSource source@@ -154,7 +153,7 @@ false' = liftSink false edge' :: Sink m d b edge' = liftSink edge- in split source' true' false' edge'+ in s source' true' false' edge' -- | 'Branching' is a type class representing all types that can act as consumers, namely 'Consumer', -- 'Transducer', and 'Splitter'.@@ -174,8 +173,8 @@ combineBranches combinator binder t1 t2 = let transduce' :: forall a1 a2 d. OpenTransducer m a1 a2 d x y () transduce' source sink = combinator binder- (\source-> transduce t1 source sink')- (\source-> transduce t2 source sink')+ (\source'-> transduce t1 source' sink')+ (\source'-> transduce t2 source' sink') source where sink' :: Sink m d y sink' = liftSink sink@@ -185,8 +184,8 @@ combineBranches combinator binder s1 s2 = let split' :: forall a1 a2 a3 a4 d. OpenSplitter m a1 a2 a3 a4 d x b () split' source true false edge = combinator binder- (\source-> split s1 source true' false' edge')- (\source-> split s2 source true' false' edge')+ (\source'-> split s1 source' true' false' edge')+ (\source'-> split s2 source' true' false' edge') source where true' :: Sink m d x true' = liftSink true@@ -215,13 +214,13 @@ -- | Function 'statelessSplitter' takes a function that assigns a Boolean value to each input item and lifts it into -- a 'Splitter'. statelessSplitter :: Monad m => (x -> Bool) -> Splitter m x b-statelessSplitter f = Splitter (\source true false edge-> partitionStream f source true false)+statelessSplitter f = Splitter (\source true false _edge-> partitionStream f source true false) -- | Function 'statefulSplitter' takes a state-converting function that also assigns a Boolean value to each input -- item and lifts it into a 'Splitter'. statefulSplitter :: Monad m => (state -> x -> (state, Bool)) -> state -> Splitter m x () statefulSplitter f s0 = - Splitter (\source true false edge-> + Splitter (\source true false _edge-> foldMStream_ (\ s x -> let (s', truth) = f s x in (if truth then put true x else put false x) >> return s') s0 source)
Control/Concurrent/SCC/XML.hs view
@@ -23,37 +23,26 @@ -- * Parsing XML xmlTokens, parseXMLTokens, expandXMLEntity, XMLToken(..), -- * XML splitters- xmlElement, xmlElementContent, xmlElementName, xmlAttribute, xmlAttributeName, xmlAttributeValue, xmlElementHavingTagWith+ xmlElement, xmlElementContent, xmlElementName, xmlAttribute, xmlAttributeName, xmlAttributeValue, + xmlElementHavingTagWith ) where -import Prelude hiding (mapM)-import Control.Category ((>>>))-import qualified Control.Category as Category-import Control.Exception (assert)-import Control.Monad (join, liftM, when)+import Control.Monad (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 (Seq, (|>))-import Data.Traversable (Traversable, mapM)-import Data.Text (Text, append)+import Data.Maybe (mapMaybe)+import Data.List (find)+import Data.Text (Text) import qualified Data.Text as Text import Numeric (readDec, readHex)-import Debug.Trace (trace) -import Control.Monad.Coroutine-import Control.Monad.Parallel (MonadParallel(..))+import Control.Cofunctor.Ticker (andThen, tickOne, tickWhile)+import Control.Monad.Coroutine (Coroutine, sequentialBinder) import Control.Concurrent.SCC.Streams import Control.Concurrent.SCC.Types import Control.Concurrent.SCC.Coercions (coerce)-import Control.Concurrent.SCC.Combinators (groupMarks, parseEachNestedRegion, splitterToMarker,- findsTrueIn, findsFalseIn, teeConsumers)-import Control.Concurrent.SCC.Primitives (group)-+import Control.Concurrent.SCC.Combinators (parseEachNestedRegion, findsTrueIn) data XMLToken = StartTag | EndTag | EmptyTag | ElementName | AttributeName | AttributeValue@@ -73,9 +62,7 @@ expandXMLEntity "amp" = "&" expandXMLEntity ('#' : 'x' : codePoint) = [chr (fst $ head $ readHex codePoint)] expandXMLEntity ('#' : codePoint) = [chr (fst $ head $ readDec codePoint)]--isNameStart x = isLetter x || x == '_'-isNameChar x = isAlphaNum x || x == '_' || x == '-'+expandXMLEntity e = error ("String \"" ++ e ++ "\" is not a built-in entity name.") -- | This splitter splits XML markup from data content. It is used by 'parseXMLTokens'. xmlTokens :: Monad m => Splitter m Char (Boundary XMLToken)@@ -88,30 +75,31 @@ (put edge (Point errorUnescapedContentLT) >> put false '<') (\x-> tag x >> getContent) contentEnd '&' = entity >> getContent- tag '?' = do put edge (Start ProcessingInstruction)- putList "<?" true- put edge (Start ProcessingInstructionText)- processingInstruction+ contentEnd _ = error "pourUntil returned early!"+ tag '?' = put edge (Start ProcessingInstruction)+ >> putList "<?" true+ >> put edge (Start ProcessingInstructionText)+ >> processingInstruction tag '!' = dispatchOnString source (\other-> put edge (Point (errorBadDeclarationType other))) [("--",- \match-> do put edge (Start Comment)- putList match true- put edge (Start CommentText)- comment),+ const (put edge (Start Comment)+ >> putList "<!--" true+ >> put edge (Start CommentText)+ >> comment)), ("[CDATA[",- \match-> do put edge (Start StartMarkedSectionCDATA)- putList match true- put edge (End StartMarkedSectionCDATA)- markedSection)]+ const (put edge (Start StartMarkedSectionCDATA)+ >> putList "<![CDATA[" true+ >> put edge (End StartMarkedSectionCDATA)+ >> markedSection))] tag '/' = {-# SCC "EndTag" #-} do put edge (Start EndTag)- putList "</" true- name <- getWhile (\x-> isNameChar x || x == ':') source- if null name+ _ <- putList "</" true+ elementName <- getWhile isNameChar source+ if null elementName then put edge (Point errorNamelessEndTag) else put edge (Start ElementName)- >> putList name true+ >> putList elementName true >> put edge (End ElementName) pourUntil (not . isSpace) source true >>= maybe @@ -132,9 +120,9 @@ startTagEnd '/' = get source >> put edge (Point EmptyTag) >> next errorInputEndInStartTag- (\x-> do when (x /= '>' ) (put edge (Point (errorBadStartTag x)))- putList ['/', x] true- return ())+ (\x-> when (x /= '>' ) (put edge (Point (errorBadStartTag x)))+ >> putList ['/', x] true+ >> return ()) startTagEnd '>' = getWith (put true) source startTagEnd x = put edge (Point (errorBadStartTag x)) attributes= pourUntil (not . isSpace) source true@@ -142,7 +130,7 @@ (put edge (Point errorInputEndInStartTag)) (\x-> if isNameStart x then attribute >> attributes else startTagEnd x) attribute= do put edge (Start AttributeName)- pourWhile (\x-> isNameChar x || x == ':') source true+ pourWhile isNameChar source true put edge (End AttributeName) next errorInputEndInStartTag (\y-> do when (y /= '=') (put edge (Point (errorBadAttribute y)))@@ -170,74 +158,78 @@ '&' -> entity >> attributeValue q _ -> return ()) processingInstruction = {-# SCC "PI" #-}- dispatchOnString source- (\other-> if null other- then put edge (Point errorInputEndInProcessingInstruction)- else putList other true >> processingInstruction)- [("?>",- \match-> do put edge (End ProcessingInstructionText)- putList match true- put edge (End ProcessingInstruction)- getContent)]+ pourWhile (/= '?') source true+ >> dispatchOnString source+ (\other-> if null other+ then put edge (Point errorInputEndInProcessingInstruction)+ else putList other true >> processingInstruction)+ [("?>",+ \match-> put edge (End ProcessingInstructionText)+ >> putList match true+ >> put edge (End ProcessingInstruction)+ >> getContent)] comment = {-# SCC "comment" #-}- dispatchOnString source- (\other-> if null other- then put edge (Point errorInputEndInComment)- else putList other true >> comment)- [("-->",- \match-> do put edge (End CommentText)- putList match true- put edge (End Comment)- getContent)]+ pourWhile (/= '-') source true+ >> dispatchOnString source+ (\other-> if null other+ then put edge (Point errorInputEndInComment)+ else putList other true >> comment)+ [("-->",+ \match-> put edge (End CommentText)+ >> putList match true+ >> put edge (End Comment)+ >> getContent)] markedSection = {-# SCC "<![CDATA[" #-}- dispatchOnString source- (\other-> if null other- then put edge (Point errorInputEndInMarkedSection)- else putList other true >> markedSection)- [("]]>",- \match-> do put edge (Start EndMarkedSection)- putList match true- put edge (End EndMarkedSection)- getContent)]+ pourWhile (/= ']') source true+ >> dispatchOnString source+ (\other-> if null other+ then put edge (Point errorInputEndInMarkedSection)+ else putList other true >> markedSection)+ [("]]>",+ \match-> put edge (Start EndMarkedSection)+ >> putList match true+ >> put edge (End EndMarkedSection)+ >> getContent)] entity = put edge (Start EntityReferenceToken) >> put true '&' >> next errorInputEndInEntityReference (\x-> name EntityName x >> next errorInputEndInEntityReference- (\x-> do when (x /= ';') (put edge (Point (errorBadEntityReference x)))- put true x))+ (\y-> do when (y /= ';') (put edge (Point (errorBadEntityReference y)))+ put true y)) >> put edge (End EntityReferenceToken) name token x = {-# SCC "name" #-} put edge (Start token) >> nameTail x >> put edge (End token)- nameTail x = getWhile (\x-> isNameChar x || x == ':') source- >>= \tail-> putList (x:tail) true- next error f = get source- >>= maybe (put edge (Point error)) f+ nameTail x = getWhile isNameChar source+ >>= \rest-> putList (x:rest) true+ next errorToken f = get source+ >>= maybe (put edge (Point errorToken)) f in getContent+ where errorInputEndInComment = ErrorToken "Unterminated comment"+ errorInputEndInMarkedSection = ErrorToken "Unterminated marked section"+ errorInputEndInStartTag = ErrorToken "Missing '>' at the end of start tag."+ errorInputEndInEndTag = ErrorToken "End of input in end tag"+ errorInputEndInAttributeValue = ErrorToken "Truncated input after attribute name"+ errorInputEndInEntityReference = ErrorToken "End of input in entity reference"+ errorInputEndInProcessingInstruction = ErrorToken "Unterminated processing instruction"+ errorBadQuoteCharacter q = ErrorToken ("Invalid quote character " ++ show q)+ errorBadStartTag x = ErrorToken ("Invalid character " ++ show x ++ " in start tag")+ errorBadEndTag x = ErrorToken ("Invalid character " ++ show x ++ " in end tag")+ errorBadAttribute x = ErrorToken ("Invalid character " ++ show x ++ " following attribute name")+ errorBadEntityReference x = ErrorToken ("Invalid character " ++ show x ++ " ends entity name.")+ errorBadDeclarationType other = ErrorToken ("Expecting <![CDATA[ or <!--, received " ++ show ("<![" ++ other))+ errorNamelessEndTag = ErrorToken "Missing element name in end tag"+ errorUnescapedContentLT = ErrorToken "Unescaped character '<' in content"+ errorUnescapedAttributeLT = ErrorToken "Invalid character '<' in attribute value."+ isNameStart x = isLetter x || x == '_'+ isNameChar x = isAlphaNum x || x == '_' || x == '-' || x == ':' -errorInputEndInComment = ErrorToken "Unterminated comment"-errorInputEndInMarkedSection = ErrorToken "Unterminated marked section"-errorInputEndInStartTag = ErrorToken "Missing '>' at the end of start tag."-errorInputEndInEndTag = ErrorToken "End of input in end tag"-errorInputEndInAttributeValue = ErrorToken "Truncated input after attribute name"-errorInputEndInEntityReference = ErrorToken "End of input in entity reference"-errorInputEndInProcessingInstruction = ErrorToken "Unterminated processing instruction"-errorBadQuoteCharacter q = ErrorToken ("Invalid quote character " ++ show q)-errorBadStartTag x = ErrorToken ("Invalid character " ++ show x ++ " in start tag")-errorBadEndTag x = ErrorToken ("Invalid character " ++ show x ++ " in end tag")-errorBadAttribute x = ErrorToken ("Invalid character " ++ show x ++ " following attribute name")-errorBadAttributeValue x = ErrorToken ("Invalid character " ++ show x ++ " in attribute value.")-errorBadEntityReference x = ErrorToken ("Invalid character " ++ show x ++ " ends entity name.")-errorBadDeclarationType other = ErrorToken ("Expecting <![CDATA[ or <!--, received " ++ show ("<![" ++ other))-errorNamelessEndTag = ErrorToken "Missing element name in end tag"-errorUnescapedContentLT = ErrorToken "Unescaped character '<' in content"-errorUnescapedAttributeLT = ErrorToken "Invalid character '<' in attribute value." -- | The XML token parser. This parser converts plain text to parsed text, which is a precondition for using the -- remaining XML components.-parseXMLTokens :: MonadParallel m => Transducer m Char (Markup XMLToken Text)+parseXMLTokens :: Monad m => Transducer m Char (Markup XMLToken Text) parseXMLTokens = parseEachNestedRegion sequentialBinder xmlTokens coerce dispatchOnString :: forall m a d r. (Monad m, AncestorFunctor a d) =>@@ -246,15 +238,15 @@ dispatchOnString source failure fullCases = dispatch fullCases id where dispatch cases consumed = case find (null . fst) cases- of Just ("", rhs) -> rhs (consumed "")+ 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+ 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 XMLToken Text) -> ([Markup XMLToken Text] -> [Markup XMLToken Text])@@ -262,11 +254,12 @@ 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))+ (\x-> let f' = f . (x:)+ in case x+ of Markup (Start ElementName) -> getRestOfRegion ElementName source f' id+ Markup (Point ErrorToken{}) -> getElementName source f'+ Content{} -> getElementName source f'+ _ -> error ("Expected an ElementName, received " ++ show x)) getRestOfRegion :: forall m a d. (Monad m, AncestorFunctor a d) => XMLToken -> Source m a (Markup XMLToken Text)@@ -275,7 +268,7 @@ getRestOfRegion token source f g = getWhile isContent source >>= \content-> get source >>= \x-> case x- of Just y@(Markup (End token))+ of Just y@(Markup End{}) -> return (f (content ++ [y]), Just (g $ Text.concat $ map fromContent content)) _ -> error ("Expected rest of " ++ show token ++ ", received " ++ show x)@@ -294,61 +287,61 @@ _ -> 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 XMLToken Text) -> Sink m a2 (Markup XMLToken Text) -> Coroutine d m Bool-pourRestOfTag source sink = pourUntil isEndTag source sink- >>= maybe - (return True)- (\x-> put sink x- >> get source- >> case x of Markup (End StartTag) -> return True- Markup (End EndTag) -> return True- Markup (Point EmptyTag) -> pourRestOfTag source sink- >> return False)- where isEndTag (Markup (End StartTag)) = True- isEndTag (Markup (End EndTag)) = True- isEndTag (Markup (Point EmptyTag)) = True- isEndTag _ = False+getRestOfStartTag :: forall m a d. (Monad m, AncestorFunctor a d) =>+ Source m a (Markup XMLToken Text) -> Coroutine d m ([Markup XMLToken Text], Bool)+getRestOfStartTag source = do rest <- getWhile notEndTag source+ end <- get source+ case end of Nothing -> return (rest, False)+ Just e@(Markup (End StartTag)) -> return (rest ++ [e], True)+ Just e@(Markup (Point EmptyTag)) -> + getRestOfStartTag source+ >>= \(rest', _)-> return (rest ++ (e: rest'), False)+ _ -> error "getWhile returned early!"+ where notEndTag (Markup (End StartTag)) = False+ notEndTag (Markup (Point EmptyTag)) = False+ notEndTag _ = True +getRestOfEndTag :: forall m a d. (Monad m, AncestorFunctor a d) =>+ Source m a (Markup XMLToken Text) -> Coroutine d m [Markup XMLToken Text]+getRestOfEndTag source = getWhile (/= Markup (End EndTag)) source+ >>= \tokens-> get source+ >>= maybe (error "No end to the end tag!") (return . (tokens ++) . (:[]))+ findEndTag :: forall m a1 a2 a3 d. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d) => Source m a1 (Markup XMLToken Text) -> Sink m a2 (Markup XMLToken Text) -> Sink m a3 (Markup XMLToken Text)- -> Text- -> Coroutine d m ()-findEndTag source sink endSink name = find where- find = pourUntil isTagStart source sink - >>= maybe (return ()) (\x-> get source >> consumeOne x)- isTagStart (Markup (Start StartTag)) = True- isTagStart (Markup (Start EndTag)) = True- isTagStart _ = False+ -> Text+ -> Coroutine d m ()+findEndTag source sink endSink name = findTag where+ findTag = pourWhile noTagStart source sink + >> get source + >>= maybe (return ()) consumeOne+ noTagStart (Markup (Start StartTag)) = False+ noTagStart (Markup (Start EndTag)) = False+ noTagStart _ = True consumeOne x@(Markup (Start EndTag)) = do (tokens, mn) <- getElementName source (x :) maybe (return ())- (\name'-> if name == name'- then do putList tokens endSink- pourRestOfTag source endSink- return ()- else do putList tokens sink- pourRestOfTag source sink- find)+ (\name'-> getRestOfEndTag source+ >>= \rest-> if name == name'+ then putList (tokens ++ rest) endSink+ >> return ()+ else putList (tokens ++ rest) sink+ >> findTag) mn consumeOne x@(Markup (Start StartTag)) = do (tokens, mn) <- getElementName source (x :) maybe (return ())- (\name'-> putList tokens sink- >> if name == name'- then pourRestOfTag source sink- >>= flip when (findEndTag source sink sink name)- >> find- else pourRestOfTag source sink- >> find)+ (\name'-> do (rest, hasContent) <- getRestOfStartTag source+ _ <- putList (tokens ++ rest) sink+ when hasContent (findEndTag source sink sink name')+ findTag) mn+ consumeOne _ = error "pourUntil returned early!" findStartTag :: forall m a1 a2 d. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d) => Source m a1 (Markup XMLToken Text) -> Sink m a2 (Markup XMLToken Text) -> Coroutine d m (Maybe (Markup XMLToken Text))-findStartTag source sink = pourUntil isStartTag source sink >> get source- where isStartTag (Markup (Start StartTag)) = True- isStartTag _ = False+findStartTag source sink = pourWhile (/= Markup (Start StartTag)) source sink >> get source -- | Splits all top-level elements with all their content to /true/, all other input to /false/. xmlElement :: Monad m => Splitter m (Markup XMLToken Text) ()@@ -361,8 +354,8 @@ (tokens, mn) <- getElementName source id maybe (putList tokens true)- (\name-> do putList tokens true- hasContent <- pourRestOfTag source true+ (\name-> do (rest, hasContent) <- getRestOfStartTag source+ _ <- putList (tokens ++ rest) true if hasContent then split1 name else split0)@@ -381,8 +374,8 @@ (tokens, mn) <- getElementName source id maybe (putList tokens false)- (\name-> do putList tokens false- hasContent <- pourRestOfTag source false+ (\name-> do (rest, hasContent) <- getRestOfStartTag source+ _ <- putList (tokens ++ rest) false if hasContent then put edge () >> split1 name else split0)@@ -393,8 +386,8 @@ -- | Similiar to @('Control.Concurrent.SCC.Combinators.having' 'element')@, except it runs the argument splitter -- only on each element's start tag, not on the entire element with its content.-xmlElementHavingTagWith :: forall m b. MonadParallel m =>- Splitter m (Markup XMLToken Text) b -> Splitter m (Markup XMLToken Text) b+xmlElementHavingTagWith :: forall m b. Monad m =>+ Splitter m (Markup XMLToken Text) b -> Splitter m (Markup XMLToken Text) b xmlElementHavingTagWith test = isolateSplitter $ \ source true false edge -> let split0 = findStartTag source false@@ -402,9 +395,7 @@ (\x-> do (tokens, mn) <- getElementName source (x :) maybe (return ())- (\name-> do (hasContent, rest) <- pipe- (pourRestOfTag source)- getList+ (\name-> do (rest, hasContent) <- getRestOfStartTag source let tag = tokens ++ rest (_, found) <- pipe (putList tag) (findsTrueIn test) case found of Just mb -> maybe (return ()) (put edge) mb@@ -453,21 +444,19 @@ xmlAttributeValue :: Monad m => Splitter m (Markup XMLToken Text) () xmlAttributeValue = Splitter (splitSimpleRegions AttributeValue) -splitSimpleRegions token source true false edge = split- where split = getWith consumeOne source+splitSimpleRegions :: Monad m => XMLToken -> OpenSplitter m a1 a2 a3 a4 d (Markup XMLToken Text) () ()+splitSimpleRegions token source true false edge = split0+ where split0 = getWith consumeOne source consumeOne x@(Markup (Start token')) | token == token' = put false x >> put edge () >> pourRestOfRegion token source true false- >>= flip when split- consumeOne x = put false x >> split--justContent (Content x) = Just x-justContent _ = Nothing+ >>= flip when split0+ consumeOne x = put false x >> split0 -isContent (Content x) = True+isContent :: Markup b x -> Bool+isContent Content{} = True isContent _ = False +fromContent :: Markup b x -> x fromContent (Content x) = x--mapJoinM :: (Monad m, Monad t, Traversable t) => (a -> m (t b)) -> t a -> m (t b)-mapJoinM f ta = mapM f ta >>= return . join+fromContent _ = error "fromContent expects Content!"
Makefile view
@@ -1,4 +1,4 @@-Executables=test test-prof test-coroutine test-enumerator test-enumerator-scc test-parallel shsh shsh-prof+Executables=test test-prof test-coroutine test-enumerator test-iteratee test-enumerator-scc test-parallel shsh shsh-prof CoroutineLibraryFiles=Control/Cofunctor/Ticker.hs \ $(addprefix Control/Monad/, \ Parallel.hs Coroutine.hs Coroutine/SuspensionFunctors.hs Coroutine/Nested.hs)@@ -10,7 +10,7 @@ Control/Concurrent/SCC/Combinators.hs \ Control/Concurrent/SCC/Combinators/Parallel.hs Control/Concurrent/SCC/Combinators/Sequential.hs \ Control/Concurrent/SCC/Parallel.hs Control/Concurrent/SCC/Sequential.hs-DocumentationFiles=$(SCCCommonFiles) Control/Monad/Coroutine/Enumerator.hs \+DocumentationFiles=$(SCCCommonFiles) Control/Monad/Coroutine/Enumerator.hs Control/Monad/Coroutine/Iteratee.hs \ Control/Concurrent/SCC/Combinators/Parallel.hs Control/Concurrent/SCC/Combinators/Sequential.hs \ Control/Concurrent/SCC/Parallel.hs Control/Concurrent/SCC/Sequential.hs OptimizingOptions=-O -threaded -hidir obj -odir obj@@ -27,18 +27,21 @@ ghc --make $< -o $@ $(ProfilingOptions) test-coroutine: TestCoroutine.hs $(CoroutineLibraryFiles) | obj- ghc --make $< -o $@ $(OptimizingOptions) -threaded -eventlog+ ghc --make $< -o $@ $(OptimizingOptions) -eventlog test-enumerator: TestEnumerator.hs $(CoroutineLibraryFiles) Control/Monad/Coroutine/Enumerator.hs | obj- ghc --make $< -o $@ $(OptimizingOptions) -threaded -eventlog+ ghc --make $< -o $@ $(OptimizingOptions) -eventlog +test-iteratee: TestIteratee.hs $(CoroutineLibraryFiles) Control/Monad/Coroutine/Iteratee.hs | obj+ ghc --make $< -o $@ $(OptimizingOptions) -eventlog+ test-enumerator-scc: TestEnumeratorSCC.hs $(SCCCommonFiles) \ Control/Monad/Coroutine/Enumerator.hs \ Control/Concurrent/SCC/Combinators/Sequential.hs Control/Concurrent/SCC/Sequential.hs | obj- ghc --make $< -o $@ $(OptimizingOptions) -threaded -eventlog+ ghc --make $< -o $@ $(OptimizingOptions) -eventlog test-parallel: TestParallel.hs Control/Monad/Parallel.hs | obj- ghc --make $< -o $@ $(OptimizingOptions) -threaded -eventlog+ ghc --make $< -o $@ $(OptimizingOptions) -eventlog shsh: Shell.hs $(AllLibraryFiles) | obj ghc --make $< -o $@ $(OptimizingOptions)@@ -50,6 +53,7 @@ haddock -hU -o doc \ -i http://www.haskell.org/ghc/docs/latest/html/libraries/base,base.haddock \ -i $(lastword $(wildcard ~/.cabal/share/doc/enumerator-*/html/)),$(lastword $(wildcard ~/.cabal/share/doc/enumerator-*/html/enumerator.haddock)) \+ -i $(lastword $(wildcard ~/.cabal/share/doc/iteratee-*/html/)),$(lastword $(wildcard ~/.cabal/share/doc/iteratee-*/html/iteratee.haddock)) \ -i $(lastword $(wildcard ~/.cabal/share/doc/transformers-*/html/)),$(lastword $(wildcard ~/.cabal/share/doc/transformers-*/html/transformers.haddock)) \ -i $(lastword $(wildcard ~/.cabal/share/doc/text-*/html/)),$(lastword $(wildcard ~/.cabal/share/doc/text-*/html/text.haddock)) \ $^
Shell.hs view
@@ -201,7 +201,6 @@ -- Data type tags AnyTag :: TypeTag () UnitTag :: TypeTag ()- ShowableTag :: Show x => TypeTag x CharTag :: TypeTag Char TextTag :: TypeTag Text IntTag :: TypeTag Integer@@ -217,7 +216,7 @@ CommandTag :: TypeTag (Performer IO ()) 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)+ SplitterTag :: 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 @@ -241,69 +240,14 @@ show (TransducerTag x y) = "Transducer " ++ shows x (" -> " ++ show y) show GenericInputTag{} = "Generic" --- Weirich's higher-order type-safe cast--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))- instance Functor c => Functor (CComponent c) where fmap f (CComponent c) = CComponent (fmap (fmap f) c) -data CList c a = CList (c [a])-data CMaybe c a = CMaybe (c (Maybe a))-data CFlip c b a = CFlip (c a b)-data CEL c a d = CEL (c (Either d a))-data CER c a d = CER (c (Either a d))-data CML c a d = CML (c (Markup d a))-data CMR c a d = CMR (c (Markup a d))-data CL c a d = CL (c (d,a))-data CR c a d = CR (c (a,d))-data CTL c a d = CTL (c (Transducer IO d a))-data CTR c a d = CTR (c (Transducer IO a d))-data CSL c a d = CSL (c (Splitter IO d a))-data CSR c a d = CSR (c (Splitter IO a d))- typecast :: forall a b c. TypeTag a -> TypeTag b -> c a -> Maybe (c b)-typecast UnitTag UnitTag x = Just x-typecast CharTag CharTag x = Just x-typecast TextTag TextTag x = Just x-typecast IntTag IntTag x = Just x-typecast XMLTokenTag XMLTokenTag x = Just x-typecast (ListTag a) (ListTag b) x = fmap (\(CList y)-> y) (typecast a b (CList x))-typecast (MaybeTag a) (MaybeTag b) x = fmap (\(CMaybe y)-> y) (typecast a b (CMaybe x))-typecast (EitherTag (ra::TypeTag a0) (rb::TypeTag b0)) (EitherTag (ra'::TypeTag a0') (rb'::TypeTag b0')) x =- let g = (typecast ra ra' :: (CEL c b0) a0 -> Maybe ((CEL c b0) a0'))- h = (typecast rb rb' :: (CER c a0') b0 -> Maybe ((CER c a0') b0'))- in case g (CEL x) of Just (CEL x') -> case h (CER x') of Just (CER y') -> Just y'- Nothing -> Nothing-typecast (MarkupTag (ra::TypeTag a0) (rb::TypeTag b0)) (MarkupTag (ra'::TypeTag a0') (rb'::TypeTag b0')) x =- let g = (typecast ra ra' :: (CML c b0) a0 -> Maybe ((CML c b0) a0'))- h = (typecast rb rb' :: (CMR c a0') b0 -> Maybe ((CMR c a0') b0'))- in case g (CML x) of Just (CML x') -> case h (CMR x') of Just (CMR y') -> Just y'- Nothing -> Nothing-typecast (PairTag (ra::TypeTag a0) (rb::TypeTag b0)) (PairTag (ra'::TypeTag a0') (rb'::TypeTag b0')) x =- let g = (typecast ra ra' :: (CL c b0) a0 -> Maybe ((CL c b0) a0'))- 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))-typecast (TransducerTag (ra::TypeTag a0) (rb::TypeTag b0)) (TransducerTag (ra'::TypeTag a0') (rb'::TypeTag b0')) x- = let g = (typecast ra ra' :: (CTL c b0) a0 -> Maybe ((CTL c b0) a0'))- h = (typecast rb rb' :: (CTR c a0') b0 -> Maybe ((CTR c a0') b0'))- in case g (CTL x) of Nothing -> Nothing- Just (CTL x') -> case h (CTR x') of Nothing -> Nothing- Just (CTR y') -> Just y'-typecast (SplitterTag (ra::TypeTag a0) (rb::TypeTag b0)) (SplitterTag (ra'::TypeTag a0') (rb'::TypeTag b0')) x- = let g = (typecast ra ra' :: (CSL c b0) a0 -> Maybe ((CSL c b0) a0'))- h = (typecast rb rb' :: (CSR c a0') b0 -> Maybe ((CSR c a0') b0'))- in case g (CSL x) of Just (CSL x') -> case h (CSR x') of Just (CSR y') -> Just y'- Nothing -> Nothing-typecast _ _ _ = Nothing+typecast tag1 tag2 x = case relateTags tag1 tag2 + of IdentityRelation{} -> Just x+ _ -> Nothing trycast :: forall a b. TypeTag a -> TypeTag b -> a -> Expression -> (b -> Expression) -> Expression trycast tag1 tag2 x e constructor = case typecast tag1 tag2 (Just x)@@ -311,29 +255,33 @@ Nothing -> TypeError tag1 tag2 e typecoerce :: forall a b c. Functor c => TypeTag a -> TypeTag b -> c a -> Maybe (c b)-typecoerce (ComponentTag (ProducerTag TextTag)) (ComponentTag (ProducerTag CharTag)) x = Just (fmap (>-> coerce) x)-typecoerce (ComponentTag (ProducerTag CharTag)) (ComponentTag (ProducerTag TextTag)) x = Just (fmap (>-> coerce) x)-typecoerce (ComponentTag (ConsumerTag TextTag)) (ComponentTag (ConsumerTag CharTag)) x = Just (fmap (coerce >->) x)-typecoerce (ComponentTag (ConsumerTag CharTag)) (ComponentTag (ConsumerTag TextTag)) x = Just (fmap (coerce >->) x)-typecoerce (ComponentTag (TransducerTag TextTag t1)) t2@(ComponentTag (TransducerTag CharTag _)) x =- typecast (ComponentTag (TransducerTag CharTag t1)) t2 (fmap (coerce >->) x)-typecoerce (ComponentTag (TransducerTag CharTag t1)) t2@(ComponentTag (TransducerTag TextTag _)) x =- typecast (ComponentTag (TransducerTag TextTag t1)) t2 (fmap (coerce >->) x)-typecoerce (ComponentTag (TransducerTag t1 TextTag)) t2@(ComponentTag (TransducerTag _ CharTag)) x =- typecast (ComponentTag (TransducerTag t1 CharTag)) t2 (fmap (>-> coerce) x)-typecoerce (ComponentTag (TransducerTag t1 CharTag)) t2@(ComponentTag (TransducerTag _ TextTag)) x =- typecast (ComponentTag (TransducerTag t1 TextTag)) t2 (fmap (>-> coerce) x)-typecoerce (ComponentTag (SplitterTag TextTag b1)) t2@(ComponentTag (SplitterTag CharTag _)) x = - typecast (ComponentTag (SplitterTag CharTag b1)) t2 (fmap adaptSplitter x)-typecoerce (ComponentTag (SplitterTag CharTag b1)) t2@(ComponentTag (SplitterTag TextTag _)) x = - typecast (ComponentTag (SplitterTag TextTag b1)) t2 (fmap adaptSplitter x)-+typecoerce (ComponentTag (ProducerTag tag1)) (ComponentTag (ProducerTag tag2)) x = + case relateTags tag1 tag2+ of IdentityRelation{} -> Just x+ CoercibleRelation{} -> Just (fmap (>-> coerce) x)+ NoRelation -> Nothing+typecoerce (ComponentTag (ConsumerTag tag1)) (ComponentTag (ConsumerTag tag2)) x = + case relateTags tag2 tag1+ of IdentityRelation{} -> Just x+ CoercibleRelation{} -> Just (fmap (coerce >->) x)+ NoRelation -> Nothing+typecoerce (ComponentTag (TransducerTag tag1a tag1b)) (ComponentTag (TransducerTag tag2a tag2b)) x =+ case (relateTags tag2a tag1a, relateTags tag1b tag2b)+ of (IdentityRelation{}, IdentityRelation{}) -> Just x+ (CoercibleRelation{}, IdentityRelation{}) -> Just (fmap (coerce >->) x) + (IdentityRelation{}, CoercibleRelation{}) -> Just (fmap (>-> coerce) x)+ _ -> Nothing+typecoerce (ComponentTag (SplitterTag tag1 b1)) (ComponentTag (SplitterTag tag2 b2)) x = + case (relateTags tag1 tag2, relateTags tag2 tag1, relateTags b1 b2)+ of (IdentityRelation{}, IdentityRelation{}, IdentityRelation{}) -> Just x+ (CoercibleRelation{}, CoercibleRelation{}, IdentityRelation{}) -> Just (fmap adaptSplitter x)+ _ -> Nothing typecoerce (ComponentTag a) (ComponentTag b) x = fmap (\(CComponent y)-> y) (typecoerce a b (CComponent x))--typecoerce (ProducerTag TextTag) (ProducerTag CharTag) x = - Just (fmap (\x-> compose sequentialBinder x Coercions.coerce) x)-typecoerce (ProducerTag CharTag) (ProducerTag TextTag) x = - Just (fmap (\x-> compose sequentialBinder x Coercions.coerce) x)+typecoerce (ProducerTag tag1) (ProducerTag tag2) x = + case relateTags tag1 tag2+ of IdentityRelation{} -> Just x+ CoercibleRelation{} -> Just (fmap (\x-> compose sequentialBinder x Coercions.coerce) x)+ NoRelation -> Nothing typecoerce tag1 tag2 x = typecast tag1 tag2 x trycoerce :: forall a b. TypeTag a -> TypeTag b -> a -> Expression -> (b -> Expression) -> Expression@@ -345,22 +293,97 @@ -> Expression tryComponentCast tag1 tag2 = trycoerce (ComponentTag tag1) (ComponentTag tag2) -data RelationTag = CoercibleRelationTag+data TypeTagRelation x y where+ CoercibleRelation :: Coercions.Coercible x y => TypeTag x -> TypeTag y -> TypeTagRelation x y+ IdentityRelation :: TypeTag x -> TypeTagRelation x x+ NoRelation :: TypeTagRelation x y -data TypeTagRelation c1 c2 where- CoercibleRelation :: Coercions.Coercible x y => TypeTag x -> TypeTag y -> c1 x -> c2 y -> TypeTagRelation c1 c2- NoRelation :: TypeTagRelation c1 c2+data TypeTagClass x where+ ShowClass :: Show x => TypeTag x -> TypeTagClass x+ EqClass :: Eq x => TypeTag x -> TypeTagClass x+ NoClass :: TypeTagClass x -typecastRelatedPair :: forall a b c1 c2. TypeTag a -> TypeTag b -> RelationTag -> c1 a -> c2 b -> TypeTagRelation c1 c2-typecastRelatedPair tag1 tag2 CoercibleRelationTag x y - | Just y' <- typecast tag2 tag1 y = CoercibleRelation tag1 tag1 x y'-typecastRelatedPair TextTag CharTag CoercibleRelationTag x y = CoercibleRelation TextTag CharTag x y-typecastRelatedPair (MarkupTag tag1b tag1) tag2 CoercibleRelationTag x y = - case typecastRelatedPair tag1 tag2 CoercibleRelationTag (CMR x) y- of CoercibleRelation tag1' tag2' (CMR x') y' -> CoercibleRelation (MarkupTag tag1b tag1') tag2' x' y'+relateTags :: forall a b. TypeTag a -> TypeTag b -> TypeTagRelation a b++relateTags CharTag CharTag = IdentityRelation CharTag+relateTags TextTag TextTag = IdentityRelation TextTag+relateTags IntTag IntTag = IdentityRelation IntTag+relateTags UnitTag UnitTag = IdentityRelation UnitTag+relateTags XMLTokenTag XMLTokenTag = IdentityRelation XMLTokenTag+relateTags (ListTag tag1) (ListTag tag2) = + case relateTags tag1 tag2+ of IdentityRelation tag' -> IdentityRelation (ListTag tag')+ CoercibleRelation tag1' tag2' -> NoRelation -- CoercibleRelation (ListTag tag1') (ListTag tag2') NoRelation -> NoRelation-typecastRelatedPair _ _ _ _ _ = NoRelation+relateTags (MaybeTag tag1) (MaybeTag tag2) = + case relateTags tag1 tag2 + of IdentityRelation tag' -> IdentityRelation (MaybeTag tag')+ CoercibleRelation tag1' tag2' -> NoRelation -- CoercibleRelation (MaybeTag tag1') (MaybeTag tag2')+ NoRelation -> NoRelation+relateTags (EitherTag tag1a tag1b) (EitherTag tag2a tag2b)+ | IdentityRelation tag'a <- relateTags tag1a tag2a,+ IdentityRelation tag'b <- relateTags tag1b tag2b = IdentityRelation (EitherTag tag'a tag'b)+relateTags (MarkupTag tag1b tag1) (MarkupTag tag2b tag2)+ | IdentityRelation tag'b <- relateTags tag1b tag2b,+ IdentityRelation tag' <- relateTags tag1 tag2 = IdentityRelation (MarkupTag tag'b tag')+relateTags (PairTag tag1a tag1b) (PairTag tag2a tag2b)+ | IdentityRelation tag'a <- relateTags tag1a tag2a,+ IdentityRelation tag'b <- relateTags tag1b tag2b = IdentityRelation (PairTag tag'a tag'b)+relateTags CommandTag CommandTag = IdentityRelation CommandTag+relateTags (ConsumerTag tag1) (ConsumerTag tag2)+ | IdentityRelation tag' <- relateTags tag1 tag2 = IdentityRelation (ConsumerTag tag')+relateTags (ProducerTag tag1) (ProducerTag tag2)+ | IdentityRelation tag' <- relateTags tag1 tag2 = IdentityRelation (ProducerTag tag')+relateTags (TransducerTag tag1a tag1b) (TransducerTag tag2a tag2b)+ | IdentityRelation tag'a <- relateTags tag1a tag2a,+ IdentityRelation tag'b <- relateTags tag1b tag2b = IdentityRelation (TransducerTag tag'a tag'b)+relateTags (SplitterTag tag1 tag1b) (SplitterTag tag2 tag2b) + | IdentityRelation tag'b <- relateTags tag1b tag2b,+ IdentityRelation tag' <- relateTags tag1 tag2 = IdentityRelation (SplitterTag tag' tag'b)+relateTags (ComponentTag tag1) (ComponentTag tag2)+ | IdentityRelation tag' <- relateTags tag1 tag2 = IdentityRelation (ComponentTag tag') +relateTags CharTag TextTag = CoercibleRelation CharTag TextTag+relateTags TextTag CharTag = CoercibleRelation TextTag CharTag+relateTags (MarkupTag tag1b tag1) tag2 = + case relateTags tag1 tag2+ of IdentityRelation tag' -> CoercibleRelation (MarkupTag tag1b tag') tag'+ CoercibleRelation tag1' tag2' -> CoercibleRelation (MarkupTag tag1b tag1') tag2'+ NoRelation -> NoRelation+relateTags _ _ = NoRelation++constrainEq :: TypeTag x -> TypeTagClass x+constrainEq CharTag = EqClass CharTag+constrainEq TextTag = EqClass TextTag+constrainEq IntTag = EqClass IntTag+constrainEq UnitTag = EqClass UnitTag+constrainEq XMLTokenTag = EqClass XMLTokenTag+constrainEq (ListTag tag) | EqClass tag' <- constrainEq tag = EqClass (ListTag tag')+constrainEq (MaybeTag tag) | EqClass tag' <- constrainEq tag = EqClass (MaybeTag tag')+constrainEq (PairTag tag1 tag2)+ | EqClass tag1' <- constrainEq tag1, EqClass tag2' <- constrainEq tag2 = EqClass (PairTag tag1' tag2')+constrainEq (EitherTag tag1 tag2)+ | EqClass tag1' <- constrainEq tag1, EqClass tag2' <- constrainEq tag2 = EqClass (EitherTag tag1' tag2')+constrainEq (MarkupTag tag1 tag2)+ | EqClass tag1' <- constrainEq tag1, EqClass tag2' <- constrainEq tag2 = EqClass (MarkupTag tag1' tag2')+constrainEq _ = NoClass++constrainShow :: TypeTag x -> TypeTagClass x+constrainShow CharTag = ShowClass CharTag+constrainShow TextTag = ShowClass TextTag+constrainShow IntTag = ShowClass IntTag+constrainShow UnitTag = ShowClass UnitTag+constrainShow XMLTokenTag = ShowClass XMLTokenTag+constrainShow (ListTag tag) | ShowClass tag' <- constrainShow tag = ShowClass (ListTag tag')+constrainShow (MaybeTag tag) | ShowClass tag' <- constrainShow tag = ShowClass (MaybeTag tag')+constrainShow (PairTag tag1 tag2)+ | ShowClass tag1' <- constrainShow tag1, ShowClass tag2' <- constrainShow tag2 = ShowClass (PairTag tag1' tag2')+constrainShow (EitherTag tag1 tag2)+ | ShowClass tag1' <- constrainShow tag1, ShowClass tag2' <- constrainShow tag2 = ShowClass (EitherTag tag1' tag2')+constrainShow (MarkupTag tag1 tag2)+ | ShowClass tag1' <- constrainShow tag1, ShowClass tag2' <- constrainShow tag2 = ShowClass (MarkupTag tag1' tag2')+constrainShow _ = NoClass+ data Flag = Command | Help | Interactive | PrettyPrint | ScriptFile String | StandardInput | Threads String deriving Eq @@ -450,8 +473,8 @@ adjust _ component = component compile :: TypeTag x -> Expression -> Expression-compile inputTag e@Compiled{} = e-compile inputTag e@TypeError{} = e+compile _ e@Compiled{} = e+compile _ e@TypeError{} = e compile inputTag (Pipe left right) = case compile inputTag left of Compiled tag@(ProducerTag tag1) p@@ -472,6 +495,18 @@ Compiled tag _ -> TypeError tag (TransducerTag tag2 AnyTag) right Compiled tag _ -> TypeError tag (ProducerTag AnyTag) left e@TypeError{} -> e+compile _ (FileProducer path) = Compiled (ProducerTag CharTag) (fromFile path)+compile _ StdInProducer = Compiled (ProducerTag CharTag) fromStdIn+compile _ (FromList string) = Compiled (ProducerTag CharTag) (atomic "putList" 1 $ Producer $+ \sink-> putList string sink >> return ())+compile _ (FileConsumer path) = Compiled (ConsumerTag CharTag) (toFile path)+compile _ (FileAppend path) = Compiled (ConsumerTag CharTag) (appendFile path)+compile inputTag Suppress = Compiled (ConsumerTag inputTag) suppress+compile inputTag (ErrorConsumer message) = Compiled (ConsumerTag inputTag) (erroneous message)+compile inputTag (Sequence e1 e2) = compileJoin sequence inputTag e1 e2+compile inputTag (Join e1 e2) = compileJoin join inputTag e1 e2+compile inputTag (ForEach splitter true false) = combineSplitterAndBranches foreach inputTag splitter true false+compile inputTag (If splitter true false) = combineSplitterAndBranches ifs inputTag splitter true false compile UnitTag (NativeCommand command) = Compiled (ProducerTag CharTag) $ atomic command ioCost $ Producer $@@ -479,20 +514,7 @@ <- lift (Process.createProcess (Process.shell command){Process.std_out= Process.CreatePipe}) produce (with $ fromHandle stdout) sink lift (hClose stdout)-compile UnitTag (FileProducer path) = Compiled (ProducerTag CharTag) (fromFile path)-compile UnitTag StdInProducer = Compiled (ProducerTag CharTag) fromStdIn-compile inputTag (FromList string) = Compiled (ProducerTag CharTag) (atomic "putList" 1 $ Producer $- \sink-> putList string sink >> return ())-compile inputTag (FileConsumer path) = Compiled (ConsumerTag CharTag) (toFile path)-compile inputTag (FileAppend path) = Compiled (ConsumerTag CharTag) (appendFile path)-compile inputTag Suppress = Compiled (ConsumerTag inputTag) suppress-compile inputTag (ErrorConsumer message) = Compiled (ConsumerTag inputTag) (erroneous message)-compile inputTag (Sequence e1 e2) = compileJoin sequence inputTag e1 e2-compile inputTag (Join e1 e2) = compileJoin join inputTag e1 e2-compile inputTag (ForEach splitter true false) = combineSplitterAndBranches foreach inputTag splitter true false-compile inputTag (If splitter true false) = combineSplitterAndBranches ifs inputTag splitter true false-compile inputTag (NativeCommand command) = Compiled (TransducerTag CharTag CharTag)- (atomic command ioCost $ Transducer f)+compile _ (NativeCommand command) = Compiled (TransducerTag CharTag CharTag) (atomic command ioCost $ Transducer f) where f :: forall a1 a2 d. OpenTransducer IO a1 a2 d Char Char () f source sink = do (Just stdin, Just stdout, Nothing, pid) <- lift (Process.createProcess@@ -550,7 +572,7 @@ compile inputTag (Prepend prefix) = wrapProducerIntoTransducer prepend inputTag prefix compile inputTag (Append suffix) = wrapProducerIntoTransducer append inputTag suffix compile inputTag (Substitute replacement) = wrapGenericProducerIntoTransducer substitute inputTag replacement-compile inputTag ExecuteTransducer+compile _ ExecuteTransducer = Compiled (TransducerTag CharTag CharTag) (atomic "execute" ioCost $ Transducer execute) where execute :: forall a1 a2 d. OpenTransducer IO a1 a2 d Char Char () execute source sink = do let (source' :: Source IO d Char) = liftSource source@@ -569,36 +591,30 @@ 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 XMLTokenTag CharTag) ShowTransducer- = Compiled (TransducerTag inputTag (ListTag CharTag)) toString+compile _ Uppercase = Compiled (TransducerTag CharTag CharTag) uppercase+compile inputTag ShowTransducer + | ShowClass{} <- constrainShow inputTag = Compiled (TransducerTag inputTag (ListTag CharTag)) toString compile inputTag ShowTransducer = TypeError (TransducerTag IntTag (ListTag CharTag)) (TransducerTag inputTag AnyTag) ShowTransducer-{--compile inputTag ShowTransducer = let targetType = TransducerTag ShowableTag (ListTag CharTag)- actualType = TransducerTag inputTag (ListTag CharTag)- in trycast targetType actualType toString ShowTransducer (Compiled actualType)--} compile inputTag EverythingSplitter = Compiled (SplitterTag inputTag UnitTag) everything compile inputTag NothingSplitter = Compiled (SplitterTag inputTag UnitTag) nothing-compile inputTag WhitespaceSplitter = Compiled (SplitterTag CharTag UnitTag) whitespace-compile inputTag LineSplitter = Compiled (SplitterTag CharTag UnitTag) line-compile inputTag LetterSplitter = Compiled (SplitterTag CharTag UnitTag) letters-compile inputTag DigitSplitter = Compiled (SplitterTag CharTag UnitTag) digits-compile inputTag MarkedSplitter = Compiled (SplitterTag (MarkupTag AnyTag AnyTag) UnitTag) marked+compile _ WhitespaceSplitter = Compiled (SplitterTag CharTag UnitTag) whitespace+compile _ LineSplitter = Compiled (SplitterTag CharTag UnitTag) line+compile _ LetterSplitter = Compiled (SplitterTag CharTag UnitTag) letters+compile _ DigitSplitter = Compiled (SplitterTag CharTag UnitTag) digits+compile inputTag@(MarkupTag tag _) MarkedSplitter + | EqClass{} <- constrainEq tag = Compiled (SplitterTag inputTag UnitTag) marked+compile _ MarkedSplitter = Compiled (SplitterTag (MarkupTag AnyTag AnyTag) UnitTag) marked compile inputTag OneSplitter = Compiled (SplitterTag inputTag UnitTag) one-compile inputTag (SubstringSplitter part) = Compiled (SplitterTag CharTag UnitTag) (substring part)-compile CharTag XMLTokenParser = Compiled (TransducerTag CharTag (MarkupTag XMLTokenTag TextTag)) xmlParseTokens-compile t@(MarkupTag XMLTokenTag TextTag) XMLElement = Compiled (SplitterTag t UnitTag) xmlElement-compile t@(MarkupTag XMLTokenTag TextTag) XMLAttribute = Compiled (SplitterTag t UnitTag) xmlAttribute-compile t@(MarkupTag XMLTokenTag TextTag) XMLAttributeName = Compiled (SplitterTag t UnitTag) xmlAttributeName-compile t@(MarkupTag XMLTokenTag TextTag) XMLAttributeValue = Compiled (SplitterTag t UnitTag) xmlAttributeValue-compile t@(MarkupTag XMLTokenTag TextTag) XMLElementContent = Compiled (SplitterTag t UnitTag) xmlElementContent-compile t@(MarkupTag XMLTokenTag TextTag) XMLElementName = Compiled (SplitterTag t UnitTag) xmlElementName-compile t@(MarkupTag XMLTokenTag TextTag) (XMLElementHavingTag s) = wrapConcreteSplitter xmlElementHavingTagWith t s+compile _ (SubstringSplitter part) = Compiled (SplitterTag CharTag UnitTag) (substring part)+compile _ XMLTokenParser = Compiled (TransducerTag CharTag (MarkupTag XMLTokenTag TextTag)) xmlParseTokens+compile _ XMLElement = Compiled (SplitterTag (MarkupTag XMLTokenTag TextTag) UnitTag) xmlElement+compile _ XMLAttribute = Compiled (SplitterTag (MarkupTag XMLTokenTag TextTag) UnitTag) xmlAttribute+compile _ XMLAttributeName = Compiled (SplitterTag (MarkupTag XMLTokenTag TextTag) UnitTag) xmlAttributeName+compile _ XMLAttributeValue = Compiled (SplitterTag (MarkupTag XMLTokenTag TextTag) UnitTag) xmlAttributeValue+compile _ XMLElementContent = Compiled (SplitterTag (MarkupTag XMLTokenTag TextTag) UnitTag) xmlElementContent+compile _ XMLElementName = Compiled (SplitterTag (MarkupTag XMLTokenTag TextTag) UnitTag) xmlElementName+compile _ (XMLElementHavingTag s) = wrapConcreteSplitter xmlElementHavingTagWith (MarkupTag XMLTokenTag TextTag) s compile inputTag expression = error ("Cannot compile " ++ show expression ++ " with input " ++ show inputTag) @@ -734,9 +750,9 @@ combineSplittersOfCoercibleTypes combinator inputTag left right = case (compile inputTag left, compile inputTag right) of (Compiled ts1@(SplitterTag tag1 tag1b) s1, Compiled ts2@(SplitterTag tag2 _) s2)- -> case typecastRelatedPair tag1 tag2 CoercibleRelationTag (CSL s1) (CSL s2)- of CoercibleRelation tag1' tag2' (CSL s1') (CSL s2') - -> Compiled (SplitterTag tag1' tag1b) (combinator s1' s2')+ -> case relateTags tag1 tag2+ of IdentityRelation tag'-> Compiled (SplitterTag tag' tag1b) (combinator s1 s2)+ CoercibleRelation tag1' tag2'-> Compiled (SplitterTag tag1' tag1b) (combinator s1 s2) NoRelation -> TypeError ts2 ts1 right (e@TypeError{}, _) -> e (_, e@TypeError{}) -> e
scc.cabal view
@@ -1,5 +1,5 @@ Name: scc-Version: 0.6+Version: 0.6.1 Cabal-Version: >= 1.2 Build-Type: Simple Synopsis: Streaming component combinators@@ -29,8 +29,7 @@ Executable shsh Main-is: Shell.hs Other-Modules: Control.Concurrent.SCC.Streams, Control.Concurrent.SCC.Types, Control.Concurrent.SCC.Coercions,- Control.Concurrent.SCC.Combinators, Control.Concurrent.SCC.Primitives,- Control.Concurrent.SCC.XML,+ Control.Concurrent.SCC.Combinators, Control.Concurrent.SCC.Primitives, Control.Concurrent.SCC.XML, Control.Concurrent.Configuration, Control.Concurrent.SCC.Configurable Build-Depends: base < 5, containers, transformers >= 0.2 && < 0.3, monad-parallel, monad-coroutine >= 0.6 && < 0.7, bytestring < 1.0, text < 1.0,@@ -38,11 +37,12 @@ GHC-options: -threaded Library- Exposed-Modules: Control.Concurrent.SCC.Streams, Control.Concurrent.SCC.Types, Control.Concurrent.SCC.Coercions,- Control.Concurrent.SCC.Combinators.Parallel, Control.Concurrent.SCC.Combinators.Sequential,- Control.Concurrent.SCC.Primitives, Control.Concurrent.SCC.XML,- Control.Concurrent.Configuration, Control.Concurrent.SCC.Configurable,+ Exposed-Modules: Control.Concurrent.Configuration, Control.Concurrent.SCC.Configurable, Control.Concurrent.SCC.Parallel, Control.Concurrent.SCC.Sequential+ Other-Modules: Control.Concurrent.SCC.Streams, Control.Concurrent.SCC.Types, Control.Concurrent.SCC.Coercions,+ Control.Concurrent.SCC.Combinators.Parallel, Control.Concurrent.SCC.Combinators.Sequential,+ Control.Concurrent.SCC.Combinators, Control.Concurrent.SCC.Primitives, Control.Concurrent.SCC.XML+ Build-Depends: base < 5, containers, transformers >= 0.2 && < 0.3, monad-parallel, monad-coroutine >= 0.6 && < 0.7, bytestring < 1.0, text < 1.0 GHC-prof-options: -auto-all