diff --git a/Control/Concurrent/Configuration.hs b/Control/Concurrent/Configuration.hs --- a/Control/Concurrent/Configuration.hs +++ b/Control/Concurrent/Configuration.hs @@ -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 diff --git a/Control/Concurrent/SCC/Coercions.hs b/Control/Concurrent/SCC/Coercions.hs --- a/Control/Concurrent/SCC/Coercions.hs +++ b/Control/Concurrent/SCC/Coercions.hs @@ -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 diff --git a/Control/Concurrent/SCC/Combinators.hs b/Control/Concurrent/SCC/Combinators.hs --- a/Control/Concurrent/SCC/Combinators.hs +++ b/Control/Concurrent/SCC/Combinators.hs @@ -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 diff --git a/Control/Concurrent/SCC/Configurable.hs b/Control/Concurrent/SCC/Configurable.hs --- a/Control/Concurrent/SCC/Configurable.hs +++ b/Control/Concurrent/SCC/Configurable.hs @@ -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 () diff --git a/Control/Concurrent/SCC/Primitives.hs b/Control/Concurrent/SCC/Primitives.hs --- a/Control/Concurrent/SCC/Primitives.hs +++ b/Control/Concurrent/SCC/Primitives.hs @@ -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 diff --git a/Control/Concurrent/SCC/Streams.hs b/Control/Concurrent/SCC/Streams.hs --- a/Control/Concurrent/SCC/Streams.hs +++ b/Control/Concurrent/SCC/Streams.hs @@ -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 diff --git a/Control/Concurrent/SCC/Types.hs b/Control/Concurrent/SCC/Types.hs --- a/Control/Concurrent/SCC/Types.hs +++ b/Control/Concurrent/SCC/Types.hs @@ -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) diff --git a/Control/Concurrent/SCC/XML.hs b/Control/Concurrent/SCC/XML.hs --- a/Control/Concurrent/SCC/XML.hs +++ b/Control/Concurrent/SCC/XML.hs @@ -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 "> putList "> 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 "", - \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 " 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 ' 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 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!" diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -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)) \ $^ diff --git a/Shell.hs b/Shell.hs --- a/Shell.hs +++ b/Shell.hs @@ -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 diff --git a/scc.cabal b/scc.cabal --- a/scc.cabal +++ b/scc.cabal @@ -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