scc 0.1 → 0.2
raw patch · 9 files changed
+2676/−1788 lines, 9 filesdep +mtldep +paralleldep ~parsec
Dependencies added: mtl, parallel
Dependency ranges changed: parsec
Files
- Control/Concurrent/SCC/Combinators.hs +1074/−646
- Control/Concurrent/SCC/ComponentTypes.hs +367/−52
- Control/Concurrent/SCC/Components.hs +115/−119
- Control/Concurrent/SCC/Foundation.hs +186/−120
- Makefile +15/−11
- Shell.hs +765/−712
- Test.hs +110/−68
- grammar.bnf +39/−56
- scc.cabal +5/−4
Control/Concurrent/SCC/Combinators.hs view
@@ -14,652 +14,1080 @@ <http://www.gnu.org/licenses/>. -} --- | The "Combinators" module defines combinators applicable to 'Transducer' and 'Splitter' components defined in the--- "ComponentTypes" module.--{-# LANGUAGE ScopedTypeVariables, Rank2Types #-}--module Control.Concurrent.SCC.Combinators- (-- * Consumer and producer combinators- (->>), (<<-),- -- * Transducer combinators- (>->), join,- -- * Pseudo-logic splitter combinators- -- | Combinators '>&' and '>|' are only /pseudo/-logic. While the laws of double negation and De Morgan's laws hold,- -- '>&' and '>|' are in general not commutative, associative, nor idempotent. In the special case when all argument- -- splitters are stateless, such as those produced by 'Components.liftStatelessSplitter', these combinators do satisfy- -- all laws of Boolean algebra.- snot, (>&), (>|),- -- ** Zipping logic combinators- -- | The '&&' and '||' combinators run the argument splitters in parallel and combine their logical outputs using- -- the corresponding logical operation on each output pair, in a manner similar to 'Prelude.zipWith'.- (&&), (||),- -- * Flow-control combinators- -- | The following combinators resemble the common flow-control programming language constructs. Combinators - -- 'wherever', 'unless', and 'select' are just the special cases of the combinator 'ifs'.- --- -- * /transducer/ ``wherever`` /splitter/ = 'ifs' /splitter/ /transducer/ 'Components.asis'- --- -- * /transducer/ ``unless`` /splitter/ = 'ifs' /splitter/ 'Components.asis' /transducer/- --- -- * 'select' /splitter/ = 'ifs' /splitter/ 'Components.asis' 'Components.suppress'- --- ifs, wherever, unless, select,- -- ** Recursive- while, nestedIn,- -- * Section-based combinators- -- | All combinators in this section use their 'Splitter' argument to determine the- -- structure of the input. Every contiguous portion of the input that gets passed to one or the other sink of the- -- splitter is treated as one section in the logical structure of the input stream. What is done with the section- -- depends on the combinator, but the sections, and therefore the logical structure of the input stream, are- -- determined by the argument splitter alone.- foreach, having, havingOnly, followedBy, even,- -- ** first and its variants- first, uptoFirst, prefix,- -- ** last and its variants- last, lastAndAfter, suffix,- -- ** input ranges- between, (...))-where--import Control.Concurrent.SCC.Foundation-import Control.Concurrent.SCC.ComponentTypes--import Prelude hiding (even, last, (||), (&&))-import qualified Prelude-import Control.Exception (assert)-import Control.Monad (liftM, when)-import qualified Control.Monad as Monad-import Data.Maybe (isJust, isNothing, fromJust)-import Data.Typeable (Typeable)-import qualified Data.Foldable as Foldable-import qualified Data.Sequence as Seq-import Data.Sequence (Seq, (|>), (><), ViewL (EmptyL, (:<)))--import Debug.Trace (trace)---infixr ->>---- | The result of combinator '->>' is a consumer that acts as a composition of the given transducer and consumer--- arguments.-(->>) :: forall x y m r. (Monad m, Typeable x, Typeable y) => Transducer m x y -> Consumer m y r -> Consumer m x r-Transducer t ->> consumer = consumer'- where consumer' source = liftM snd $ pipeD "->>" (t source) consumer---- | The result of combinator '<<-' is a producer that acts as a composition of the given transducer and producer--- arguments.-(<<-) :: forall x y m r c c1. (Monad m, Typeable x, Typeable y) => Transducer m x y -> Producer m x r -> Producer m y r-Transducer t <<- producer = producer'- where producer' sink = liftM fst $ pipeD "<<-" producer (flip t sink)----- | The '>->' combinator composes its argument transducers. The resulting composition /t1 >-> t2/ passes its input through the--- first transducer /t1/, the output of /t1/ is passed to the other transducer /t2/, and its output becomes the output of the--- composition.-(>->) :: forall m x y z. Monad m => Transducer m x y -> Transducer m y z -> Transducer m x z-Transducer t1 >-> Transducer t2 = Transducer t- where t source sink = liftM fst $ pipeD ">->" (t1 source) (flip t2 sink)---- | The 'join' combinator arranges the two transducer arguments in parallel. The input of the resulting transducer is replicated--- to both component transducers in parallel, and the output of the resulting transducer is a concatenation of the two component--- transducers' outputs.-join :: (Monad m, Typeable x) => Transducer m x y -> Transducer m x y -> Transducer m x y-join (Transducer t1) (Transducer t2) = Transducer t- where t source sink = do (((), l), extra) <- pipeD "join 1"- (\sink1-> pipeD "join 2" (\sink2-> tee source sink1 sink2) getList)- (flip t1 sink)- pipeD "join 3" (putList l) (flip t2 sink)- return extra--- | The 'snot' (streaming not) combinator simply reverses the outputs of the argument splitter.--- In other words, data that the argument splitter sends to its /true/ sink goes to the /false/ sink of the result, and vice versa.-snot :: (Monad m, Typeable x) => Splitter m x -> Splitter m x-snot splitter = liftSectionSplitter (\source true false-> splitSections splitter source false true)---- | The '>&' combinator sends the /true/ sink output of its left operand to the input of its right operand for further--- splitting. Both operands' /false/ sinks are connected to the /false/ sink of the combined splitter, but any input--- value to reach the /true/ sink of the combined component data must be deemed true by both splitters.-(>&) :: (Monad m, Typeable x) => Splitter m x -> Splitter m x -> Splitter m x-s1 >& s2 = liftSimpleSplitter (\source true false->- liftM fst $ pipeD ">&" (\true-> split s1 source true false) (\source-> split s2 source true false))---- | A '>|' combinator's input value can reach its /false/ sink only by going through both argument splitters' /false/--- sinks.-(>|) :: (Monad m, Typeable x) => Splitter m x -> Splitter m x -> Splitter m x-s1 >| s2 = liftSimpleSplitter (\source true false->- liftM fst $ pipeD ">|" (split s1 source true) (\source-> split s2 source true false))---- | Combinator '&&' is a pairwise logical conjunction of two splitters run in parallel on the same input.-(&&) :: (Monad m, Typeable x) => Splitter m x -> Splitter m x -> Splitter m x-(&&) = zipSplittersWith (Prelude.&&)---- | Combinator '||' is a pairwise logical disjunction of two splitters run in parallel on the same input.-(||) :: (Monad m, Typeable x) => Splitter m x -> Splitter m x -> Splitter m x-(||) = zipSplittersWith (Prelude.||)---- | The result of the combinator 'ifs' is a transducer that applies one argument transducer to one portion of--- the input and the other transducer to the other portion of input, depending on where the splitter argument routes the data.-ifs :: (Monad m, Typeable x) => Splitter m x -> Transducer m x y -> Transducer m x y -> Transducer m x y-ifs s (Transducer t1) (Transducer t2) = Transducer t- where t source sink = liftM fst3 $ splitConsumer "ifs" s (flip t1 sink) (flip t2 sink) source--wherever :: (Monad m, Typeable x) => Transducer m x x -> Splitter m x -> Transducer m x x-wherever (Transducer t) s = Transducer wherever'- where wherever' source sink = liftM fst3 $ splitConsumer "wherever" s (flip t sink) (flip pour sink) source--unless :: (Monad m, Typeable x) => Transducer m x x -> Splitter m x -> Transducer m x x-unless (Transducer t) s = Transducer unless'- where unless' source sink = liftM fst3 $ splitConsumer "unless" s (flip pour sink) (flip t sink) source--select :: (Monad m, Typeable x) => Splitter m x -> Transducer m x x-select s = Transducer (\source sink-> liftM fst3 $ splitConsumer "select" s (flip pour sink) consumeAndSuppress source)---- | The recursive combinator 'while' feeds the true sink of the argument splitter back to itself, modified by the--- argument transducer. Data fed to the splitter's false sink is passed on unmodified.-while :: (Monad m, Typeable x) => Transducer m x x -> Splitter m x -> Transducer m x x-while t s = Transducer while'- where while' source sink = liftM fst3 $ splitConsumer "while" s (t ->> while t s ->> flip pour sink) (flip pour sink) source---- | The recursive combinator 'nestedIn' combines two splitters into a mutually recursive loop acting as a single splitter.--- The true sink of one of the argument splitters and false sink of the other become the true and false sinks of the loop.--- The other two sinks are bound to the other splitter's source.--- The use of 'nestedIn' makes sense only on hierarchically structured streams. If we gave it some input containing--- a flat sequence of values, and assuming both component splitters are deterministic and stateless,--- a value would either not loop at all or it would loop forever.-nestedIn :: (Monad m, Typeable x) => Splitter m x -> Splitter m x -> Splitter m x-nestedIn s1 s2 = s- where s = liftSimpleSplitter (\source true false->- liftM fst $- pipe (\false-> split s1 source true false)- (\source-> pipe (\true-> split s2 source true false)- (\source-> split (nestedIn s1 s2) source true false)))---- | The 'foreach' combinator is similar to the combinator 'ifs' in that it combines a splitter and two transducers into--- another transducer. However, in this case the transducers are re-instantiated for each consecutive portion of the--- input as the splitter chunks it up. Each contiguous portion of the input that the splitter sends to one of its two--- sinks gets transducered through the appropriate argument transducer as that transducer's whole input. As soon as the--- contiguous portion is finished, the transducer gets terminated.-foreach :: (Monad m, Typeable x, Typeable y) => Splitter m x -> Transducer m x y -> Transducer m x y -> Transducer m x y-foreach s t1 t2 = Transducer t- where t source sink = liftM fst $- pipeD "foreach"- (transduce (splitterToMarker s) source)- (\source-> groupMarks source (\b chunk-> transduce (if b then t1 else t2) chunk sink))---- | The 'having' combinator combines two pure splitters into a pure splitter. One splitter is used to chunk the input--- into contiguous portions. Its /false/ sink is routed directly to the /false/ sink of the combined splitter. The--- second splitter is instantiated and run on each portion of the input that goes to first splitter's /true/ sink. If--- the second splitter sends any output at all to its /true/ sink, the whole input portion is passed on to the /true/--- sink of the combined splitter, otherwise it goes to its /false/ sink.-having :: (Monad m, Typeable x) => Splitter m x -> Splitter m x -> Splitter m x-having s1 s2 = liftSectionSplitter s- where s source true false = liftM fst $- pipeD "having"- (transduce (splitterToMarker s1) source)- (\source-> groupMarks source (\b chunk-> if b then test chunk else pourMaybe chunk false))- where test chunk = pipe (\sink1-> pipe (\sink2-> tee chunk sink1 sink2) getList)- (\chunk-> pipe (\sink-> suppressProducer (split s2 chunk sink)) getList)- >>= \(((), chunk), (_, truePart))-> let chunk' = if null chunk- then [Nothing]- else map Just chunk- in (if null truePart- then putList chunk' false- else putList chunk' true)- >> 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 :: (Monad m, Typeable x) => Splitter m x -> Splitter m x -> Splitter m x-havingOnly s1 s2 = liftSectionSplitter s- where s source true false = liftM fst $- pipeD "havingOnly"- (transduce (splitterToMarker s1) source)- (\source-> groupMarks source (\b chunk-> if b then test chunk else pourMaybe chunk false))- where test chunk = pipe (\sink1-> pipe (\sink2-> tee chunk sink1 sink2) getList)- (\chunk-> pipe (\sink-> suppressProducer (\suppress-> split s2 chunk suppress sink))- getList)- >>= \(((), chunk), (_, falsePart))-> let chunk' = if null chunk- then [Nothing]- else map Just chunk- in (if null falsePart- then putList chunk' true- else putList chunk' false)- >> return ()---- | The result of combinator 'first' behaves the same as the argument splitter up to and including the first portion of--- the input which goes into the argument's /true/ sink. All input following the first true portion goes into the--- /false/ sink.-first :: (Monad m, Typeable x) => Splitter m x -> Splitter m x-first splitter = liftSectionSplitter s- where s source true false = liftM (\(x, y)-> y ++ x) $- pipeD "first" (transduce (splitterToMarker splitter) source)- (\source-> let get1 (x, False) = p false x get1- get1 (x, True) = p true x get2- get2 (x, True) = p true x get2- get2 (x, False) = p false x get3- get3 (x, _) = p false x get3- p sink x succeed = put sink x- >>= cond (get source >>= maybe (return []) succeed)- (return $ maybe [] (:[]) x)- in get source >>= maybe (return []) get1)---- | The result of combinator 'uptoFirst' takes all input up to and including the first portion of the input which goes--- into the argument's /true/ sink and feeds it to the result splitter's /true/ sink. All the rest of the input goes--- into the /false/ sink. The only difference between 'last' and 'lastAndAfter' combinators is in where they direct the--- /false/ portion of the input preceding the first /true/ part.-uptoFirst :: (Monad m, Typeable x) => Splitter m x -> Splitter m x-uptoFirst splitter = liftSectionSplitter s- where s source true false = liftM (\(x, y)-> concatMap (maybe [] (:[])) y ++ x) $- pipeD "uptoFirst" (transduce (splitterToMarker splitter) source)- (\source-> let get1 q (x, False) = let q' = q |> x- in get source- >>= maybe- (putQueue q' false)- (get1 q')- get1 q p@(x, True) = do rest <- putQueue q true- if null rest then get2 p else return rest- get2 (x, True) = p true x get2- get2 (x, False) = p false x get3- get3 (x, _) = p false x get3- p sink x succeed = put sink x- >>= cond (get source >>= maybe (return []) succeed)- (return [x])- in get source >>= maybe (return []) (get1 Seq.empty))---- | The result of the combinator 'last' is a splitter which directs all input to its /false/ sink, up to the last--- portion of the input which goes to its argument's /true/ sink. That portion of the input is the only one that goes to--- the resulting component's /true/ sink. The splitter returned by the combinator 'last' has to buffer the previous two--- portions of its input, because it cannot know if a true portion of the input is the last one until it sees the end of--- the input or another portion succeeding the previous one.-last :: (Monad m, Typeable x) => Splitter m x -> Splitter m x-last splitter = liftSectionSplitter s- where s source true false = liftM (\(x, y)-> concatMap (maybe [] (:[])) y ++ x) $- pipeD "last" (transduce (splitterToMarker splitter) source)- (\source-> let get1 (x, False) = put false x- >>= cond (get source >>= maybe (return []) get1)- (return [x])- get1 p@(x, True) = get2 Seq.empty p- get2 q (x, True) = let q' = q |> x- in get source- >>= maybe- (putQueue q' true)- (get2 q')- get2 q p@(x, False) = get3 q Seq.empty p- get3 qt qf (x, False) = let qf' = qf |> x- in get source- >>= maybe- (putQueue qt true >> putQueue qf' false)- (get3 qt qf')- get3 qt qf p@(x, True) = do rest1 <- putQueue qt false- rest2 <- putQueue qf false - if null rest1 Prelude.&& null rest2- then get2 Seq.empty p- else return (rest1 ++ rest2)- p succeed = get source >>= maybe (return []) succeed- in p get1)---- | The result of the combinator 'lastAndAfter' is a splitter which directs all input to its /false/ sink, up to the--- last portion of the input which goes to its argument's /true/ sink. That portion and the remainder of the input is fed--- to the resulting component's /true/ sink. The difference between 'last' and 'lastAndAfter' combinators is where they--- feed the /false/ portion of the input, if any, remaining after the last /true/ part.-lastAndAfter :: (Monad m, Typeable x) => Splitter m x -> Splitter m x-lastAndAfter splitter = liftSectionSplitter s- where s source true false = liftM (\(x, y)-> concatMap (maybe [] (:[])) y ++ x) $- pipeD "lastAndAfter" (transduce (splitterToMarker splitter) source)- (\source-> let get1 (x, False) = put false x >>= cond (p get1) (return [x])- get1 p@(x, True) = get2 Seq.empty p- get2 q (x, True) = let q' = q |> x- in get source- >>= maybe- (putQueue q' true)- (get2 q')- get2 q p@(x, False) = get3 q p- get3 q (x, False) = let q' = q |> x- in get source- >>= maybe- (putQueue q' true)- (get3 q')- get3 q p@(x, True) = putQueue q false >>= whenNull (get1 p)- p succeed = get source >>= maybe (return []) succeed- in p get1)---- | The 'prefix' combinator feeds its /true/ sink only the prefix of the input that its argument feeds to its /true/ sink.--- All the rest of the input is dumped into the /false/ sink of the result.-prefix :: (Monad m, Typeable x) => Splitter m x -> Splitter m x-prefix splitter = liftSectionSplitter s- where s source true false = liftM (\(x, y)-> y ++ x) $- pipeD "prefix" (transduce (splitterToMarker splitter) source)- (\source-> let get1 (x, False) = p false x get2- get1 (x, True) = p true x get1- get2 (x, _) = p false x get2- p sink x succeed = put sink x- >>= cond (get source >>= maybe (return []) succeed)- (return $ maybe [] (:[]) x)- in get source >>= maybe (return []) get1)---- | The 'suffix' combinator feeds its /true/ sink only the suffix of the input that its argument feeds to its /true/ sink.--- All the rest of the input is dumped into the /false/ sink of the result.-suffix :: (Monad m, Typeable x) => Splitter m x -> Splitter m x-suffix splitter = liftSectionSplitter s- where s source true false = liftM (\(x, y)-> concatMap (maybe [] (:[])) y ++ x) $- pipeD "suffix" (transduce (splitterToMarker splitter) source)- (\source-> let get1 (x, False) = put false x >>= cond (p get1) (return [x])- get1 (x, True) = get2 (Seq.singleton x)- get2 q = get source- >>= maybe (putQueue q true) (get3 q)- get3 q (x, True) = get2 (q |> x)- get3 q p@(x, False) = putQueue q false >>= whenNull (get1 p)- p succeed = get source >>= maybe (return []) succeed- in p get1)---- | The 'even' combinator takes every input section that its argument splitters deems /true/, and feeds even ones into--- its /true/ sink. The odd sections and parts of input that are /false/ according to its argument splitter are fed to--- 'even' splitter's /false/ sink.-even :: (Monad m, Typeable x) => Splitter m x -> Splitter m x-even splitter = liftSectionSplitter s- where s source true false = liftM (\(x, y)-> concatMap (maybe [] (:[])) y ++ x) $- pipeD "even"- (transduce (splitterToMarker splitter) source)- (\source-> let get1 (x, False) = put false x- >>= cond (get source >>= maybe (return []) get1)- (return [x])- get1 p@(x, True) = get2 p- get2 (x, True) = put false x- >>= cond (get source >>= maybe (return []) get2)- (return [x])- get2 p@(x, False) = get3 p- get3 (x, False) = put false x- >>= cond (get source >>= maybe (return []) get3)- (return [x])- get3 p@(x, True) = get4 p- get4 (x, True) = put true x- >>= cond (get source >>= maybe (return []) get4)- (return [x])- get4 p@(x, False) = get1 p- in get source >>= maybe (return []) get1)---- | Combinator 'followedBy' treats its argument 'Splitter's as patterns components and returns a 'Splitter' that--- matches their concatenation. A section of input is considered /true/ by the result iff its prefix is considered--- /true/ by argument /s1/ and the rest of the section is considered /true/ by /s2/. The splitter /s2/ is started anew--- after every section split to /true/ sink by /s1/.-followedBy :: forall m x. (Monad m, Typeable x) => Splitter m x -> Splitter m x -> Splitter m x-followedBy s1 s2 = liftSectionSplitter s- where s source true false- = liftM (\(x, y)-> concatMap (maybe [] (:[])) y ++ x) $- pipeD "followedBy"- (transduce (splitterToMarker s1) source)- (\source-> let get0 q = case Seq.viewl q- of Seq.EmptyL -> get source >>= maybe (return []) get1- (x, False) :< rest -> put false x- >>= cond (get0 rest)- (return $ Foldable.toList $ Seq.viewl $ fmap fst q)- (x, True) :< rest -> get2 Seq.empty q- get1 (x, False) = put false x- >>= cond (get source >>= maybe (return []) get1)- (return [x])- get1 p@(x, True) = get2 Seq.empty (Seq.singleton p)- get2 q q' = case Seq.viewl q'- of Seq.EmptyL -> get source- >>= maybe (testEnd q) (get2 q . Seq.singleton)- (x, True) :< rest -> get2 (q |> x) rest- (x, False) :< rest -> do ((q1, q2), n) <- pipeD "followedBy tail"- (get3 Seq.empty q') (test q)- case n of Nothing -> putQueue q false- >>= whenNull (get0 (q1 >< q2))- Just n -> do put false Nothing- get0 (dropJust n q1 >< q2)- get3 q1 q2 sink = canPut sink- >>= cond (case Seq.viewl q2- of Seq.EmptyL -> get source- >>= maybe (return (q1, q2))- (\p-> maybe (return True) (put sink) (fst p)- >> get3 (q1 |> p) q2 sink)- p :< rest -> maybe (return True) (put sink) (fst p)- >> get3 (q1 |> p) rest sink)- (return (q1, q2))- testEnd q = do ((), n) <- pipeD "testEnd" (const $ return ()) (test q)- case n of Nothing -> putQueue q false- _ -> return []- test q source = liftM snd $- pipeD "follower"- (transduce (splitterToMarker s2) source)- (\source-> let get4 (_, False) = return Nothing- get4 p@(_, True) = putQueue q true >> get5 0 p- get5 n (x, False) = return (Just n)- get5 n (Nothing, True) = get6 n- get5 n (x, True) = put true x >> get6 (succ n)- get6 n = get source- >>= maybe- (return $ Just n)- (get5 n)- in get source >>= maybe (return Nothing) get4)- dropJust 0 q = q- dropJust n q = case Seq.viewl q of (Nothing, _) :< rest -> dropJust n rest- (Just _, _) :< rest -> dropJust (pred n) rest- in get0 Seq.empty)---- | Combinator 'between' passes to its /true/ sink all input that follows a section considered true by its first--- argument splitter but not a section considered true by its second argument. The section delimiter pairs can nest to--- arbitrary depth.-between :: forall m x. (Monad m, Typeable x) => Splitter m x -> Splitter m x -> Splitter m x-between s1 s2 = liftSectionSplitter s- where s source true false = liftM (\(x, y)-> concatMap (maybe [] (:[])) y ++ x) $- pipeD "between"- (transduce (pairMarkerToMaybePairMarker $ splittersToPairMarker s1 s2) source)- (\source-> let next state = get source >>= maybe (return []) state- pass sink x state = put sink x >>= cond (next state) (return [x])- state0 t@(x, True, False) = state1 t- state0 (x, _, _) = pass false x state0- state1 t@(x, _, True) = state0 t- state1 (x, True, False) = pass false x state1- state1 t@(x, False, False) = state2 1 t- state2 n (x, False, False) = pass true x (state2 n)- state2 n t@(x, _, True) = state4 (pred n) t- state2 n t@(x, True, False) = state3 (succ n) t- state3 n (x, True, _) = pass true x (state3 n)- state3 n t@(x, False, False) = state2 n t- state3 n t@(x, False, True) = state4 (pred n) t- state4 0 t = state0 t- state4 n (x, _, True) = pass true x (state4 n)- state4 n t@(x, True, False) = state3 (succ n) t- state4 n t@(x, False, False) = state2 n t- in next state0)---- | Combinator '...' is similar to 'between', except it passes to /true/ the delimiting sections as well--- as all input between them.-(...) :: forall m x. (Monad m, Typeable x) => Splitter m x -> Splitter m x -> Splitter m x-s1 ... s2 = liftSectionSplitter s- where s source true false = liftM (\(x, y)-> concatMap (maybe [] (:[])) y ++ x) $- pipeD "..."- (transduce (pairMarkerToMaybePairMarker $ splittersToPairMarker s1 s2) source)- (\source-> let next state = get source >>= maybe (return []) state- pass sink x state = put sink x >>= cond (next state) (return [x])- state0 (x, False, _) = pass false x state0- state0 t@(x, True, _) = state1 1 t- state1 0 t = state0 t- state1 n (x, True, False) = pass true x (state1 n)- state1 n t@(x, False, False) = state2 n t- state1 n t@(x, _, True) = state3 (pred n) t- state2 n (x, False, False) = pass true x (state2 n)- state2 n t@(x, _, True) = state3 (pred n) t- state2 n t@(x, True, False) = state1 (succ n) t- state3 n (x, _, True) = pass true x (state3 n)- state3 n t@(x, True, False) = put false Nothing >> state1 (succ n) t- state3 0 t@(x, False, False) = state0 t- state3 n t@(x, False, False) = state2 n t- in next state0)---- Helper functions--type Marker m x = Transducer m x (Maybe x, Bool)--splitterToMarker :: forall m x. (Monad m, Typeable x) => Splitter m x -> Marker m x-splitterToMarker s = Transducer t- where t source sink = liftM (\((x, y), z)-> z ++ y ++ x) $- pipeD "splitterToMarker true"- (\trueSink-> pipeD "splitterToMarker false" (splitSections s source trueSink) (mark False))- (mark True)- where mark b source = canPut sink- >>= cond (get source- >>= maybe (return [])- (\x-> put sink (x, b) >>= cond (mark b source) (return $ maybe [] (: []) x)))- (return [])---splittersToPairMarker :: forall m x. (Monad m, Typeable x)- => Splitter m x -> Splitter m x -> Transducer m x (Either (x, Bool, Bool) (Either Bool Bool))-splittersToPairMarker s1 s2 = Transducer t- where t source sink = liftM (\((((((((), l1), l2), l3), l4), l5), l6), l7)-> l7 ++ l6 ++ l5 ++ l4 ++ l3 ++ l2 ++ l1) $- pipeD "splittersToMarker synchronize"- (\sync->- pipeD "splittersToMarker true1"- (\true1->- pipeD "splittersToMarker false1"- (\false1->- pipeD "splitterssToMarker true2"- (\true2->- pipeD "splittersToMarker false2"- (\false2->- pipeD "splittersToMarker sink1"- (\sink1->- pipeD "splittersToMarker sink2"- (\sink2-> tee source sink1 sink2)- (\source2-> splitSections s2 source2 true2 false2))- (\source1-> splitSections s1 source1 true1 false1))- (mark sync False False))- (mark sync False True))- (mark sync True False))- (mark sync True True))- (synchronizeMarks Nothing)- where synchronizeMarks :: Maybe (Seq (x, Bool), Bool) -> Source c (Maybe x, Bool, Bool) -> Pipe c m [x]- synchronizeMarks state source- = get source--- >>= \t-> trace (show t ++ "@" ++ show state) (return t)- >>= maybe- (assert (isNothing state) (return []))- (\(x, pos, b) ->- maybe- (put sink (Right $ if pos then Left b else Right b)- >> synchronizeMarks state source)- (\x-> case state- of Nothing -> synchronizeMarks (Just (Seq.singleton (x, b), pos)) source- Just (q, pos') -> if pos == pos'- then synchronizeMarks (Just (q |> (x, b), pos')) source- else case Seq.viewl q- of Seq.EmptyL -> synchronizeMarks- (Just (Seq.singleton (x, b), pos))- source- (y, b') :< rest -> put sink (Left $ if pos- then (x, b, b')- else (x, b', b))- >>= cond- (synchronizeMarks- (if Seq.null rest- then Nothing- else Just (rest, pos'))- source)- (returnQueuedList q))- x)- returnQueuedList q = return $ map fst $ Foldable.toList $ Seq.viewl q- mark sink first b source = let mark' = canPut sink- >>= cond- (get source- >>= maybe- (return [])- (\x-> put sink (x, first, b)- >>= cond mark' (return $ maybe [] (: []) x)))- (return [])- in mark'--pairMarkerToMaybePairMarker :: forall m x. (Monad m, Typeable x)- => Transducer m x (Either (x, Bool, Bool) (Either Bool Bool)) -> Transducer m x (Maybe x, Bool, Bool)-pairMarkerToMaybePairMarker t = Transducer t'- where t' source sink = liftM (\(x, y)-> y ++ x) $- pipeD "pairMarkerToMaybePairMarker"- (transduce t source)- (\source-> let next state = get source >>= maybe (return []) state- nextState2 l r d = get source- >>= maybe (put sink (Nothing, l, r) >> return []) (state2 l r d)- state0 (Left (x, l, r)) = put sink (Just x, l, r)- >>= cond (next $ state1 l r) (return [x])- state0 v@(Right d) = state2 False False d v- state1 _ _ (Left (x, l, r)) = put sink (Just x, l, r)- >>= cond (next $ state1 l r) (return [x])- state1 l r v@(Right d) = state2 l r d v- state2 l r Left{} (Right d@(Left l')) = nextState2 l' r d- state2 l r Left{} (Right (Right r')) = put sink (Nothing, l, r')- >>= cond (next $ state1 l r') (return [])- state2 l r Left{} t@(Left (x, l', r')) | l == l' = state1 l r t- | otherwise = put sink (Nothing, l, r)- >>= cond- (state1 l' r' t)- (return [])- state2 l r Right{} (Right d@(Right r')) = nextState2 l r' d- state2 l r Right{} (Right (Left l')) = put sink (Nothing, l', r)- >>= cond (next $ state1 l' r) (return [])- state2 l r Right{} t@(Left (x, l', r')) | r == r' = state1 l r t- | otherwise = put sink (Nothing, l, r)- >>= cond- (state1 l' r' t)- (return [])- in next state0)--zipSplittersWith :: (Monad m, Typeable x) => (Bool -> Bool -> Bool) -> Splitter m x -> Splitter m x -> Splitter m x-zipSplittersWith f s1 s2- = liftSectionSplitter (\source true false->- liftM (\(x, y)-> y ++ x) $- pipeD "&"- (transduce (pairMarkerToMaybePairMarker $ splittersToPairMarker s1 s2) source)- (\source-> let split = get source >>= maybe (return []) test- test (x, b1, b2) = (if f b1 b2 then put true x else put false x)- >>= cond split (return $ maybe [] (:[]) x)- in split))--groupMarks :: forall c1 c m x y z. (Monad m, Typeable x, Typeable y, Eq y)- => Source c1 (Maybe x, y) -> (y -> Consumer m x z) -> Pipe c m ()-groupMarks source getConsumer = getSuccess source startNew- where startNew (mx, y) = do (nextPair, _) <- pipeD "groupMarks" (\sink-> pass sink mx y) (getConsumer y)- case nextPair of Just p -> startNew p- Nothing -> return ()- pass sink Nothing y = next sink y- pass sink (Just x) y = put sink x >> next sink y- next sink y = get source >>= maybe (return Nothing) (continue sink y)- continue sink y (x, y') | y == y' = pass sink x y- continue sink y p@(x, y') | y /= y' = return (Just p)--splitConsumer :: forall x m r1 r2 c c1. (Monad m, Typeable x)- => String -> Splitter m x -> Consumer m x r1 -> Consumer m x r2 -> Source c1 x -> Pipe c m ([x], r1, r2)-splitConsumer description s trueConsumer falseConsumer = consumer'- where consumer' source = pipeD (description ++ " false")- (\false-> pipeD (description ++ " true") (\true-> split s source true false) trueConsumer)- falseConsumer- >>= \((extra, r1), r2)-> return (extra, r1, r2)--splitConsumerSections :: forall x m r1 r2 c c1. (Monad m, Typeable x)- => String -> Splitter m x -> Consumer m (Maybe x) r1 -> Consumer m (Maybe x) r2 -> Source c1 x- -> Pipe c m ([x], r1, r2)-splitConsumerSections description s trueConsumer falseConsumer = consumer'- where consumer' source = pipeD (description ++ " false")- (\false-> pipeD (description ++ " true") (\true-> splitSections s source true false) trueConsumer)- falseConsumer- >>= \((extra, r1), r2)-> return (extra, r1, r2)--putQueue :: forall context r m x. (Monad m, Typeable x) => Seq x -> Sink context x -> Pipe r m [x]-putQueue q sink = putList (Foldable.toList (Seq.viewl q)) sink--getQueue :: forall x c c1 m. (Monad m, Typeable x) => Source c1 x -> Pipe c m (Seq x)-getQueue source = let getOne q = get source >>= maybe (return q) (\x-> getOne (q |> x))- in getOne Seq.empty--pourMaybe :: forall c c1 c2 x m. (Monad m, Typeable x) => Source c1 x -> Sink c2 (Maybe x) -> Pipe c m ()-pourMaybe source sink = pour0- where pour0 = canPut sink >>= flip when (get source >>= maybe (put sink Nothing >> return ()) pass)- pour1 = canPut sink >>= flip when (getSuccess source pass)- pass x = put sink (Just x) >> pour1---suppressProducer :: forall x c m r. (Monad m, Typeable x) => Producer m x r -> Pipe c m r-suppressProducer producer = liftM fst $ pipeD "suppress" producer consumeAndSuppress+{-# LANGUAGE ScopedTypeVariables, Rank2Types, KindSignatures, EmptyDataDecls,+ MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, FlexibleInstances #-}++-- | The "Combinators" module defines combinators applicable to 'Transducer' and 'Splitter' components defined in the+-- "ComponentTypes" module.++module Control.Concurrent.SCC.Combinators+ (-- * Consumer, producer, and transducer combinators+ consumeBy, prepend, append, substitute,+ PipeableComponentPair ((>->)), JoinableComponentPair (join, sequence),+ -- * Pseudo-logic splitter combinators+ -- | Combinators '>&' and '>|' are only /pseudo/-logic. While the laws of double negation and De Morgan's laws hold,+ -- '>&' and '>|' are in general not commutative, associative, nor idempotent. In the special case when all argument+ -- splitters are stateless, such as those produced by 'Components.liftStatelessSplitter', these combinators do satisfy+ -- all laws of Boolean algebra.+ snot, (>&), (>|),+ -- ** Zipping logic combinators+ -- | The '&&' and '||' combinators run the argument splitters in parallel and combine their logical outputs using+ -- the corresponding logical operation on each output pair, in a manner similar to 'Prelude.zipWith'. They fully+ -- satisfy the laws of Boolean algebra.+ (&&), (||),+ -- * Flow-control combinators+ -- | The following combinators resemble the common flow-control programming language constructs. Combinators + -- 'wherever', 'unless', and 'select' are just the special cases of the combinator 'ifs'.+ --+ -- * /transducer/ ``wherever`` /splitter/ = 'ifs' /splitter/ /transducer/ 'Components.asis'+ --+ -- * /transducer/ ``unless`` /splitter/ = 'ifs' /splitter/ 'Components.asis' /transducer/+ --+ -- * 'select' /splitter/ = 'ifs' /splitter/ 'Components.asis' 'Components.suppress'+ --+ ifs, wherever, unless, select,+ -- ** Recursive+ while, nestedIn,+ -- * Section-based combinators+ -- | All combinators in this section use their 'Splitter' argument to determine the+ -- structure of the input. Every contiguous portion of the input that gets passed to one or the other sink of the+ -- splitter is treated as one section in the logical structure of the input stream. What is done with the section+ -- depends on the combinator, but the sections, and therefore the logical structure of the input stream, are+ -- determined by the argument splitter alone.+ foreach, having, havingOnly, followedBy, even,+ -- ** first and its variants+ first, uptoFirst, prefix,+ -- ** last and its variants+ last, lastAndAfter, suffix,+ -- ** positional splitters+ startOf, endOf,+ -- ** input ranges+ (...))+where++import Control.Concurrent.SCC.Foundation+import Control.Concurrent.SCC.ComponentTypes++import Prelude hiding (even, last, sequence, (||), (&&))+import qualified Prelude+import Control.Exception (assert)+import Control.Monad (liftM, when)+import qualified Control.Monad as Monad+import Data.Maybe (isJust, isNothing, fromJust)+import Data.Typeable (Typeable)+import qualified Data.Foldable as Foldable+import qualified Data.Sequence as Seq+import Data.Sequence (Seq, (|>), (><), ViewL (EmptyL, (:<)))++import Debug.Trace (trace)++consumeBy :: forall m x y r. (Monad m, Typeable x) => Consumer m x r -> Transducer m x y+consumeBy c = liftTransducer "consumeBy" (maxUsableThreads c) $+ \threads-> let c' = usingThreads threads c+ in (ComponentConfiguration [AnyComponent c'] (usedThreads c') (cost c'),+ \ source _sink -> consume c' source >> return [])++-- | Class 'PipeableComponentPair' applies to any two components that can be combined into a third component with the+-- | following properties:+-- | * The input of the result, if any, becomes the input of the first component.+-- | * The output produced by the first child component is consumed by the second child component.+-- | * The result output, if any, is the output of the second component.+class PipeableComponentPair (m :: * -> *) w c1 c2 c3 | c1 c2 -> c3, c1 c3 -> c2, c2 c3 -> c2,+ c1 -> m w, c2 -> m w, c3 -> m+ where (>->) :: c1 -> c2 -> c3++instance (ParallelizableMonad m, Typeable x)+ => PipeableComponentPair m x (Producer m x ()) (Consumer m x ()) (Performer m ())+ where p >-> c = liftPerformer ">->" (maxUsableThreads p `max` maxUsableThreads c) $+ \threads-> let (configuration, p', c', parallel) = optimalTwoParallelConfigurations threads p c+ performPipe = (if parallel then pipeP else pipe) (produce p') (consume c') >> return ()+ in (configuration, performPipe)++instance (ParallelizableMonad m, Typeable x, Typeable y)+ => PipeableComponentPair m y (Transducer m x y) (Consumer m y r) (Consumer m x r)+ where t >-> c = liftConsumer ">->" (maxUsableThreads t `max` maxUsableThreads c) $+ \threads-> let (configuration, t', c', parallel) = optimalTwoParallelConfigurations threads t c+ consumePipe source = liftM snd $ (if parallel then pipeP else pipe)+ (transduce t' source)+ (consume c')+ in (configuration, consumePipe)++instance (ParallelizableMonad m, Typeable x, Typeable y)+ => PipeableComponentPair m x (Producer m x r) (Transducer m x y) (Producer m y r)+ where p >-> t = liftProducer ">->" (maxUsableThreads t `max` maxUsableThreads p) $+ \threads-> let (configuration, p', t', parallel) = optimalTwoParallelConfigurations threads p t+ producePipe sink = liftM fst $ (if parallel then pipeP else pipe)+ (produce p')+ (\source-> transduce t' source sink)+ in (configuration, producePipe)++instance ParallelizableMonad m => PipeableComponentPair m y (Transducer m x y) (Transducer m y z) (Transducer m x z)+ where t1 >-> t2 = liftTransducer ">->" (maxUsableThreads t1 + maxUsableThreads t2) $+ \threads-> let (configuration, t1', t2', parallel) = optimalTwoParallelConfigurations threads t1 t2+ transducePipe source sink = liftM fst $ (if parallel then pipeP else pipe)+ (transduce t1' source)+ (\source-> transduce t2' source sink)+ in (configuration, transducePipe)++class Component c => CompatibleSignature c cons (m :: * -> *) input output | c -> cons m++class AnyListOrUnit c++instance AnyListOrUnit [x]+instance AnyListOrUnit ()++instance (AnyListOrUnit x, AnyListOrUnit y) => CompatibleSignature (Performer m r) (PerformerType r) m x y+instance AnyListOrUnit y => CompatibleSignature (Consumer m x r) (ConsumerType r) m [x] y+instance AnyListOrUnit y => CompatibleSignature (Producer m x r) (ProducerType r) m y [x]+instance CompatibleSignature (Transducer m x y) TransducerType m [x] [y]++data PerformerType r+data ConsumerType r+data ProducerType r+data TransducerType++-- | Class 'JoinableComponentPair' applies to any two components that can be combined into a third component with the+-- | following properties:+-- | * if both argument components consume input, the input of the combined component gets distributed to both+-- | components in parallel,+-- | * if both argument components produce output, the output of the combined component is a concatenation of the+-- | complete output from the first component followed by the complete output of the second component, and+-- | * the 'join' method may apply the components in any order, the 'sequence' method makes sure its first argument+-- | has completed before using the second one.+class (Monad m, CompatibleSignature c1 t1 m x y, CompatibleSignature c2 t2 m x y, CompatibleSignature c3 t3 m x y)+ => JoinableComponentPair t1 t2 t3 m x y c1 c2 c3 | c1 c2 -> c3, c1 -> t1 m, c2 -> t2 m, c3 -> t3 m x y,+ t1 m x y -> c1, t2 m x y -> c2, t3 m x y -> c3+ where join :: c1 -> c2 -> c3+ sequence :: c1 -> c2 -> c3+ join = sequence++instance forall m x any r1 r2. (Monad m, Typeable x)+ => JoinableComponentPair (ProducerType r1) (ProducerType r2) (ProducerType r2) m () [x] (Producer m x r1) (Producer m x r2) (Producer m x r2)+ where sequence p1 p2 = liftProducer "sequence" (maxUsableThreads p1 `max` maxUsableThreads p2) $+ \threads-> let (configuration, p1', p2') = optimalTwoSequentialConfigurations threads p1 p2+ produceJoin sink = produce p1' sink >> produce p2' sink+ in (configuration, produceJoin)++instance forall m x any. (ParallelizableMonad m, Typeable x)+ => JoinableComponentPair (ConsumerType ()) (ConsumerType ()) (ConsumerType ()) m [x] () (Consumer m x ()) (Consumer m x ()) (Consumer m x ())+ where join c1 c2 = liftConsumer "join" (maxUsableThreads c1 + maxUsableThreads c2) $+ \threads-> let (configuration, c1', c2', parallel) = optimalTwoParallelConfigurations threads c1 c2+ consumeJoin source = do (if parallel then pipeP else pipe)+ (\sink1-> pipe (tee source sink1) (consume c2'))+ (consume c1')+ return ()+ in (configuration, consumeJoin)+ sequence c1 c2 = liftConsumer "sequence" (maxUsableThreads c1 `max` maxUsableThreads c2) $+ \threads-> let (configuration, c1', c2') = optimalTwoSequentialConfigurations threads c1 c2+ consumeJoin source = pipe+ (\buffer-> pipe (tee source buffer) (consume c1'))+ getList+ >>= \(_, list)-> pipe (putList list) (consume c2')+ >> return ()+ in (configuration, consumeJoin)++instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)+ => JoinableComponentPair TransducerType TransducerType TransducerType m [x] [y] (Transducer m x y) (Transducer m x y) (Transducer m x y)+ where join t1 t2 = liftTransducer "join" (maxUsableThreads t1 + maxUsableThreads t2) $+ \threads-> let (configuration, t1', t2', parallel) = optimalTwoParallelConfigurations threads t1 t2+ transduce' source sink = pipe+ (\buffer-> (if parallel then pipeP else pipe)+ (\sink1-> pipe+ (\sink2-> tee source sink1 sink2)+ (\src-> transduce t2' src buffer))+ (\source-> transduce t1' source sink))+ getList+ >>= \(_, list)-> putList list sink+ >> getList source+ in (configuration, transduce')+ sequence t1 t2 = liftTransducer "sequence" (maxUsableThreads t1 `max` maxUsableThreads t2) $+ \threads-> let (configuration, t1', t2') = optimalTwoSequentialConfigurations threads t1 t2+ transduce' source sink = pipe+ (\buffer-> pipe+ (tee source buffer)+ (\source-> transduce t1 source sink))+ getList+ >>= \((extra, _), list)-> pipe+ (putList list)+ (\source-> transduce t2 source sink)+ >> return extra+ in (configuration, transduce')+++instance forall m r1 r2. ParallelizableMonad m+ => JoinableComponentPair (PerformerType r1) (PerformerType r2) (PerformerType r2) m () () (Performer m r1) (Performer m r2) (Performer m r2)+ where join p1 p2 = liftPerformer "join" (maxUsableThreads p1 + maxUsableThreads p2) $+ \threads-> let (configuration, p1', p2', parallel) = optimalTwoParallelConfigurations threads p1 p2+ in (configuration, if parallel then liftM snd $ perform p1' `parallelize` perform p2'+ else perform p1' >> perform p2')+ sequence p1 p2 = liftPerformer "sequence" (maxUsableThreads p1 `max` maxUsableThreads p2) $+ \threads-> let (configuration, p1', p2') = optimalTwoSequentialConfigurations threads p1 p2+ in (configuration, perform p1' >> perform p2')++instance forall m x r1 r2. (ParallelizableMonad m, Typeable x)+ => JoinableComponentPair (PerformerType r1) (ProducerType r2) (ProducerType r2) m () [x] (Performer m r1) (Producer m x r2) (Producer m x r2)+ where join pe pr = liftProducer "join" (maxUsableThreads pe + maxUsableThreads pr) $+ \threads-> let (configuration, pe', pr', parallel) = optimalTwoParallelConfigurations threads pe pr+ produceJoin sink = if parallel then liftM snd (perform pe' `parallelize` produce pr' sink)+ else perform pe' >> produce pr' sink+ in (configuration, produceJoin)+ sequence pe pr = liftProducer "sequence" (maxUsableThreads pe `max` maxUsableThreads pr) $+ \threads-> let (configuration, pe', pr') = optimalTwoSequentialConfigurations threads pe pr+ produceJoin sink = perform pe' >> produce pr' sink+ in (configuration, produceJoin)++instance forall m x r1 r2. (ParallelizableMonad m, Typeable x)+ => JoinableComponentPair (ProducerType r1) (PerformerType r2) (ProducerType r2) m () [x] (Producer m x r1) (Performer m r2) (Producer m x r2)+ where join pr pe = liftProducer "join" (maxUsableThreads pr + maxUsableThreads pe) $+ \threads-> let (configuration, pr', pe', parallel) = optimalTwoParallelConfigurations threads pr pe+ produceJoin sink = if parallel then liftM snd (produce pr' sink `parallelize` perform pe')+ else produce pr' sink >> perform pe'+ in (configuration, produceJoin)+ sequence pr pe = liftProducer "sequence" (maxUsableThreads pr `max` maxUsableThreads pe) $+ \threads-> let (configuration, pr', pe') = optimalTwoSequentialConfigurations threads pr pe+ produceJoin sink = produce pr' sink >> perform pe'+ in (configuration, produceJoin)++instance forall m x r1 r2. (ParallelizableMonad m, Typeable x)+ => JoinableComponentPair (PerformerType r1) (ConsumerType r2) (ConsumerType r2) m [x] () (Performer m r1) (Consumer m x r2) (Consumer m x r2)+ where join p c = liftConsumer "join" (maxUsableThreads p + maxUsableThreads c) $+ \threads-> let (configuration, p', c', parallel) = optimalTwoParallelConfigurations threads p c+ consumeJoin source = if parallel then liftM snd (perform p' `parallelize` consume c' source)+ else perform p' >> consume c' source+ in (configuration, consumeJoin)+ sequence p c = liftConsumer "sequence" (maxUsableThreads p `max` maxUsableThreads c) $+ \threads-> let (configuration, p', c') = optimalTwoSequentialConfigurations threads p c+ consumeJoin source = perform p' >> consume c' source+ in (configuration, consumeJoin)++instance forall m x r1 r2. (ParallelizableMonad m, Typeable x)+ => JoinableComponentPair (ConsumerType r1) (PerformerType r2) (ConsumerType r2) m [x] () (Consumer m x r1) (Performer m r2) (Consumer m x r2)+ where join c p = liftConsumer "join" (maxUsableThreads c + maxUsableThreads p) $+ \threads-> let (configuration, c', p', parallel) = optimalTwoParallelConfigurations threads c p+ consumeJoin source = if parallel then liftM snd (consume c' source `parallelize` perform p')+ else consume c' source >> perform p'+ in (configuration, consumeJoin)+ sequence c p = liftConsumer "sequence" (maxUsableThreads c `max` maxUsableThreads p) $+ \threads-> let (configuration, c', p') = optimalTwoSequentialConfigurations threads c p+ consumeJoin source = consume c' source >> perform p'+ in (configuration, consumeJoin)++instance forall m x y r. (ParallelizableMonad m, Typeable x, Typeable y)+ => JoinableComponentPair (PerformerType r) TransducerType TransducerType m [x] [y] (Performer m r) (Transducer m x y) (Transducer m x y)+ where join p t = liftTransducer "join" (maxUsableThreads p + maxUsableThreads t) $+ \threads-> let (configuration, p', t', parallel) = optimalTwoParallelConfigurations threads p t+ join' source sink = if parallel then liftM snd (perform p'+ `parallelize` transduce t' source sink)+ else perform p' >> transduce t' source sink+ in (configuration, join')+ sequence p t = liftTransducer "sequence" (maxUsableThreads p `max` maxUsableThreads t) $+ \threads-> let (configuration, p', t') = optimalTwoSequentialConfigurations threads p t+ join' source sink = perform p' >> transduce t' source sink+ in (configuration, join')++instance forall m x y r. (ParallelizableMonad m, Typeable x, Typeable y)+ => JoinableComponentPair TransducerType (PerformerType r) TransducerType m [x] [y] (Transducer m x y) (Performer m r) (Transducer m x y)+ where join t p = liftTransducer "join" (maxUsableThreads t + maxUsableThreads p) $+ \threads-> let (configuration, t', p', parallel) = optimalTwoParallelConfigurations threads t p+ join' source sink = if parallel then liftM fst (transduce t' source sink+ `parallelize` perform p')+ else do result <- transduce t' source sink+ perform p'+ return result+ in (configuration, join')+ sequence t p = liftTransducer "sequence" (maxUsableThreads t `max` maxUsableThreads p) $+ \threads-> let (configuration, t', p') = optimalTwoSequentialConfigurations threads t p+ join' source sink = do result <- transduce t' source sink+ perform p'+ return result+ in (configuration, join')++instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)+ => JoinableComponentPair (ProducerType ()) TransducerType TransducerType m [x] [y] (Producer m y ()) (Transducer m x y) (Transducer m x y)+ where join p t = liftTransducer "join" (maxUsableThreads p + maxUsableThreads t) $+ \threads-> let (configuration, p', t', parallel) = optimalTwoParallelConfigurations threads p t+ join' source sink = if parallel+ then do ((_, rest), out) <- pipe+ (\buffer-> produce p' sink `parallelize`+ transduce t' source buffer)+ getList+ putList out sink+ return rest + else produce p' sink >> transduce t' source sink+ in (configuration, join')+ sequence p t = liftTransducer "sequence" (maxUsableThreads p `max` maxUsableThreads t) $+ \threads-> let (configuration, p', t') = optimalTwoSequentialConfigurations threads p t+ join' source sink = produce p' sink >> transduce t' source sink+ in (configuration, join')++instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)+ => JoinableComponentPair TransducerType (ProducerType ()) TransducerType m [x] [y] (Transducer m x y) (Producer m y ()) (Transducer m x y)+ where join t p = liftTransducer "join" (maxUsableThreads t `max` maxUsableThreads p) $+ \threads-> let (configuration, t', p', parallel) = optimalTwoParallelConfigurations threads t p+ join' source sink = if parallel+ then do ((rest, ()), out) <- pipe+ (\buffer-> transduce t' source sink+ `parallelize` produce p' buffer)+ getList+ putList out sink+ return rest + else do result <- transduce t' source sink+ produce p' sink+ return result+ in (configuration, join')+ sequence t p = liftTransducer "sequence" (maxUsableThreads t `max` maxUsableThreads p) $+ \threads-> let (configuration, t', p') = optimalTwoSequentialConfigurations threads t p+ join' source sink = do result <- transduce t' source sink+ produce p' sink+ return result+ in (configuration, join')++instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)+ => JoinableComponentPair (ConsumerType ()) TransducerType TransducerType m [x] [y] (Consumer m x ()) (Transducer m x y) (Transducer m x y)+ where join c t = liftTransducer "join" (maxUsableThreads c + maxUsableThreads t) $+ \threads-> let (configuration, c', t', parallel) = optimalTwoParallelConfigurations threads c t+ join' source sink = liftM (snd . fst) $+ (if parallel then pipeP else pipe)+ (\sink1-> pipe+ (tee source sink1)+ (\source-> transduce t' source sink))+ (consume c')+ in (configuration, join')+ sequence c t = liftTransducer "sequence" (maxUsableThreads c `max` maxUsableThreads t) $+ \threads-> let (configuration, c', t') = optimalTwoSequentialConfigurations threads c t+ sequence' source sink = pipe+ (\buffer-> pipe+ (tee source buffer)+ (consume c'))+ getList+ >>= \((rest, _), list)-> pipe+ (putList list)+ (\source-> transduce t' source sink)+ >> return rest+ in (configuration, sequence')++instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)+ => JoinableComponentPair TransducerType (ConsumerType ()) TransducerType m [x] [y] (Transducer m x y) (Consumer m x ()) (Transducer m x y)+ where join t c = join c t+ sequence t c = liftTransducer "sequence" (maxUsableThreads t `max` maxUsableThreads c) $+ \threads-> let (configuration, t', c') = optimalTwoSequentialConfigurations threads t c+ sequence' source sink = pipe+ (\buffer-> pipe+ (tee source buffer)+ (\source-> transduce t' source sink))+ getList+ >>= \((rest, _), list)-> pipe+ (putList list)+ (consume c')+ >> return rest+ in (configuration, sequence')++instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)+ => JoinableComponentPair (ProducerType ()) (ConsumerType ()) TransducerType m [x] [y] (Producer m y ()) (Consumer m x ()) (Transducer m x y)+ where join p c = liftTransducer "sequence" (maxUsableThreads p + maxUsableThreads c) $+ \threads-> let (configuration, p', c', parallel) = optimalTwoParallelConfigurations threads p c+ join' source sink = if parallel then produce p' sink >> consume c' source >> return []+ else parallelize (produce p' sink) (consume c' source) >> return []+ in (configuration, join')+ sequence p c = liftTransducer "sequence" (maxUsableThreads p `max` maxUsableThreads c) $+ \threads-> let (configuration, p', c') = optimalTwoSequentialConfigurations threads p c+ join' source sink = produce p' sink >> consume c' source >> return []+ in (configuration, join')++instance forall m x y. (ParallelizableMonad m, Typeable x, Typeable y)+ => JoinableComponentPair (ConsumerType ()) (ProducerType ()) TransducerType m [x] [y] (Consumer m x ()) (Producer m y ()) (Transducer m x y)+ where join c p = join p c+ sequence c p = liftTransducer "sequence" (maxUsableThreads c `max` maxUsableThreads p) $+ \threads-> let (configuration, c', p') = optimalTwoSequentialConfigurations threads c p+ join' source sink = consume c' source >> produce p' sink >> return []+ in (configuration, join')++-- | Combinator 'prepend' converts the given producer to transducer that passes all its input through unmodified, except+-- | for prepending the output of the argument producer to it.+-- | 'prepend' /prefix/ = 'join' ('substitute' /prefix/) 'asis'+prepend :: forall m x r. (Monad m, Typeable x) => Producer m x r -> Transducer m x x+prepend prefix = liftTransducer "prepend" (maxUsableThreads prefix) $+ \threads-> let prefix' = usingThreads threads prefix+ prepend' source sink = produce prefix' sink >> pour source sink >> return []+ in (ComponentConfiguration [AnyComponent prefix] threads (cost prefix'), prepend')++-- | Combinator 'append' converts the given producer to transducer that passes all its input through unmodified, finally+-- | appending to it the output of the argument producer.+-- | 'append' /suffix/ = 'join' 'asis' ('substitute' /suffix/)+append :: forall m x r. (Monad m, Typeable x) => Producer m x r -> Transducer m x x+append suffix = liftTransducer "append" (maxUsableThreads suffix) $+ \threads-> let suffix' = usingThreads threads suffix+ append' source sink = pour source sink >> produce suffix' sink >> return []+ in (ComponentConfiguration [AnyComponent suffix] threads (cost suffix'), append')++-- | The 'substitute' combinator converts its argument producer to a transducer that produces the same output, while+-- | consuming its entire input and ignoring it.+substitute :: forall m x y r. (Monad m, Typeable x, Typeable y) => Producer m y r -> Transducer m x y+substitute feed = liftTransducer "substitute" (maxUsableThreads feed) $+ \threads-> let feed' = usingThreads threads feed+ substitute' source sink = consumeAndSuppress source >> produce feed' sink >> return []+ in (ComponentConfiguration [AnyComponent feed] threads (cost feed'), substitute')++-- | The 'snot' (streaming not) combinator simply reverses the outputs of the argument splitter.+-- In other words, data that the argument splitter sends to its /true/ sink goes to the /false/ sink of the result, and vice versa.+snot :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x+snot splitter = liftSectionSplitter "not" (maxUsableThreads splitter) $+ \threads-> let splitter' = usingThreads threads splitter+ not source true false = splitSections splitter source false true+ in (ComponentConfiguration [AnyComponent splitter'] threads (cost splitter'), not)++-- | The '>&' combinator sends the /true/ sink output of its left operand to the input of its right operand for further+-- splitting. Both operands' /false/ sinks are connected to the /false/ sink of the combined splitter, but any input+-- value to reach the /true/ sink of the combined component data must be deemed true by both splitters.+(>&) :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x -> Splitter m x+s1 >& s2 = liftSimpleSplitter ">&" (maxUsableThreads s1 + maxUsableThreads s2) $+ \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2+ s source true false = liftM fst $+ (if parallel then pipeP else pipe)+ (\true-> split s1 source true false)+ (\source-> split s2 source true false)+ in (configuration, s)++-- | A '>|' combinator's input value can reach its /false/ sink only by going through both argument splitters' /false/+-- sinks.+(>|) :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x -> Splitter m x+s1 >| s2 = liftSimpleSplitter ">|" (maxUsableThreads s1 + maxUsableThreads s2) $+ \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2+ s source true false = liftM fst $+ (if parallel then pipeP else pipe)+ (split s1 source true)+ (\source-> split s2 source true false)+ in (configuration, s)++-- | Combinator '&&' is a pairwise logical conjunction of two splitters run in parallel on the same input.+(&&) :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x -> Splitter m x+(&&) = zipSplittersWith (Prelude.&&)++-- | Combinator '||' is a pairwise logical disjunction of two splitters run in parallel on the same input.+(||) :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x -> Splitter m x+(||) = zipSplittersWith (Prelude.||)++ifs :: (ParallelizableMonad m, Typeable x, BranchComponent cc m x [x]) => Splitter m x -> cc -> cc -> cc+ifs s = combineBranches "if" (cost s) (\ parallel c1 c2 -> \source-> liftM fst3 $ splitConsumer "ifs" parallel s c1 c2 source)++wherever :: (ParallelizableMonad m, Typeable x) => Transducer m x x -> Splitter m x -> Transducer m x x+wherever t s = liftTransducer "wherever" (maxUsableThreads s + maxUsableThreads t) $+ \threads-> let (configuration, s', t', parallel) = optimalTwoParallelConfigurations threads s t+ wherever' source sink = liftM fst3 $ splitConsumer "wherever" parallel s+ (\source-> transduce t source sink)+ (\source-> pour source sink)+ source+ in (configuration, wherever')++unless :: (ParallelizableMonad m, Typeable x) => Transducer m x x -> Splitter m x -> Transducer m x x+unless t s = liftTransducer "unless" (maxUsableThreads s + maxUsableThreads t) $+ \threads-> let (configuration, s', t', parallel) = optimalTwoParallelConfigurations threads s t+ unless' source sink = liftM fst3 $ splitConsumer "unless" parallel s+ (\source-> pour source sink)+ (\source-> transduce t source sink)+ source+ in (configuration, unless')++select :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Transducer m x x+select s = liftTransducer "select" (maxUsableThreads s) $+ \threads-> let s' = usingThreads threads s+ transduce' source sink = liftM fst3 $ splitConsumer "select" False s'+ (\source-> pour source sink)+ consumeAndSuppress+ source+ in (ComponentConfiguration [AnyComponent s'] threads (cost s' + 1), transduce')++-- | The recursive combinator 'while' feeds the true sink of the argument splitter back to itself, modified by the+-- argument transducer. Data fed to the splitter's false sink is passed on unmodified.+while :: (ParallelizableMonad m, Typeable x) => Transducer m x x -> Splitter m x -> Transducer m x x+while t s = liftTransducer "while" (maxUsableThreads t + maxUsableThreads s) $+ \threads-> let (configuration, s', while'', parallel) = optimalTwoParallelConfigurations threads s while'+ transduce' source sink = liftM fst3 $ splitConsumer "while" parallel s'+ (\source-> transduce while' source sink)+ (\source-> pour source sink)+ source+ while' = t >-> while t s+ in (configuration, transduce')++-- | The recursive combinator 'nestedIn' combines two splitters into a mutually recursive loop acting as a single splitter.+-- The true sink of one of the argument splitters and false sink of the other become the true and false sinks of the loop.+-- The other two sinks are bound to the other splitter's source.+-- The use of 'nestedIn' makes sense only on hierarchically structured streams. If we gave it some input containing+-- a flat sequence of values, and assuming both component splitters are deterministic and stateless,+-- a value would either not loop at all or it would loop forever.+nestedIn :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x -> Splitter m x+nestedIn s1 s2 = liftSimpleSplitter "nestedIn" (maxUsableThreads s1 + maxUsableThreads s2) $+ \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2+ s source true false = liftM fst $+ (if parallel then pipeP else pipe)+ (\false-> split s1' source true false)+ (\source-> pipe (\true-> split s2' source true false)+ (\source-> split (nestedIn s1' s2') source true false))+ in (configuration,s)++-- | The 'foreach' combinator is similar to the combinator 'ifs' in that it combines a splitter and two transducers into+-- another transducer. However, in this case the transducers are re-instantiated for each consecutive portion of the+-- input as the splitter chunks it up. Each contiguous portion of the input that the splitter sends to one of its two+-- sinks gets transducered through the appropriate argument transducer as that transducer's whole input. As soon as the+-- contiguous portion is finished, the transducer gets terminated.+foreach :: (ParallelizableMonad m, Typeable x, BranchComponent cc m x [x]) => Splitter m x -> cc -> cc -> cc+foreach s = combineBranches "foreach" (cost s)+ (\ parallel c1 c2 source-> liftM fst $ (if parallel then pipeP else pipe)+ (transduce (splitterToMarker s) source)+ (\source-> groupMarks source (\b-> if b then c1 else c2)))++-- | The 'having' combinator combines two pure splitters into a pure splitter. One splitter is used to chunk the input+-- into contiguous portions. Its /false/ sink is routed directly to the /false/ sink of the combined splitter. The+-- second splitter is instantiated and run on each portion of the input that goes to first splitter's /true/ sink. If+-- the second splitter sends any output at all to its /true/ sink, the whole input portion is passed on to the /true/+-- sink of the combined splitter, otherwise it goes to its /false/ sink.+having :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x -> Splitter m x+having s1 s2 = liftSectionSplitter "having" (maxUsableThreads s1 + maxUsableThreads s2) $+ \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2+ s source true false = liftM fst $+ (if parallel then pipeP else pipe)+ (transduce (splitterToMarker s1') source)+ (\source-> groupMarks source (\b chunk-> if b then test chunk+ else pourMaybe chunk false))+ where test chunk = pipe (\sink1-> pipe (tee chunk sink1) getList)+ (\chunk-> pipe (\sink-> suppressProducer (split s2' chunk sink)) getList)+ >>= \(([], chunk), (_, truePart))-> let chunk' = if null chunk+ then [Nothing]+ else map Just chunk+ in (if null truePart+ then putList chunk' false+ else putList chunk' true)+ >> return ()+ in (configuration, s)++-- | The 'havingOnly' combinator is analogous to the 'having' combinator, but it succeeds and passes each chunk of the+-- input to its /true/ sink only if the second splitter sends no part of it to its /false/ sink.+havingOnly :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x -> Splitter m x+havingOnly s1 s2 = liftSectionSplitter "havingOnly" (maxUsableThreads s1 + maxUsableThreads s2) $+ \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2+ s source true false = liftM fst $+ (if parallel then pipeP else pipe)+ (transduce (splitterToMarker s1') source)+ (\source-> groupMarks source (\b chunk-> if b then test chunk+ else pourMaybe chunk false))+ where test chunk = pipe (\sink1-> pipe (tee chunk sink1) getList)+ (\chunk-> pipe (\sink-> suppressProducer+ (\suppress-> split s2' chunk suppress sink))+ getList)+ >>= \(([], chunk), (_, falsePart))-> let chunk' = if null chunk+ then [Nothing]+ else map Just chunk+ in (if null falsePart+ then putList chunk' true+ else putList chunk' false)+ >> return ()+ in (configuration, s)++-- | The result of combinator 'first' behaves the same as the argument splitter up to and including the first portion of+-- the input which goes into the argument's /true/ sink. All input following the first true portion goes into the+-- /false/ sink.+first :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x+first splitter = liftSectionSplitter "first" (maxUsableThreads splitter) $+ \threads-> let splitter' = usingThreads threads splitter+ configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)+ s source true false = liftM (\(x, y)-> y ++ x) $+ pipeD "first" (transduce (splitterToMarker splitter') source)+ (\source-> let get1 (x, False) = p false x get1+ get1 (x, True) = p true x get2+ get2 (x, True) = p true x get2+ get2 (x, False) = p false x get3+ get3 (x, _) = p false x get3+ p sink x succeed = put sink x+ >>= cond (get source+ >>= maybe (return []) succeed)+ (return $ maybe [] (:[]) x)+ in get source >>= maybe (return []) get1)+ in (configuration, s)++-- | The result of combinator 'uptoFirst' takes all input up to and including the first portion of the input which goes+-- into the argument's /true/ sink and feeds it to the result splitter's /true/ sink. All the rest of the input goes+-- into the /false/ sink. The only difference between 'last' and 'lastAndAfter' combinators is in where they direct the+-- /false/ portion of the input preceding the first /true/ part.+uptoFirst :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x+uptoFirst splitter = liftSectionSplitter "uptoFirst" (maxUsableThreads splitter) $+ \threads-> let splitter' = usingThreads threads splitter+ configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)+ s source true false = liftM (\(x, y)-> concatMap (maybe [] (:[])) y ++ x) $+ pipeD "uptoFirst" (transduce (splitterToMarker splitter') source)+ (\source-> let get1 q (x, False) = let q' = q |> x+ in get source+ >>= maybe+ (putQueue q' false)+ (get1 q')+ get1 q p@(x, True) = putQueue q true+ >>= whenNull (get2 p)+ get2 (x, True) = p true x get2+ get2 (x, False) = p false x get3+ get3 (x, _) = p false x get3+ p sink x succeed = put sink x+ >>= cond (get source+ >>= maybe (return []) succeed)+ (return [x])+ in get source >>= maybe (return []) (get1 Seq.empty))+ in (configuration, s)++-- | The result of the combinator 'last' is a splitter which directs all input to its /false/ sink, up to the last+-- portion of the input which goes to its argument's /true/ sink. That portion of the input is the only one that goes to+-- the resulting component's /true/ sink. The splitter returned by the combinator 'last' has to buffer the previous two+-- portions of its input, because it cannot know if a true portion of the input is the last one until it sees the end of+-- the input or another portion succeeding the previous one.+last :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x+last splitter = liftSectionSplitter "last" (maxUsableThreads splitter) $+ \threads-> let splitter' = usingThreads threads splitter+ configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)+ s source true false = liftM (\(x, y)-> concatMap (maybe [] (:[])) y ++ x) $+ pipeD "last" (transduce (splitterToMarker splitter') source)+ (\source-> let get1 (x, False) = put false x+ >>= cond (get source+ >>= maybe (return []) get1)+ (return [x])+ get1 p@(x, True) = get2 Seq.empty p+ get2 q (x, True) = let q' = q |> x+ in get source+ >>= maybe+ (putQueue q' true)+ (get2 q')+ get2 q p@(x, False) = get3 q Seq.empty p+ get3 qt qf (x, False) = let qf' = qf |> x+ in get source+ >>= maybe+ (putQueue qt true+ >> putQueue qf' false)+ (get3 qt qf')+ get3 qt qf p@(x, True) = do rest1 <- putQueue qt false+ rest2 <- putQueue qf false + if null rest1 Prelude.&& null rest2+ then get2 Seq.empty p+ else return (rest1 ++ rest2)+ p succeed = get source >>= maybe (return []) succeed+ in p get1)+ in (configuration, s)++-- | The result of the combinator 'lastAndAfter' is a splitter which directs all input to its /false/ sink, up to the+-- last portion of the input which goes to its argument's /true/ sink. That portion and the remainder of the input is fed+-- to the resulting component's /true/ sink. The difference between 'last' and 'lastAndAfter' combinators is where they+-- feed the /false/ portion of the input, if any, remaining after the last /true/ part.+lastAndAfter :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x+lastAndAfter splitter = liftSectionSplitter "lastAndAfter" (maxUsableThreads splitter) $+ \threads-> let splitter' = usingThreads threads splitter+ configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)+ s source true false = liftM (\(x, y)-> concatMap (maybe [] (:[])) y ++ x) $+ pipeD "lastAndAfter" (transduce (splitterToMarker splitter') source)+ (\source-> let get1 (x, False) = put false x+ >>= cond (p get1) (return [x])+ get1 p@(x, True) = get2 Seq.empty p+ get2 q (x, True) = let q' = q |> x+ in get source+ >>= maybe+ (putQueue q' true)+ (get2 q')+ get2 q p@(x, False) = get3 q p+ get3 q (x, False) = let q' = q |> x+ in get source+ >>= maybe+ (putQueue q' true)+ (get3 q')+ get3 q p@(x, True) = putQueue q false+ >>= whenNull (get1 p)+ p succeed = get source >>= maybe (return []) succeed+ in p get1)+ in (configuration, s)++-- | The 'prefix' combinator feeds its /true/ sink only the prefix of the input that its argument feeds to its /true/ sink.+-- All the rest of the input is dumped into the /false/ sink of the result.+prefix :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x+prefix splitter = liftSectionSplitter "prefix" (maxUsableThreads splitter) $+ \threads-> let splitter' = usingThreads threads splitter+ configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)+ s source true false = liftM (\(x, y)-> y ++ x) $+ pipeD "prefix" (transduce (splitterToMarker splitter') source)+ (\source-> let get1 (x, False) = p false x get2+ get1 (x, True) = p true x get1+ get2 (x, _) = p false x get2+ p sink x succeed = put sink x+ >>= cond (get source+ >>= maybe (return []) succeed)+ (return $ maybe [] (:[]) x)+ in get source >>= maybe (return []) get1)+ in (configuration, s)++-- | The 'suffix' combinator feeds its /true/ sink only the suffix of the input that its argument feeds to its /true/ sink.+-- All the rest of the input is dumped into the /false/ sink of the result.+suffix :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x+suffix splitter = liftSectionSplitter "suffix" (maxUsableThreads splitter) $+ \threads-> let splitter' = usingThreads threads splitter+ configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)+ s source true false = liftM (\(x, y)-> concatMap (maybe [] (:[])) y ++ x) $+ pipeD "suffix" (transduce (splitterToMarker splitter') source)+ (\source-> let get1 (x, False) = put false x >>= cond (p get1) (return [x])+ get1 (x, True) = get2 (Seq.singleton x)+ get2 q = get source+ >>= maybe (putQueue q true) (get3 q)+ get3 q (x, True) = get2 (q |> x)+ get3 q p@(x, False) = putQueue q false >>= whenNull (get1 p)+ p succeed = get source >>= maybe (return []) succeed+ in p get1)+ in (configuration, s)++-- | The 'even' combinator takes every input section that its argument splitters deems /true/, and feeds even ones into+-- its /true/ sink. The odd sections and parts of input that are /false/ according to its argument splitter are fed to+-- 'even' splitter's /false/ sink.+even :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x+even splitter = liftSectionSplitter "even" (maxUsableThreads splitter) $+ \threads-> let splitter' = usingThreads threads splitter+ configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)+ s source true false = liftM (\(x, y)-> concatMap (maybe [] (:[])) y ++ x) $+ pipeD "even"+ (transduce (splitterToMarker splitter') source)+ (\source-> let get1 (x, False) = put false x+ >>= cond (next get1) (return [x])+ get1 p@(x, True) = get2 p+ get2 (x, True) = put false x+ >>= cond (next get2) (return [x])+ get2 p@(x, False) = get3 p+ get3 (x, False) = put false x+ >>= cond (next get3) (return [x])+ get3 p@(x, True) = get4 p+ get4 (x, True) = put true x+ >>= cond (next get4) (return [x])+ get4 p@(x, False) = get1 p+ next g = get source >>= maybe (return []) g+ in next get1)+ in (configuration, s)++-- | Splitter 'startOf' issues an empty /true/ section at the beginning of every section considered /true/ by its+-- | argument splitter, otherwise the entire input goes into its /false/ sink.+startOf :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x+startOf splitter = liftSectionSplitter "startOf" (maxUsableThreads splitter) $+ \threads-> let splitter' = usingThreads threads splitter+ configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)+ s source true false = liftM (\(x, y)-> concatMap (maybe [] (:[])) y ++ x) $+ pipeD "startOf"+ (transduce (splitterToMarker splitter') source)+ (\source-> let get1 (x, False) = put false x+ >>= cond (next get1) (return [x])+ get1 p@(x, True) = put true Nothing >> get2 p+ get2 (x, True) = put false x+ >>= cond (next get2) (return [x])+ get2 p@(x, False) = get1 p+ next g = get source >>= maybe (return []) g+ in next get1)+ in (configuration, s)++-- | Splitter 'endOf' issues an empty /true/ section at the end of every section considered /true/ by its argument+-- | splitter, otherwise the entire input goes into its /false/ sink.+endOf :: (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x+endOf splitter = liftSectionSplitter "endOf" (maxUsableThreads splitter) $+ \threads-> let splitter' = usingThreads threads splitter+ configuration = ComponentConfiguration [AnyComponent splitter'] threads (cost splitter' + 2)+ s source true false = liftM (\(x, y)-> concatMap (maybe [] (:[])) y ++ x) $+ pipeD "endOf"+ (transduce (splitterToMarker splitter') source)+ (\source-> let get1 (x, False) = put false x+ >>= cond (next get1) (return [x])+ get1 p@(x, True) = get2 p+ get2 (x, True) = put false x+ >>= cond (next get2) (return [x])+ get2 p@(x, False) = put true Nothing >> get1 p+ next g = get source >>= maybe (return []) g+ in next get1)+ in (configuration, s)++-- | Combinator 'followedBy' treats its argument 'Splitter's as patterns components and returns a 'Splitter' that+-- matches their concatenation. A section of input is considered /true/ by the result iff its prefix is considered+-- /true/ by argument /s1/ and the rest of the section is considered /true/ by /s2/. The splitter /s2/ is started anew+-- after every section split to /true/ sink by /s1/.+followedBy :: forall m x. (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x -> Splitter m x+followedBy s1 s2 = liftSectionSplitter "followedBy" (maxUsableThreads s1 + maxUsableThreads s2) $+ \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2+ in (configuration, followedBy' parallel s1' s2')+ where followedBy' parallel s1 s2 source true false+ = liftM (\(x, y)-> concatMap (maybe [] (:[])) y ++ x) $+ (if parallel then pipeP else pipe)+ (transduce (splitterToMarker s1) source)+ (\source-> let get0 q = case Seq.viewl q+ of Seq.EmptyL -> get source >>= maybe (return []) get1+ (x, False) :< rest -> put false x+ >>= cond (get0 rest)+ (return $ Foldable.toList $ Seq.viewl $ fmap fst q)+ (x, True) :< rest -> get2 Seq.empty q+ get1 (x, False) = put false x+ >>= cond (get source >>= maybe (return []) get1)+ (return [x])+ get1 p@(x, True) = get2 Seq.empty (Seq.singleton p)+ get2 q q' = case Seq.viewl q'+ of Seq.EmptyL -> get source+ >>= maybe (testEnd q) (get2 q . Seq.singleton)+ (x, True) :< rest -> get2 (q |> x) rest+ (x, False) :< rest -> do ((q1, q2), n) <- pipeD "followedBy tail"+ (get3 Seq.empty q') (test q)+ case n of Nothing -> putQueue q false+ >>= whenNull (get0 (q1 >< q2))+ Just n -> do put false Nothing+ get0 (dropJust n q1 >< q2)+ get3 q1 q2 sink = canPut sink+ >>= cond (case Seq.viewl q2+ of Seq.EmptyL -> get source+ >>= maybe (return (q1, q2))+ (\p-> maybe (return True) (put sink) (fst p)+ >> get3 (q1 |> p) q2 sink)+ p :< rest -> maybe (return True) (put sink) (fst p)+ >> get3 (q1 |> p) rest sink)+ (return (q1, q2))+ testEnd q = do ((), n) <- pipeD "testEnd" (const $ return ()) (test q)+ case n of Nothing -> putQueue q false+ _ -> return []+ test q source = liftM snd $+ pipeD "follower"+ (transduce (splitterToMarker s2) source)+ (\source-> let get4 (_, False) = return Nothing+ get4 p@(_, True) = putQueue q true >> get5 0 p+ get5 n (x, False) = return (Just n)+ get5 n (Nothing, True) = get6 n+ get5 n (x, True) = put true x >> get6 (succ n)+ get6 n = get source+ >>= maybe+ (return $ Just n)+ (get5 n)+ in get source >>= maybe (return Nothing) get4)+ dropJust 0 q = q+ dropJust n q = case Seq.viewl q of (Nothing, _) :< rest -> dropJust n rest+ (Just _, _) :< rest -> dropJust (pred n) rest+ in get0 Seq.empty)++-- | Combinator '...' tracks the running balance of difference between the numbers of preceding inputs considered /true/+-- according to its first argument and the ones according to its second argument. The combinator passes to /true/ all+-- input values for which the difference balance is positive. This combinator is typically used with 'startOf' and+-- 'endOf' in order to count entire input sections and ignore their lengths.+(...) :: forall m x. (ParallelizableMonad m, Typeable x) => Splitter m x -> Splitter m x -> Splitter m x+s1 ... s2 = liftSectionSplitter "..." (maxUsableThreads s1 + maxUsableThreads s2) $+ \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2+ s source true false = liftM (\(x, y)-> concatMap (maybe [] (:[])) y ++ x) $+ (if parallel then pipeP else pipe)+ (transduce (splittersToPairMarker s1 s2) source)+ (\source-> let next n = get source >>= maybe (return []) (state n)+ pass n x = (if n > 0 then put true x else put false x)+ >>= cond (next n) (return [x])+ pass' n x = (if n >= 0 then put true x else put false x)+ >>= cond (next n) (return [x])+ state n (Left (x, True, False)) = pass (succ n) (Just x)+ state n (Left (x, False, True)) = pass' (pred n) (Just x)+ state n (Left (x, True, True)) = pass' n (Just x)+ state n (Left (x, False, False)) = pass n (Just x)+ state n (Right (Left True)) = pass (succ n) Nothing+ state n (Right (Right True)) = pass (pred n) Nothing+ state n (Right _) = next n+ in next 0)+ in (configuration, s)++-- Helper functions++type Marker m x = Transducer m x (Maybe x, Bool)++splitterToMarker :: forall m x. (ParallelizableMonad m, Typeable x) => Splitter m x -> Marker m x+splitterToMarker s = liftTransducer "splitterToMarker" (maxUsableThreads s) $+ \threads-> let s' = usingThreads threads s+ t source sink = liftM (\((x, y), z)-> z ++ y ++ x) $+ pipeD "splitterToMarker true"+ (\trueSink-> pipeD "splitterToMarker false"+ (splitSections s' source trueSink)+ (mark False))+ (mark True)+ where mark b source = canPut sink+ >>= cond (get source+ >>= maybe (return [])+ (\x-> put sink (x, b)+ >>= cond+ (mark b source)+ (return $ maybe [] (: []) x)))+ (return [])+ in (ComponentConfiguration [AnyComponent s'] threads (cost s' + 1), t)+++splittersToPairMarker :: forall m x. (ParallelizableMonad m, Typeable x)+ => Splitter m x -> Splitter m x -> Transducer m x (Either (x, Bool, Bool) (Either Bool Bool))+splittersToPairMarker s1 s2+ = liftTransducer "splittersToPairMarker" (maxUsableThreads s1 + maxUsableThreads s2) $+ \threads-> let (configuration, s1', s2', parallelize) = optimalTwoParallelConfigurations threads s1 s2+ t source sink = liftM (\((((((([], l1), l2), l3), l4), l5), l6), l7)-> l7 ++ l6 ++ l5 ++ l4 ++ l3 ++ l2 ++ l1) $+ pipeD "splittersToPairMarker synchronize"+ (\sync->+ pipeD "splittersToPairMarker true1"+ (\true1->+ pipeD "splittersToPairMarker false1"+ (\false1->+ pipeD "splittersToPairMarker true2"+ (\true2->+ pipeD "splittersToPairMarker false2"+ (\false2->+ pipeD "splittersToPairMarker sink1"+ (\sink1->+ (if parallelize then pipeP else pipe)+ (\sink2-> tee source sink1 sink2)+ (\source2-> splitSections s2 source2 true2 false2))+ (\source1-> splitSections s1 source1 true1 false1))+ (mark sync False False))+ (mark sync False True))+ (mark sync True False))+ (mark sync True True))+ (synchronizeMarks Nothing sink)+ synchronizeMarks :: Maybe (Seq (Maybe x, Bool), Bool)+ -> Sink c (Either (x, Bool, Bool) (Either Bool Bool)) -> Source c (Maybe x, Bool, Bool)+ -> Pipe c m [x]+ synchronizeMarks state sink source = get source+ >>= maybe+ (assert (isNothing state) (return []))+ (handleMark state sink source)+ handleMark :: Maybe (Seq (Maybe x, Bool), Bool)+ -> Sink c (Either (x, Bool, Bool) (Either Bool Bool)) -> Source c (Maybe x, Bool, Bool)+ -> (Maybe x, Bool, Bool) -> Pipe c m [x]+ handleMark Nothing sink source (x, pos, b)+ = case x of Nothing -> put sink (Right $ if pos then Left b else Right b)+ >> synchronizeMarks Nothing sink source+ _ -> synchronizeMarks (Just (Seq.singleton (x, b), pos)) sink source+ handleMark state@(Just (q, pos')) sink source mark@(x, pos, b)+ | pos == pos' = synchronizeMarks (Just (q |> (x, b), pos')) sink source+ | isNothing x = put sink (Right $ if pos then Left b else Right b)+ >> synchronizeMarks state sink source+ | otherwise = case Seq.viewl q+ of Seq.EmptyL -> synchronizeMarks (Just (Seq.singleton (x, b), pos)) sink source+ (Nothing, b') :< rest -> put sink (Right $ if pos then Right b' else Left b')+ >>= cond+ (handleMark+ (if Seq.null rest then Nothing else Just (rest, pos'))+ sink+ source+ mark)+ (returnQueuedList q)+ (Just y, b') :< rest -> put sink (Left $ if pos then (y, b, b') else (y, b', b))+ >>= cond+ (synchronizeMarks+ (if Seq.null rest then Nothing else Just (rest, pos'))+ sink+ source)+ (returnQueuedList q)+ returnQueuedList q = return $ concatMap (maybe [] (:[]) . fst) $ Foldable.toList $ Seq.viewl q+ mark sink first b source = let mark' = canPut sink+ >>= cond+ (get source+ >>= maybe+ (return [])+ (\x-> put sink (x, first, b)+ >>= cond mark' (return $ maybe [] (: []) x)))+ (return [])+ in mark'+ in (configuration, t)++pairMarkerToMaybePairMarker :: forall m x. (ParallelizableMonad m, Typeable x)+ => Transducer m x (Either (x, Bool, Bool) (Either Bool Bool)) -> Transducer m x (Maybe x, Bool, Bool)+pairMarkerToMaybePairMarker t = liftTransducer "pairMarkerToMaybePairMarker" (maxUsableThreads t + 1) $+ \threads-> let t's = usingThreads threads t+ t'p = usingThreads (threads - 1) t+ parallel = threads > 1 Prelude.&& cost t'p <= cost t's+ t' = if parallel then t'p else t's+ cost' = if parallel then (cost t'p `max` 1) + 1 else cost t's + 1+ transduce' source sink+ = liftM (\(x, y)-> y ++ x) $+ (if parallel then pipeP else pipe)+ (transduce t source)+ (\source-> let next state = get source >>= maybe (return []) state+ nextState2 l r d = get source+ >>= maybe (put sink (Nothing, l, r) >> return []) (state2 l r d)+ state0 (Left (x, l, r)) = put sink (Just x, l, r)+ >>= cond (next $ state1 l r) (return [x])+ state0 v@(Right d) = state2 False False d v+ state1 _ _ (Left (x, l, r)) = put sink (Just x, l, r)+ >>= cond (next $ state1 l r) (return [x])+ state1 l r v@(Right d) = state2 l r d v+ state2 l r Left{} (Right d@(Left l')) = nextState2 l' r d+ state2 l r Left{} (Right (Right r')) = put sink (Nothing, l, r')+ >>= cond (next $ state1 l r') (return [])+ state2 l r Left{} t@(Left (x, l', r')) | l == l' = state1 l r t+ | otherwise = put sink (Nothing, l, r)+ >>= cond+ (state1 l' r' t)+ (return [])+ state2 l r Right{} (Right d@(Right r')) = nextState2 l r' d+ state2 l r Right{} (Right (Left l')) = put sink (Nothing, l', r)+ >>= cond (next $ state1 l' r) (return [])+ state2 l r Right{} t@(Left (x, l', r')) | r == r' = state1 l r t+ | otherwise = put sink (Nothing, l, r)+ >>= cond+ (state1 l' r' t)+ (return [])+ in next state0)+ in (ComponentConfiguration [AnyComponent t'] threads cost', transduce')++zipSplittersWith :: (ParallelizableMonad m, Typeable x) => (Bool -> Bool -> Bool) -> Splitter m x -> Splitter m x -> Splitter m x+zipSplittersWith f s1 s2+ = liftSectionSplitter "zip" (maxUsableThreads s1 + maxUsableThreads s2) $+ \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2+ s source true false = liftM (\(x, y)-> y ++ x) $+ (if parallel then pipeP else pipe)+ (transduce (pairMarkerToMaybePairMarker $ splittersToPairMarker s1 s2) source)+ (\source-> let split = get source >>= maybe (return []) test+ test (x, b1, b2) = (if f b1 b2 then put true x else put false x)+ >>= cond split (return $ maybe [] (:[]) x)+ in split)+ in (configuration, s)++groupMarks :: forall c m x y z. (ParallelizableMonad m, Typeable x, Typeable y, Eq y)+ => Source c (Maybe x, y) -> (y -> Source c x -> Pipe c m z) -> Pipe c m ()+groupMarks source getConsumer = getSuccess source startNew+ where startNew (mx, y) = do (nextPair, _) <- pipeD "groupMarks" (\sink-> pass sink mx y) (getConsumer y)+ case nextPair of Just p -> startNew p+ Nothing -> return ()+ pass sink Nothing y = next sink y+ pass sink (Just x) y = put sink x >> next sink y+ next sink y = get source >>= maybe (return Nothing) (continue sink y)+ continue sink y (x, y') | y == y' = pass sink x y+ continue sink y p@(x, y') | y /= y' = return (Just p)++splitConsumer :: forall c m x r1 r2. (ParallelizableMonad m, Typeable x)+ => String -> Bool -> Splitter m x -> (Source c x -> Pipe c m r1) -> (Source c x -> Pipe c m r2)+ -> (Source c x -> Pipe c m ([x], r1, r2))+splitConsumer description parallel s trueConsumer falseConsumer = consumer'+ where consumer' source = (if parallel then pipeP else pipe)+ (\false-> pipeD (description ++ " true") (\true-> split s source true false) trueConsumer)+ falseConsumer+ >>= \((extra, r1), r2)-> return (extra, r1, r2)++splitConsumerSections :: forall m x r1 r2. (ParallelizableMonad m, Typeable x) =>+ String -> Splitter m x -> Consumer m (Maybe x) r1 -> Consumer m (Maybe x) r2 -> Consumer m x ([x], r1, r2)+splitConsumerSections description s trueConsumer falseConsumer+ = liftConsumer description (maxUsableThreads s + maxUsableThreads trueConsumer + maxUsableThreads falseConsumer) usingThreads+ where usingThreads :: Int -> (ComponentConfiguration, forall c. Source c x -> Pipe c m ([x], r1, r2))+ usingThreads threadCount = (configuration', consumer')+ where (configuration', (splitter', forkSplitter), (trueConsumer', forkTrue), (falseConsumer', forkFalse))+ = optimalThreeParallelConfigurations threadCount s trueConsumer falseConsumer+ consumer' source = (if forkFalse then pipeP else pipe)+ (\false-> (if forkTrue Prelude.|| forkSplitter then pipeP else pipe)+ (\true-> splitSections s source true false)+ (consume trueConsumer))+ (consume falseConsumer)+ >>= \((extra, r1), r2)-> return (extra, r1, r2)++putQueue :: forall c m x. (Monad m, Typeable x) => Seq x -> Sink c x -> Pipe c m [x]+putQueue q sink = putList (Foldable.toList (Seq.viewl q)) sink++getQueue :: forall c m x. (Monad m, Typeable x) => Source c x -> Pipe c m (Seq x)+getQueue source = let getOne q = get source >>= maybe (return q) (\x-> getOne (q |> x))+ in getOne Seq.empty++pourMaybe :: forall c x m. (Monad m, Typeable x) => Source c x -> Sink c (Maybe x) -> Pipe c m ()+pourMaybe source sink = pour0+ where pour0 = canPut sink >>= flip when (get source >>= maybe (put sink Nothing >> return ()) pass)+ pour1 = canPut sink >>= flip when (getSuccess source pass)+ pass x = put sink (Just x) >> pour1+++suppressProducer :: forall c m x r. (ParallelizableMonad m, Typeable x) => (Sink c x -> Pipe c m r) -> Pipe c m r+suppressProducer p = liftM fst $ pipeD "suppress" p consumeAndSuppress fst3 :: (a, b, c) -> a fst3 (a, b, c) = a
Control/Concurrent/SCC/ComponentTypes.hs view
@@ -14,100 +14,415 @@ <http://www.gnu.org/licenses/>. -} -{-# LANGUAGE ScopedTypeVariables, Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies,+ ExistentialQuantification, KindSignatures, Rank2Types, PatternSignatures #-} module Control.Concurrent.SCC.ComponentTypes- (-- * Types- Splitter(..), Transducer(..),+ (-- * Classes+ Component (..), BranchComponent (combineBranches),+ -- * Types+ AnyComponent (AnyComponent), Performer (..), Consumer (..), Producer(..), Splitter(..), Transducer(..),+ ComponentConfiguration(..), -- * Lifting functions- lift121Transducer, liftStatelessTransducer, liftFoldTransducer, liftStatefulTransducer,- liftSimpleSplitter, liftSectionSplitter, liftStatelessSplitter)+ liftPerformer, liftConsumer, liftAtomicConsumer, liftProducer, liftAtomicProducer,+ liftTransducer, liftAtomicTransducer, lift121Transducer, liftStatelessTransducer, liftFoldTransducer, liftStatefulTransducer,+ liftSimpleSplitter, liftSectionSplitter, liftAtomicSimpleSplitter, liftAtomicSectionSplitter, liftStatelessSplitter,+ -- * Utility functions+ showComponentTree, optimalTwoParallelConfigurations, optimalTwoSequentialConfigurations, optimalThreeParallelConfigurations+ ) where import Control.Concurrent.SCC.Foundation import Control.Monad (liftM, when)-import Data.Maybe (maybe)+import Data.List (minimumBy)+import Data.Maybe import Data.Typeable (Typeable, cast) +-- | 'AnyComponent' is an existential type wrapper around a 'Component'.+data AnyComponent = forall a. Component a => AnyComponent a++-- | The types of 'Component' class carry metadata and can be configured to use a specific number of threads.+class Component c where+ name :: c -> String+ -- | Returns the list of all children components.+ subComponents :: c -> [AnyComponent]+ -- | Returns the maximum number of threads that can be used by the component.+ maxUsableThreads :: c -> Int+ -- | Configures the component to use the specified number of threads. This function affects 'usedThreads', 'cost',+ -- and 'subComponents' methods of the result, while 'name' and 'maxUsableThreads' remain the same.+ usingThreads :: Int -> c -> c+ -- | The number of threads that the component is configured to use. By default the number is usually 1.+ usedThreads :: c -> Int+ -- | The cost of using the component as configured.+ cost :: c -> Int+ cost c = 1 + sum (map cost (subComponents c))++instance Component AnyComponent where+ name (AnyComponent c) = name c+ subComponents (AnyComponent c) = subComponents c+ maxUsableThreads (AnyComponent c) = maxUsableThreads c+ usingThreads n (AnyComponent c) = AnyComponent (usingThreads n c)+ usedThreads (AnyComponent c) = usedThreads c+ cost (AnyComponent c) = cost c++-- | Show details of the given component's configuration.+showComponentTree :: forall c. Component c => c -> String+showComponentTree c = showIndentedComponent 1 c++showIndentedComponent :: forall c. Component c => Int -> c -> String+showIndentedComponent depth c = showRightAligned 4 (cost c) ++ showRightAligned 3 (usedThreads c) ++ replicate depth ' '+ ++ name c ++ "\n"+ ++ concatMap (showIndentedComponent (succ depth)) (subComponents c)++showRightAligned :: Show x => Int -> x -> String+showRightAligned width x = let str = show x+ in replicate (width - length str) ' ' ++ str++data ComponentConfiguration = ComponentConfiguration {componentChildren :: [AnyComponent],+ componentThreads :: Int,+ componentCost :: Int}++-- | A component that performs a computation with no inputs nor outputs is a 'Performer'.+data Performer m r = Performer {performerName :: String,+ performerMaxThreads :: Int,+ performerConfiguration :: ComponentConfiguration,+ performerUsingThreads :: Int -> (ComponentConfiguration, forall c. Pipe c m r),+ perform :: forall c. Pipe c m r}++-- | A component that consumes values from a 'Source' is called 'Consumer'.+-- data Consumer m x r = Consumer {consumerData :: ComponentData (forall c. Source c x -> Pipe c m r),+-- consume :: forall c. Source c x -> Pipe c m r}+data Consumer m x r = Consumer {consumerName :: String,+ consumerMaxThreads :: Int,+ consumerConfiguration :: ComponentConfiguration,+ consumerUsingThreads :: Int -> (ComponentConfiguration, forall c. Source c x -> Pipe c m r),+ consume :: forall c. Source c x -> Pipe c m r}++-- | A component that produces values and puts them into a 'Sink' is called 'Producer'.+data Producer m x r = Producer {producerName :: String,+ producerMaxThreads :: Int,+ producerConfiguration :: ComponentConfiguration,+ producerUsingThreads :: Int -> (ComponentConfiguration, forall c. Sink c x -> Pipe c m r),+ produce :: forall c. Sink c x -> Pipe c m r}+ -- | The 'Transducer' type represents computations that transform data and return no result. -- A transducer must continue consuming the given source and feeding the sink while there is data.-newtype Monad m => Transducer m x y = Transducer {transduce :: forall c1 c2 context. Source c1 x -> Sink c2 y -> Pipe context m [x]}+data Transducer m x y = Transducer {transducerName :: String,+ transducerMaxThreads :: Int,+ transducerConfiguration :: ComponentConfiguration,+ transducerUsingThreads :: Int -> (ComponentConfiguration,+ forall c. Source c x -> Sink c y -> Pipe c m [x]),+ transduce :: forall c. Source c x -> Sink c y -> Pipe c m [x]} -- | The 'Splitter' type represents computations that distribute data acording to some criteria. A splitter should -- distribute only the original input data, and feed it into the sinks in the same order it has been read from the -- source. If the two sink arguments of a splitter are the same, the splitter must act as an identity transform.-data Monad m => Splitter m x = Splitter {split :: forall c1 c2 c3 context.- Source c1 x -> Sink c2 x -> Sink c3 x -> Pipe context m [x],- splitSections :: forall c1 c2 c3 context.- Source c1 x -> Sink c2 (Maybe x) -> Sink c3 (Maybe x)- -> Pipe context m [x]}+data Splitter m x = Splitter {splitterName :: String,+ splitterMaxThreads :: Int,+ splitterConfiguration :: ComponentConfiguration,+ splitterUsingThreads :: Int -> (ComponentConfiguration,+ forall c. Source c x -> Sink c x -> Sink c x -> Pipe c m [x],+ forall c. Source c x -> Sink c (Maybe x) -> Sink c (Maybe x)+ -> Pipe c m [x]),+ split :: forall c. Source c x -> Sink c x -> Sink c x -> Pipe c m [x],+ splitSections :: forall c. Source c x -> Sink c (Maybe x) -> Sink c (Maybe x) -> Pipe c m [x]} +instance Component (Performer m r) where+ name = performerName+ subComponents = componentChildren . performerConfiguration+ maxUsableThreads = performerMaxThreads+ usedThreads = componentThreads . performerConfiguration+ usingThreads threads performer = let (configuration', perform' :: forall c. Pipe c m r) = performerUsingThreads performer threads+ in performer{performerConfiguration= configuration', perform= perform'}+ cost = componentCost . performerConfiguration++instance Component (Consumer m x r) where+ name = consumerName+ subComponents = componentChildren . consumerConfiguration+ maxUsableThreads = consumerMaxThreads+ usedThreads = componentThreads . consumerConfiguration+ usingThreads threads consumer = let (configuration',+ consume' :: forall c. Source c x -> Pipe c m r) = consumerUsingThreads consumer threads+ in consumer{consumerConfiguration= configuration', consume= consume'}+ cost = componentCost . consumerConfiguration++instance Component (Producer m x r) where+ name = producerName+ subComponents = componentChildren . producerConfiguration+ maxUsableThreads = producerMaxThreads+ usedThreads = componentThreads . producerConfiguration+ usingThreads threads producer = let (configuration',+ produce' :: forall c. Sink c x -> Pipe c m r) = producerUsingThreads producer threads+ in producer{producerConfiguration= configuration', produce= produce'}+ cost = componentCost . producerConfiguration++instance Component (Transducer m x y) where+ name = transducerName+ subComponents = componentChildren . transducerConfiguration+ maxUsableThreads = transducerMaxThreads+ usedThreads = componentThreads . transducerConfiguration+ usingThreads threads transducer = let (configuration', transduce' :: forall c. Source c x -> Sink c y -> Pipe c m [x])+ = transducerUsingThreads transducer threads+ in transducer{transducerConfiguration= configuration', transduce= transduce'}+ cost = componentCost . transducerConfiguration++instance Component (Splitter m x) where+ name = splitterName+ subComponents = componentChildren . splitterConfiguration+ maxUsableThreads = splitterMaxThreads+ usedThreads = componentThreads . splitterConfiguration+ usingThreads threads splitter = let (configuration',+ split' :: forall c. Source c x -> Sink c x -> Sink c x -> Pipe c m [x],+ splitSections' :: forall c. Source c x -> Sink c (Maybe x) -> Sink c (Maybe x)+ -> Pipe c m [x])+ = splitterUsingThreads splitter threads+ in splitter{splitterConfiguration= configuration',+ split= split', splitSections= splitSections'}+ cost = componentCost . splitterConfiguration+++-- | 'BranchComponent' is a type class representing all components that can act as consumers, namely 'Consumer',+-- 'Transducer', and 'Splitter'.+class BranchComponent cc m x r | cc -> m x where+ -- | 'combineBranches' is used to combine two components in 'BranchComponent' class into one, using the+ -- given 'Consumer' binary combinator.+ combineBranches :: String -> Int+ -> (forall c. Bool -> (Source c x -> Pipe c m r) -> (Source c x -> Pipe c m r) -> (Source c x -> Pipe c m r))+ -> cc -> cc -> cc++instance forall m x r. Monad m => BranchComponent (Consumer m x r) m x r where+ combineBranches name cost combinator c1 c2 = liftConsumer name 1 $+ \threads-> (ComponentConfiguration [AnyComponent c1, AnyComponent c2] 1 cost,+ combinator False (consume c1) (consume c2))++instance forall m x. Monad m => BranchComponent (Consumer m x ()) m x [x] where+ combineBranches name cost combinator c1 c2 = liftConsumer name 1 $+ \threads-> (ComponentConfiguration [AnyComponent c1, AnyComponent c2] 1 cost,+ liftM (const ())+ . combinator False+ (\source-> consume c1 source >> return [])+ (\source-> consume c2 source >> return []))++instance forall m x y. BranchComponent (Transducer m x y) m x [x] where+ combineBranches name cost combinator t1 t2+ = liftTransducer name (maxUsableThreads t1 + maxUsableThreads t2) $+ \threads-> let (configuration, t1', t2', parallel) = optimalTwoParallelConfigurations threads t1 t2+ transduce' source sink = combinator parallel+ (\source-> transduce t1 source sink)+ (\source-> transduce t2 source sink)+ source+ in (configuration, transduce')++instance forall m x. (ParallelizableMonad m, Typeable x) => BranchComponent (Splitter m x) m x [x] where+ combineBranches name cost combinator s1 s2+ = liftSimpleSplitter name (maxUsableThreads s1 + maxUsableThreads s2) $+ \threads-> let (configuration, s1', s2', parallel) = optimalTwoParallelConfigurations threads s1 s2+ split' source true false = combinator parallel+ (\source-> split s1 source true false)+ (\source-> split s2 source true false)+ source+ in (configuration, split')++-- | Function 'liftPerformer' takes a component name, maximum number of threads it can use, and its 'usingThreads'+-- method, and returns a 'Performer' component.+liftPerformer :: String -> Int -> (Int -> (ComponentConfiguration, forall c. Pipe c m r)) -> Performer m r+liftPerformer name maxThreads usingThreads = case usingThreads 1+ of (configuration, perform) -> Performer name maxThreads configuration+ usingThreads perform++-- | Function 'liftConsumer' takes a component name, maximum number of threads it can use, and its 'usingThreads'+-- method, and returns a 'Consumer' component.+liftConsumer :: String -> Int -> (Int -> (ComponentConfiguration, forall c. Source c x -> Pipe c m r)) -> Consumer m x r+liftConsumer name maxThreads usingThreads = case usingThreads 1+ of (configuration, consume) -> Consumer name maxThreads configuration+ usingThreads consume++-- | Function 'liftProducer' takes a component name, maximum number of threads it can use, and its 'usingThreads'+-- method, and returns a 'Producer' component.+liftProducer :: String -> Int -> (Int -> (ComponentConfiguration, forall c. Sink c x -> Pipe c m r)) -> Producer m x r+liftProducer name maxThreads usingThreads = case usingThreads 1+ of (configuration, produce) -> Producer name maxThreads configuration+ usingThreads produce++-- | Function 'liftTransducer' takes a component name, maximum number of threads it can use, and its 'usingThreads'+-- method, and returns a 'Transducer' component.+liftTransducer :: String -> Int -> (Int -> (ComponentConfiguration, forall c. Source c x -> Sink c y -> Pipe c m [x]))+ -> Transducer m x y+liftTransducer name maxThreads usingThreads = case usingThreads 1+ of (configuration, transduce) -> Transducer name maxThreads configuration+ usingThreads transduce++-- | Function 'liftAtomicConsumer' lifts a single-threaded 'consume' function into a 'Consumer' component.+liftAtomicConsumer :: String -> Int -> (forall c. Source c x -> Pipe c m r) -> Consumer m x r+liftAtomicConsumer name cost consume = liftConsumer name 1 (\_threads-> (ComponentConfiguration [] 1 cost, consume))++-- | Function 'liftAtomicProducer' lifts a single-threaded 'produce' function into a 'Producer' component.+liftAtomicProducer :: String -> Int -> (forall c. Sink c x -> Pipe c m r) -> Producer m x r+liftAtomicProducer name cost produce = liftProducer name 1 (\_threads-> (ComponentConfiguration [] 1 cost, produce))++-- | Function 'liftAtomicTransducer' lifts a single-threaded 'transduce' function into a 'Transducer' component.+liftAtomicTransducer :: String -> Int -> (forall c. Source c x -> Sink c y -> Pipe c m [x]) -> Transducer m x y+liftAtomicTransducer name cost transduce = liftTransducer name 1 (\_threads-> (ComponentConfiguration [] 1 cost, transduce))+ -- | Function 'lift121Transducer' takes a function that maps one input value to one output value each, and lifts it into -- a 'Transducer'.-lift121Transducer :: (Monad m, Typeable x, Typeable y) => (x -> y) -> Transducer m x y-lift121Transducer f = Transducer (\source sink-> let t = canPut sink- >>= flip when (getSuccess source (\x-> put sink (f x) >> t))- in t >> return [])+lift121Transducer :: (Monad m, Typeable x, Typeable y) => String -> (x -> y) -> Transducer m x y+lift121Transducer name f = liftAtomicTransducer name 1 $+ \source sink-> let t = canPut sink+ >>= flip when (getSuccess source (\x-> put sink (f x) >> t))+ in t >> return [] -- | Function 'liftStatelessTransducer' takes a function that maps one input value into a list of output values, and -- lifts it into a 'Transducer'.-liftStatelessTransducer :: (Monad m, Typeable x, Typeable y) => (x -> [y]) -> Transducer m x y-liftStatelessTransducer f = Transducer (\source sink-> let t = canPut sink- >>= flip when (getSuccess source (\x-> putList (f x) sink >> t))- in t >> return [])+liftStatelessTransducer :: (Monad m, Typeable x, Typeable y) => String -> (x -> [y]) -> Transducer m x y+liftStatelessTransducer name f = liftAtomicTransducer name 1 $+ \source sink-> let t = canPut sink+ >>= flip when (getSuccess source (\x-> putList (f x) sink >> t))+ in t >> return []+ -- | Function 'liftFoldTransducer' creates a stateful transducer that produces only one output value after consuming the -- entire input. Similar to 'Data.List.foldl'-liftFoldTransducer :: (Monad m, Typeable x, Typeable y) => (y -> x -> y) -> y -> Transducer m x y-liftFoldTransducer f y0 = Transducer (\source sink-> let t y = canPut sink- >>= flip when (get source- >>= maybe (put sink y >> return ()) (t . f y))- in t y0 >> return [])+liftFoldTransducer :: (Monad m, Typeable x, Typeable y) => String -> (s -> x -> s) -> s -> (s -> y) -> Transducer m x y+liftFoldTransducer name f s0 w = liftAtomicTransducer name 1 $+ \source sink-> let t s = canPut sink+ >>= flip when (get source+ >>= maybe+ (put sink (w s) >> return ())+ (t . f s))+ in t s0 >> return [] -- | Function 'liftStatefulTransducer' constructs a 'Transducer' from a state-transition function and the initial -- state. The transition function may produce arbitrary output at any transition step.-liftStatefulTransducer :: (Monad m, Typeable x, Typeable y) => (state -> x -> (state, [y])) -> state -> Transducer m x y-liftStatefulTransducer f s0 = Transducer (\source sink-> let t s = canPut sink- >>= flip when (getSuccess source (\x-> let (s', ys) = f s x- in putList ys sink- >> t s'))- in t s0 >> return [])+liftStatefulTransducer :: (Monad m, Typeable x, Typeable y) => String -> (state -> x -> (state, [y])) -> state -> Transducer m x y+liftStatefulTransducer name f s0 = liftAtomicTransducer name 1 $+ \source sink-> let t s = canPut sink+ >>= flip when (getSuccess source+ (\x-> let (s', ys) = f s x+ in putList ys sink >> t s'))+ in t s0 >> return [] -- | Function 'liftStatelessSplitter' takes a function that assigns a Boolean value to each input item and lifts it into--- a 'Splitter'-liftStatelessSplitter :: (Monad m, Typeable x) => (x -> Bool) -> Splitter m x-liftStatelessSplitter f = liftSimpleSplitter (\source true false-> let s = get source- >>= maybe- (return [])- (\x-> (if f x- then put true x- else put false x)- >>= cond s (return [x]))- in s)+-- a 'Splitter'.+liftStatelessSplitter :: (ParallelizableMonad m, Typeable x) => String -> (x -> Bool) -> Splitter m x+liftStatelessSplitter name f = liftAtomicSimpleSplitter name 1 $+ \source true false-> let s = get source+ >>= maybe+ (return [])+ (\x-> (if f x+ then put true x+ else put false x)+ >>= cond s (return [x]))+ in s --- | Function 'liftSimpleSplitter' lifts a simple, non-sectioning splitter function into a full 'Splitter'-liftSimpleSplitter :: (Monad m, Typeable x) =>- (forall c1 c2 c3 context. Source c1 x -> Sink c2 x -> Sink c3 x -> Pipe context m [x]) -> Splitter m x-liftSimpleSplitter split = Splitter split splitSections- where splitSections source true false+-- | Function 'liftSimpleSplitter' lifts a simple, non-sectioning splitter function into a full 'Splitter'.+liftSimpleSplitter :: forall m x. (ParallelizableMonad m, Typeable x) =>+ String -> Int+ -> (Int -> (ComponentConfiguration, forall c. Source c x -> Sink c x -> Sink c x -> Pipe c m [x]))+ -> Splitter m x+liftSimpleSplitter name maxThreads usingThreads+ = case usingThreads 1+ of (configuration, split) -> Splitter name maxThreads configuration usingThreads' split (splitSections split)+ where usingThreads' :: Int -> (ComponentConfiguration,+ forall c. Source c x -> Sink c x -> Sink c x -> Pipe c m [x],+ forall c. Source c x -> Sink c (Maybe x) -> Sink c (Maybe x) -> Pipe c m [x])+ usingThreads' threads = case usingThreads threads+ of (configuration, splitValues) -> (configuration, splitValues, splitSections splitValues)+ splitSections split source true false = liftM (fst . fst) $ pipeD "liftSimpleSplitter true" (\true'-> pipeD "liftSimpleSplitter false" (\false'-> split source true' false') (decorate false)) (decorate true)- decorate sink source = transduce (lift121Transducer Just) source sink+ decorate sink source = transduce (lift121Transducer "Just" Just) source sink + -- | Function 'liftSectionSplitter' lifts a sectioning splitter function into a full 'Splitter'-liftSectionSplitter :: (Monad m, Typeable x) =>- (forall c1 c2 c3 context. Source c1 x -> Sink c2 (Maybe x) -> Sink c3 (Maybe x) -> Pipe context m [x])- -> Splitter m x-liftSectionSplitter splitSections = Splitter splitValues splitSections- where splitValues source true false+liftSectionSplitter :: forall m x. (ParallelizableMonad m, Typeable x) =>+ String -> Int -> (Int -> (ComponentConfiguration,+ forall c. Source c x -> Sink c (Maybe x) -> Sink c (Maybe x) -> Pipe c m [x]))+ -> Splitter m x+liftSectionSplitter name maxThreads usingThreads+ = case usingThreads 1+ of (configuration, splitSections) -> Splitter name 1 configuration usingThreads' (splitValues splitSections) splitSections+ where usingThreads' :: Int -> (ComponentConfiguration,+ forall c. Source c x -> Sink c x -> Sink c x -> Pipe c m [x],+ forall c. Source c x -> Sink c (Maybe x) -> Sink c (Maybe x) -> Pipe c m [x])+ usingThreads' threads = case usingThreads threads+ of (configuration, splitSections) -> (configuration, splitValues splitSections, splitSections)+ splitValues splitSections source true false = liftM (fst . fst) $ pipeD "liftSectionSplitter true" (\true'-> pipeD "liftSectionSplitter false" (\false'-> splitSections source true' false') (strip false)) (strip true)+ strip sink source = canPut sink+ >>= flip when (getSuccess source (\x-> maybe (return False) (put sink) x >> strip sink source))++-- | Function 'liftAtomicSimpleSplitter' lifts a single-threaded 'split' function into a 'Splitter' component.+liftAtomicSimpleSplitter :: forall m x. (ParallelizableMonad m, Typeable x) =>+ String -> Int -> (forall c. Source c x -> Sink c x -> Sink c x -> Pipe c m [x]) -> Splitter m x+liftAtomicSimpleSplitter name cost split = liftSimpleSplitter name 1 (\_threads-> (ComponentConfiguration [] 1 cost, split))++-- | Function 'liftAtomicSectionSplitter' lifts a single-threaded 'splitSections' function into a full 'Splitter'+-- component.+liftAtomicSectionSplitter :: forall m x. (ParallelizableMonad m, Typeable x) =>+ String -> Int -> (forall c. Source c x -> Sink c (Maybe x) -> Sink c (Maybe x) -> Pipe c m [x])+ -> Splitter m x+liftAtomicSectionSplitter name cost splitSections = liftSectionSplitter name 1 $+ \_threads-> (ComponentConfiguration [] 1 cost, splitSections)+ where configuration = ComponentConfiguration [] 1 1+ usingThreads :: Int -> (ComponentConfiguration,+ forall c. Source c x -> Sink c x -> Sink c x -> Pipe c m [x],+ forall c. Source c x -> Sink c (Maybe x) -> Sink c (Maybe x) -> Pipe c m [x])+ usingThreads threads = (configuration, splitValues, splitSections)+ splitValues source true false+ = liftM (fst . fst) $+ pipeD "liftSectionSplitter true"+ (\true'-> pipeD "liftSectionSplitter false" (\false'-> splitSections source true' false') (strip false))+ (strip true) -- strip sink source = transduce (liftStatelessTransducer (maybe [] (:[]))) source sink strip sink source = canPut sink >>= flip when (getSuccess source (\x-> maybe (return False) (put sink) x >> strip sink source))++-- | Function 'optimalTwoParallelConfigurations' configures two components, both of them with the full thread count, and+-- returns the components and a 'ComponentConfiguration' that can be used to build a new component from them.+optimalTwoSequentialConfigurations :: (Component c1, Component c2) => Int -> c1 -> c2 -> (ComponentConfiguration, c1, c2)+optimalTwoSequentialConfigurations threads c1 c2 = (configuration, c1', c2')+ where configuration = ComponentConfiguration+ [AnyComponent c1', AnyComponent c2']+ (usedThreads c1' `max` usedThreads c2')+ (cost c1' + cost c2')+ c1' = usingThreads threads c1+ c2' = usingThreads threads c2++-- | Function 'optimalTwoParallelConfigurations' configures two components assuming they can be run in parallel,+-- splitting the given thread count between them, and returns the configured components, a 'ComponentConfiguration' that+-- can be used to build a new component from them, and a flag that indicates if they should be run in parallel or+-- sequentially for optimal resource usage.+optimalTwoParallelConfigurations :: (Component c1, Component c2) => Int -> c1 -> c2 -> (ComponentConfiguration, c1, c2, Bool)+optimalTwoParallelConfigurations threads c1 c2 = (configuration, c1', c2', parallelize)+ where parallelize = threads > 1 && parallelCost + 1 < sequentialCost+ configuration = ComponentConfiguration+ [AnyComponent c1', AnyComponent c2']+ (if parallelize then usedThreads c1' + usedThreads c2' else usedThreads c1' `max` usedThreads c2')+ (if parallelize then parallelCost + 1 else sequentialCost)+ (c1', c2') = if parallelize then (c1p, c2p) else (c1s, c2s)+ (c1p, c2p, parallelCost) = minimumBy+ (\(_, _, cost1) (_, _, cost2)-> compare cost1 cost2)+ [let c2threads = threads - c1threads `min` maxUsableThreads c2+ c1i = usingThreads c1threads c1+ c2i = usingThreads c2threads c2+ in (c1i, c2i, cost c1i `max` cost c2i)+ | c1threads <- [1 .. threads - 1 `min` maxUsableThreads c1]]+ c1s = usingThreads threads c1+ c2s = usingThreads threads c2+ sequentialCost = cost c1s + cost c2s++-- | Function 'optimalThreeParallelConfigurations' configures three components assuming they can be run in parallel,+-- splitting the given thread count between them, and returns the components, a 'ComponentConfiguration' that can be+-- used to build a new component from them, and a flag per component that indicates if it should be run in parallel or+-- sequentially for optimal resource usage.+optimalThreeParallelConfigurations :: (Component c1, Component c2, Component c3) =>+ Int -> c1 -> c2 -> c3 -> (ComponentConfiguration, (c1, Bool), (c2, Bool), (c3, Bool))+optimalThreeParallelConfigurations threadCount c1 c2 c3 = undefined
Control/Concurrent/SCC/Components.hs view
@@ -20,14 +20,17 @@ {-# LANGUAGE ScopedTypeVariables, Rank2Types #-} module Control.Concurrent.SCC.Components- (-- * IO components+ (-- * List producers and consumers+ fromList, toList,+ -- * I/O producers and consumers fromFile, fromHandle, fromStdIn, appendFile, toFile, toHandle, toStdOut, toPrint,+ -- * Generic consumers+ suppress, erroneous, -- * Generic transducers- asis, suppress, erroneous,- prepend, append, substitute,+ asis, -- * Generic splitters- allTrue, allFalse, one, substring, substringMatch,+ everything, nothing, one, substring, substringMatch, -- * List transducers -- | The following laws hold: --@@ -38,7 +41,8 @@ -- * Character stream components lowercase, uppercase, whitespace, letters, digits, line, nonEmptyLine, -- * Oddballs- count, toString+ count, toString,+ ioCost ) where @@ -59,142 +63,133 @@ import System.IO (Handle, IOMode (ReadMode, WriteMode, AppendMode), openFile, hClose, hGetChar, hPutChar, hFlush, hIsEOF, hClose, putChar, isEOF, stdout) +ioCost :: Int+ioCost = 5 +-- | Consumer 'toList' copies the given source into a list.+toList :: forall m x. (Monad m, Typeable x) => Consumer m x [x]+toList = liftAtomicConsumer "toList" 1 getList++-- | 'fromList' produces the contents of the given list argument.+fromList :: forall m x. (Monad m, Typeable x) => [x] -> Producer m x [x]+fromList l = liftAtomicProducer "fromList" 1 (putList l)+ -- | Consumer 'toStdOut' copies the given source into the standard output. toStdOut :: Consumer IO Char ()-toStdOut source = getSuccess source (\x-> liftPipe (putChar x) >> toStdOut source)+toStdOut = liftAtomicConsumer "toStdOut" ioCost $ \source-> let c = get source+ >>= maybe (return ()) (\x-> liftPipe (putChar x) >> c)+ in c toPrint :: forall x. (Show x, Typeable x) => Consumer IO x ()-toPrint source = getSuccess source (\x-> liftPipe (print x) >> toPrint source)+toPrint = liftAtomicConsumer "toPrint" ioCost $ \source-> let c = getSuccess source (\x-> liftPipe (print x) >> c)+ in c -- | Producer 'fromStdIn' feeds the given sink from the standard input. fromStdIn :: Producer IO Char ()-fromStdIn sink = do readyInput <- liftM not (liftPipe isEOF)- readyOutput <- canPut sink- when (readyInput && readyOutput) (liftPipe getChar >>= put sink >> fromStdIn sink)+fromStdIn = liftAtomicProducer "fromStdIn" ioCost $ \sink-> let p = do readyInput <- liftM not (liftPipe isEOF)+ readyOutput <- canPut sink+ when (readyInput && readyOutput) (liftPipe getChar+ >>= put sink+ >> p)+ in p -- | Producer 'fromFile' opens the named file and feeds the given sink from its contents. fromFile :: String -> Producer IO Char ()-fromFile path sink = liftPipe (openFile path ReadMode) >>= flip fromHandle sink+fromFile path = liftAtomicProducer "fromFile" ioCost $ \sink-> do handle <- liftPipe (openFile path ReadMode)+ produce (fromHandle handle True) sink --- | Producer 'fromHandle' feeds the given sink from the open file /handle/.-fromHandle :: Handle -> Producer IO Char ()-fromHandle handle sink = producer- where producer = do readyInput <- liftM not (liftPipe (hIsEOF handle))- readyOutput <- canPut sink- when (readyInput && readyOutput) (liftPipe (hGetChar handle) >>= put sink >> producer)+-- | Producer 'fromHandle' feeds the given sink from the open file /handle/. The argument /doClose/ determines if+-- | /handle/ should be closed when the handle is consumed or the sink closed.+fromHandle :: Handle -> Bool -> Producer IO Char ()+fromHandle handle doClose = liftAtomicProducer "fromHandle" ioCost $+ \sink-> (canPut sink+ >>= flip when (let p = do eof <- liftPipe (hIsEOF handle)+ when (not eof) (liftPipe (hGetChar handle)+ >>= put sink+ >>= flip when p)+ in p)+ >> when doClose (liftPipe $ hClose handle)) -- | Consumer 'toFile' opens the named file and copies the given source into it. toFile :: String -> Consumer IO Char ()-toFile path source = liftPipe (openFile path WriteMode) >>= flip toHandle source+toFile path = liftAtomicConsumer "toFile" ioCost $ \source-> do handle <- liftPipe (openFile path WriteMode)+ consume (toHandle handle True) source -- | Consumer 'appendFile' opens the name file and appends the given source to it. appendFile :: String -> Consumer IO Char ()-appendFile path source = liftPipe (openFile path AppendMode) >>= flip toHandle source+appendFile path = liftAtomicConsumer "appendFile" ioCost $ \source-> do handle <- liftPipe (openFile path AppendMode)+ consume (toHandle handle True) source --- | Consumer 'toHandle' copies the given source into the open file /handle/.-toHandle :: Handle -> Consumer IO Char ()-toHandle handle source = getSuccess source (\x-> liftPipe (hPutChar handle x) >> toHandle handle source)+-- | Consumer 'toHandle' copies the given source into the open file /handle/. The argument /doClose/ determines if+-- | /handle/ should be closed once the entire source is consumed and copied.+toHandle :: Handle -> Bool -> Consumer IO Char ()+toHandle handle doClose = liftAtomicConsumer "toHandle" ioCost $ \source-> let c = get source+ >>= maybe+ (when doClose $ liftPipe $ hClose handle)+ (\x-> liftPipe (hPutChar handle x) >> c)+ in c -- | Transducer 'asis' passes its input through unmodified.-asis :: (Monad m, Typeable x) => Transducer m x x-asis = Transducer (\source sink-> pour source sink >> return [])+asis :: forall m x. (Monad m, Typeable x) => Transducer m x x+asis = lift121Transducer "asis" id -- | The 'suppress' transducer suppresses all input it receives. It is equivalent to 'substitute' []-suppress :: (Monad m, Typeable x, Typeable y) => Transducer m x y-suppress = liftStatelessTransducer (const [])+suppress :: forall m x y. (Monad m, Typeable x) => Consumer m x ()+suppress = liftAtomicConsumer "suppress" 1 consumeAndSuppress -- | The 'erroneous' transducer reports an error if any input reaches it.-erroneous :: (Monad m, Typeable x) => Transducer m x x-erroneous = liftStatelessTransducer (\x-> error "Erroneous.")+erroneous :: forall m x. (Monad m, Typeable x) => String -> Consumer m x ()+erroneous message = liftAtomicConsumer "erroneous" 0 $ \source-> get source >>= maybe (return ()) (const (error message)) -- | The 'lowercase' transforms all uppercase letters in the input to lowercase, leaving the rest unchanged.-lowercase :: Monad m => Transducer m Char Char-lowercase = lift121Transducer toLower+lowercase :: forall m. Monad m => Transducer m Char Char+lowercase = lift121Transducer "lowercase" toLower -- | The 'uppercase' transforms all lowercase letters in the input to uppercase, leaving the rest unchanged.-uppercase :: Monad m => Transducer m Char Char-uppercase = lift121Transducer toUpper---- | Transducer 'prepend' passes its input unmodified, except for prepending contents of the given list parameter before--- it.-prepend :: (Monad m, Typeable x) => [x] -> Transducer m x x-prepend prefix = Transducer (\source sink-> putList prefix sink >>= whenNull (pour source sink >> return []))---- | Transducer 'append' passes its input unmodified, except for appending contents of the given list parameter to--- its end.-append :: (Monad m, Typeable x) => [x] -> Transducer m x x-append suffix = Transducer (\source sink-> do pour source sink- putList suffix sink- return [])---- | The 'substitute' transducer replaces its whole input by its parameter.-substitute :: (Monad m, Typeable x, Typeable y) => [y] -> Transducer m x y-substitute list = Transducer (\source sink-> consumeAndSuppress source >> putList list sink >> return [])+uppercase :: forall m. Monad m => Transducer m Char Char+uppercase = lift121Transducer "uppercase" toUpper -- | The 'count' transducer counts all its input values and outputs the final tally.-count :: (Monad m, Typeable x) => Transducer m x Integer-count = Transducer (\source sink-> let t count = get source- >>= maybe- (put sink count >> return [])- (\_-> t (succ count))- in canPut sink >>= cond (t 0) (return []))+count :: forall m x. (Monad m, Typeable x) => Transducer m x Integer+count = liftFoldTransducer "count" (\count _-> succ count) 0 id -toString :: (Monad m, Show x, Typeable x) => Transducer m x String-toString = lift121Transducer show+toString :: forall m x. (Monad m, Show x, Typeable x) => Transducer m x String+toString = lift121Transducer "toString" show -- | Transducer 'group' collects all its input values into a single list.-group :: (Monad m, Typeable x) => Transducer m x [x]-group = Transducer (\source sink-> let group q = get source- >>= maybe- (let list = Foldable.toList (Seq.viewl q)- in put sink list- >>= cond- (return [])- (return list))- (\x-> group (q |> x))- in group Seq.empty)+group :: forall m x. (Monad m, Typeable x) => Transducer m x [x]+group = liftFoldTransducer "group" (|>) Seq.empty Foldable.toList -- | Transducer 'concatenate' flattens the input stream of lists of values into the output stream of values.-concatenate :: (Monad m, Typeable x) => Transducer m [x] x-concatenate = liftStatelessTransducer id+concatenate :: forall m x. (Monad m, Typeable x) => Transducer m [x] x+concatenate = liftStatelessTransducer "concatenate" id -concatSeparate :: (Monad m, Typeable x) => [x] -> Transducer m [x] x-concatSeparate separator = Transducer (\source sink-> let t = canPut sink- >>= cond- (get source- >>= maybe- (return [])- (\xs-> do putList separator sink- putList xs sink- t))- (return [])- in get source- >>= maybe- (return [])- (\xs-> putList xs sink >> t))+concatSeparate :: forall m x. (Monad m, Typeable x) => [x] -> Transducer m [x] x+concatSeparate separator = liftStatefulTransducer "concatSeparate"+ (\seen list-> (True, if seen then separator ++ list else list))+ False -- | Splitter 'whitespace' feeds all white-space characters into its /true/ sink, all others into /false/.-whitespace :: Monad m => Splitter m Char-whitespace = liftStatelessSplitter isSpace+whitespace :: forall m. ParallelizableMonad m => Splitter m Char+whitespace = liftStatelessSplitter "whitespace" isSpace -- | Splitter 'letters' feeds all alphabetical characters into its /true/ sink, all other characters into /false/.-letters :: Monad m => Splitter m Char-letters = liftStatelessSplitter isAlpha+letters :: forall m. ParallelizableMonad m => Splitter m Char+letters = liftStatelessSplitter "letters" isAlpha -- | Splitter 'digits' feeds all digits into its /true/ sink, all other characters into /false/.-digits :: Monad m => Splitter m Char-digits = liftStatelessSplitter isDigit+digits :: forall m. ParallelizableMonad m => Splitter m Char+digits = liftStatelessSplitter "digits" isDigit -- | Splitter 'nonEmptyLine' feeds line-ends into its /false/ sink, and all other characters into /true/.-nonEmptyLine :: Monad m => Splitter m Char-nonEmptyLine = liftStatelessSplitter (\ch-> ch /= '\n' && ch /= '\r')+nonEmptyLine :: forall m. ParallelizableMonad m => Splitter m Char+nonEmptyLine = liftStatelessSplitter "nonEmptyLine" (\ch-> ch /= '\n' && ch /= '\r') -- | The sectioning splitter 'line' feeds line-ends into its /false/ sink, and line contents into /true/. A single -- line-end can be formed by any of the character sequences \"\\n\", \"\\r\", \"\\r\\n\", or \"\\n\\r\".-line :: Monad m => Splitter m Char-line = liftSectionSplitter (\source true false->- let split0 = get source >>= maybe (return []) split1+line :: forall m. ParallelizableMonad m => Splitter m Char+line = liftAtomicSectionSplitter "line" 1 $+ \source true false-> let split0 = get source >>= maybe (return []) split1 split1 x = if x == '\n' || x == '\r' then split2 x else lineChar x@@ -220,43 +215,44 @@ (return [x]) emptyLine x = put true Nothing >>= cond (split2 x) (return []) lineChar x = put true (Just x) >>= cond split0 (return [x])- in split0)+ in split0 --- | Splitter 'allTrue' feeds its entire input into its /true/ sink.-allTrue :: (Monad m, Typeable x) => Splitter m x-allTrue = liftStatelessSplitter (const True)+-- | Splitter 'everything' feeds its entire input into its /true/ sink.+everything :: forall m x. (ParallelizableMonad m, Typeable x) => Splitter m x+everything = liftStatelessSplitter "everything" (const True) --- | Splitter 'allFalse' feeds its entire input into its /false/ sink.-allFalse :: (Monad m, Typeable x) => Splitter m x-allFalse = liftStatelessSplitter (const False)+-- | Splitter 'nothing' feeds its entire input into its /false/ sink.+nothing :: forall m x. (ParallelizableMonad m, Typeable x) => Splitter m x+nothing = liftStatelessSplitter "nothing" (const False) -- | Splitter 'one' feeds all input values to its /true/ sink, treating every value as a separate section.-one :: (Monad m, Typeable x) => Splitter m x-one = liftSectionSplitter (\source true false-> let split x = put true (Just x)- >>= cond (get source- >>= maybe- (return [])- (\x-> put false Nothing >> split x))- (return [x])- in get source >>= maybe (return []) split)+one :: forall m x. (ParallelizableMonad m, Typeable x) => Splitter m x+one = liftAtomicSectionSplitter "one" 1 $+ \source true false-> let split x = put true (Just x)+ >>= cond (get source+ >>= maybe+ (return [])+ (\x-> put false Nothing >> split x))+ (return [x])+ in get source >>= maybe (return []) split -- | Splitter 'substring' feeds to its /true/ sink all input parts that match the contents of the given list -- argument. If two overlapping parts of the input both match the argument, only the first one wins.-substring :: (Monad m, Eq x, Typeable x) => [x] -> Splitter m x-substring = substringPrim False+substring :: forall m x. (ParallelizableMonad m, Eq x, Typeable x) => [x] -> Splitter m x+substring = substringPrim "substring" False -- | Splitter 'substringMatch' feeds to its /true/ sink all input parts that match the contents of the given list -- argument. If two overlapping parts of the input match the argument, both are considered /true/.-substringMatch :: (Monad m, Eq x, Typeable x) => [x] -> Splitter m x-substringMatch = substringPrim True+substringMatch :: forall m x. (ParallelizableMonad m, Eq x, Typeable x) => [x] -> Splitter m x+substringMatch = substringPrim "substringMatch" True -substringPrim _ [] = liftSectionSplitter (\ source true false ->- do put true Nothing- rest <- splitSections one source false true- put true Nothing- return rest)-substringPrim overlap list- = liftSectionSplitter $+substringPrim name _ [] = liftAtomicSectionSplitter name 1 $+ \ source true false -> do put true Nothing+ rest <- splitSections one source false true+ put true Nothing+ return rest+substringPrim name overlap list+ = liftAtomicSectionSplitter name 1 $ \ source true false -> let getNext rest q separate = get source >>= maybe
Control/Concurrent/SCC/Foundation.hs view
@@ -19,29 +19,62 @@ {-# LANGUAGE ScopedTypeVariables, Rank2Types, PatternGuards, ExistentialQuantification #-} module Control.Concurrent.SCC.Foundation- (-- * Types- Pipe, Source, Sink, Consumer, Producer,+ (-- * Classes+ ParallelizableMonad (parallelize),+ -- * Types+ Pipe, Source, Sink, -- * Flow-control functions- pipe, pipeD, get, getSuccess, canPut, put,+ pipe, pipeD, pipeP, get, getSuccess, canPut, put, liftPipe, runPipes, -- * Utility functions cond, whenNull, pour, tee, getList, putList, consumeAndSuppress) where +import Control.Concurrent (forkIO)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) import Control.Exception (assert)-import Control.Monad (liftM, when)+import Control.Monad (liftM, liftM2, when)+import Control.Monad.Identity+import Control.Parallel (par, pseq) import Data.Maybe (maybe) import Data.Typeable (Typeable, cast) import Debug.Trace (trace) +class Monad m => ParallelizableMonad m where+ parallelize :: m a -> m b -> m (a, b)+ parallelize = liftM2 (,)++instance ParallelizableMonad Identity where+ parallelize ma mb = let a = runIdentity ma+ b = runIdentity mb+ in a `par` (b `pseq` Identity (a, b))++instance ParallelizableMonad Maybe where+ parallelize ma mb = case ma `par` (mb `pseq` (ma, mb))+ of (Just a, Just b) -> Just (a, b)+ _ -> Nothing+++instance ParallelizableMonad IO where+ parallelize ma mb = do va <- newEmptyMVar+ vb <- newEmptyMVar+ forkIO (ma >>= putMVar va)+ forkIO (mb >>= putMVar vb)+ a <- takeMVar va+ b <- takeMVar vb+ return (a, b)+ + -- | 'Pipe' represents the type of monadic computations that can be split into co-routining computations using function -- 'pipe'. The /context/ type parameter delimits the scope of the computation.-newtype Monad m => Pipe context m r = Pipe {proceed :: context -> Int -> Integer -> m (PipeState context m r)}-data PipeState context m r = Suspend context [Suspension context m r]- | Done Integer r-data Suspension context m r = Suspension {pid :: Int,- clock :: Integer,+newtype Pipe context m r = Pipe {proceed :: PipeState context -> m (PipeRendezvous context m r)}+data PipeState context = PipeState {level :: Int,+ clock :: Integer}+data PipeRendezvous context m r = Suspend [Suspension context m r]+ | Done Integer r+data Suspension context m r = Suspension {targetLevel :: Int,+ state :: PipeState context, description :: String, continuation :: SuspendedContinuation context m r} data SuspendedContinuation context m r = forall x. Typeable x => Get (Maybe x -> Pipe context m r)@@ -49,119 +82,148 @@ | CanPut (Bool -> Pipe context m r) -- | A 'Source' is the read-only end of a 'Pipe' communication channel.-data Source context x = Source context Int String+data Source context x = Source Int String -- | A 'Sink' is the write-only end of a 'Pipe' communication channel.-data Sink context x = Sink context Int String+data Sink context x = Sink Int String -- | A computation that consumes values from a 'Source' is called 'Consumer'.-type Consumer m x r = forall c. Source c x -> Pipe c m r+type Consumer c m x r = Source c x -> Pipe c m r -- | A computation that produces values and puts them into a 'Sink' is called 'Producer'.-type Producer m x r = forall c. Sink c x -> Pipe c m r+type Producer c m x r = Sink c x -> Pipe c m r -- | Function 'liftPipe' lifts a value of the underlying monad type into a 'Pipe' computation. liftPipe :: forall context m r. Monad m => m r -> Pipe context m r-liftPipe mr = Pipe (\context pid clock-> liftM (Done clock) mr)+liftPipe mr = Pipe (\state-> liftM (Done (clock state)) mr) -- | Function 'runPipes' runs the given computation involving pipes and returns the final result. -- The /context/ argument ensures that no suspended computation can escape its scope. runPipes :: forall m r. Monad m => (forall context. Pipe context m r) -> m r-runPipes c = proceed c undefined 1 0 >>= \s-> case s of Done _ r -> return r+runPipes c = proceed c (PipeState 1 0) >>= \s-> case s of Done _ r -> return r instance Monad m => Monad (Pipe context m) where- return r = Pipe (\context pid clock-> return (Done clock r))- Pipe p >>= f = Pipe (\context pid clock-> p context pid clock >>= apply f context pid)- where apply :: forall r1 r2. (r1 -> Pipe context m r2) -> context -> Int -> PipeState context m r1 -> m (PipeState context m r2)- apply f context pid (Done clock r) = proceed (f r) context pid (succ clock)- apply f _ pid (Suspend context suspensions) = return $ Suspend context (map suspendApplied suspensions)- where suspendApplied s@Suspension{description= desc, clock= clock', continuation= Get cont}- = s{description= "applied " ++ desc, continuation= Get ((f =<<) . cont)}- suspendApplied s@Suspension{description= desc, clock= clock', continuation= Put x cont}- = s{description= "applied " ++ desc, continuation= Put x ((f =<<) . cont)}- suspendApplied s@Suspension{description= desc, clock= clock', continuation= CanPut cont}- = s{description= "applied " ++ desc, continuation= CanPut ((f =<<) . cont)}+ return r = Pipe (\state-> return (Done (clock state) r))+ Pipe p >>= f = Pipe (\state-> p state >>= apply f state)+ where apply :: forall r1 r2. (r1 -> Pipe context m r2) -> PipeState context -> PipeRendezvous context m r1+ -> m (PipeRendezvous context m r2)+ apply f state (Done t r) = proceed (f r) state{clock= succ t}+ apply f state (Suspend suspensions) = return $ Suspend (map suspendApplied suspensions)+ where suspendApplied s = postApply (>>= f) s{description= "applied " ++ description s} +postApply :: (Pipe context m r1 -> Pipe context m r2) -> Suspension context m r1 -> Suspension context m r2+postApply f s = s{continuation= case continuation s of Get cont -> Get (f . cont)+ Put x cont -> Put x (f . cont)+ CanPut cont -> CanPut (f . cont)}++instance ParallelizableMonad m => ParallelizableMonad (Pipe context m) where+ parallelize p1 p2 = Pipe (\state-> liftM combine $ parallelize (proceed p1 state) (proceed p2 state))+ where combine :: forall r1 r2. (PipeRendezvous context m r1, PipeRendezvous context m r2) -> PipeRendezvous context m (r1, r2)+ combine (Done c1 r1, Done c2 r2) = Done (max c1 c2) (r1, r2)+ combine (Suspend s1, Done c2 r2) = Suspend (map (adjustSuspension c2 (liftM $ flip (,) r2)) s1)+ combine (Done c1 r1, Suspend s2) = Suspend (map (adjustSuspension c1 (liftM $ (,) r1)) s2)+ combine (r1@(Suspend s1), r2@(Suspend s2)) = Suspend (merge (map (postApply (flip parallelize (rewrap r2))) s1)+ (map (postApply (parallelize (rewrap r1))) s2))+ rewrap :: PipeRendezvous context m r -> Pipe context m r+ rewrap r = Pipe $ const $ return $ r+ adjustSuspension :: Integer -> (Pipe context m r1 -> Pipe context m r2)+ -> Suspension context m r1 -> Suspension context m r2+ adjustSuspension c f s = postApply f s{state= (state s) {clock= clock (state s) `max` c}}+ instance Show (Suspension context m r) where- show Suspension{pid= pid, description = desc, continuation= c} = (case c of Put{} -> "(Put)"- CanPut{} -> "(CanPut)"- Get{} -> "(Get)")- ++ desc ++ " -> " ++ show pid+ show Suspension{targetLevel= lvl, description = desc, continuation= c} = (case c of Put{} -> "(Put)"+ CanPut{} -> "(CanPut)"+ Get{} -> "(Get)")+ ++ desc ++ " -> " ++ show lvl -- | The 'pipe' function splits the computation into two concurrent parts, /producer/ and /consumer/. The /producer/ is -- given a 'Sink' to put values into, and /consumer/ a 'Source' to get those values from. Once producer and consumer -- both complete, 'pipe' returns their paired results.-pipe :: forall context x m r1 r2. Monad m => Producer m x r1 -> Consumer m x r2 -> Pipe context m (r1, r2)+pipe :: forall context x m r1 r2. Monad m => Producer context m x r1 -> Consumer context m x r2 -> Pipe context m (r1, r2) pipe = pipeD "" -- | The 'pipeD' function is same as 'pipe', with an additional description argument.-pipeD :: forall context x m r1 r2. Monad m => String -> Producer m x r1 -> Consumer m x r2 -> Pipe context m (r1, r2)-pipeD description producer consumer- = Pipe (\context pid clock-> let producerPid = 2*pid- consumerPid = 2*pid+1- context' = undefined- description' = description ++ ':' : show pid- in assert (track (indent pid ++ "pipe " ++ description')) $- do ps <- proceed (producer (Sink context' producerPid description')) context' producerPid clock- cs <- proceed (consumer (Source context' consumerPid description')) context' consumerPid clock- reduce context' producerPid ps consumerPid cs)+pipeD :: forall c x m r1 r2. Monad m => String -> Producer c m x r1 -> Consumer c m x r2 -> Pipe c m (r1, r2)+pipeD description producer consumer = pipePrim description (liftM2 (,)) producer consumer -reduce :: forall c m r1 r2. Monad m => c -> Int -> PipeState c m r1 -> Int -> PipeState c m r2 -> m (PipeState c m (r1, r2))-reduce context pid1 (Done t1 r1) pid2 (Done t2 r2)- = assert (track (indent pid1 ++ "Done " ++ show pid1 ++ " -> " ++ show pid2)) $+-- | The 'pipeP' function is equivalent to 'pipe', except the /producer/ and /consumer/ are run in parallel if resources+-- allow.+pipeP :: forall c x m r1 r2. ParallelizableMonad m => Producer c m x r1 -> Consumer c m x r2 -> Pipe c m (r1, r2)+pipeP producer consumer = pipePrim "" parallelize producer consumer++-- | The 'pipePrim' function is the actual worker function of the 'pipe' family.+pipePrim :: forall c m x r1 r2. Monad m =>+ String -> (forall a b. m a -> m b -> m (a, b)) -> Producer c m x r1 -> Consumer c m x r2 -> Pipe c m (r1, r2)+pipePrim description pairMonads producer consumer+ = Pipe (\(PipeState level clock)-> let level' = succ level+ description' = description ++ ':' : show level+ in assert (track (indent level ++ "pipe " ++ description')) $+ do (ps, cs) <- pairMonads (proceed (producer (Sink level description'))+ (PipeState level' clock))+ (proceed (consumer (Source level description'))+ (PipeState level' clock))+ reduce pairMonads level ps cs)++reduce :: forall c m r1 r2. Monad m =>+ (m (PipeRendezvous c m r1) -> m (PipeRendezvous c m r2) -> m (PipeRendezvous c m r1, PipeRendezvous c m r2))+ -> Int -> PipeRendezvous c m r1 -> PipeRendezvous c m r2 -> m (PipeRendezvous c m (r1, r2))+reduce pairMonads level (Done t1 r1) (Done t2 r2)+ = assert (track (indent level ++ "Done " ++ show level ++ " -> " ++ show level)) $ return (Done (max t1 t2) (r1, r2))-reduce context pid1 (Suspend c1 ps@(Suspension{pid= pid1', clock= t, continuation= pCont} : _)) pid2 consumer@Done{}- | pid1' == pid1, Put _ cont <- pCont- = assert (track (indent pid1 ++ "Failed producer put " ++ show ps ++ " from " ++ show pid1)) $- proceed (cont False) context pid1 t >>= \p'-> reduce context pid1 p' pid2 consumer- | pid1' == pid1, CanPut cont <- pCont- = assert (track (indent pid1 ++ "Finish producer " ++ show ps ++ " from " ++ show pid1)) $- proceed (cont False) context pid1 t >>= \p'-> reduce context pid1 p' pid2 consumer- | pid1' < pid1 = assert (track (indent pid1 ++ "Suspend producer " ++ show ps ++ " from " ++ show pid1)) $- return $ Suspend context $ map (delay (\ps'-> reduce context pid1 ps' pid2 consumer)) ps- | otherwise = error (show pid1' ++ ">" ++ show pid1 ++ " | producer : " ++ show ps)-reduce context pid1 producer@Done{} pid2 (Suspend c2 cs@(Suspension{pid= pid2', clock= t, continuation= cCont} : _))- | pid2' == pid2, Get cont <- cCont- = assert (track (indent pid1 ++ "Finish consumer " ++ show cs ++ " from " ++ show pid2)) $- proceed (cont Nothing) context pid2 t >>= reduce context pid1 producer pid2- | pid2' < pid2 = assert (track (indent pid1 ++ "Suspend consumer " ++ show cs ++ " from " ++ show pid2)) $- return $ Suspend context $ map (delay (reduce context pid1 producer pid2)) cs- | otherwise = error (show pid2' ++ ">" ++ show pid2 ++ " | consumer : " ++ show cs)-reduce context pid1 producer@(Suspend _ ps@(Suspension{pid= pid1', clock=t1, continuation= pc} : _))- pid2 consumer@(Suspend _ cs@(Suspension{pid= pid2', clock=t2, continuation= Get cCont} : _))- | pid1' == pid1 && pid2' == pid2, CanPut pCont <- pc- = assert (track (indent pid1 ++ "CanPut Match at " ++ show pid1 ++ "/" ++ show pid2 ++ " : " ++ show ps ++ " -> " ++ show cs)) $- proceed (pCont True) context pid1 t1 >>= \p'-> reduce context pid1 p' pid2 consumer- | pid1' == pid1 && pid2' == pid2, Put x pCont <- pc- = assert (track (indent pid1 ++ "Match at " ++ show pid1 ++ "/" ++ show pid2 ++ " : " ++ show ps ++ " -> " ++ show cs)) $- let t' = max t1 t2- in do p' <- assert (track "producer (") $ proceed (pCont True) context pid1 t'- c' <- assert (track ") consumer (") $ proceed (cCont (cast x)) context pid2 t'- assert (track ") combined ->") reduce context pid1 p' pid2 c'-reduce context pid1 producer@(Suspend c1 ps) pid2 consumer@(Suspend c2 cs) = assert (track (indent pid1 ++ "Suspend producer & consumer, "- ++ show ps ++ " from " ++ show pid1 ++ " & "- ++ show cs ++ " from " ++ show pid2)) $- keepSuspending ps cs- where keepSuspending (Suspension{pid=pid1'} : pTail) cs | pid1' == pid1 = keepSuspending pTail cs- keepSuspending ps (Suspension{pid= pid2'} : cTail) | pid2' == pid2 = keepSuspending ps cTail- keepSuspending ps cs = assert (track (indent pid1 ++ "Suspend' producer & consumer, "- ++ show ps ++ " from " ++ show pid1 ++ " & "- ++ show cs ++ " from " ++ show pid2)) $- return $ Suspend context $- merge (map (\p-> delay (\p'-> reduce context pid1 p' pid2 consumer) p) ps)- (map (delay (reduce context pid1 producer pid2)) cs)+reduce pairMonads level (Suspend ps@(Suspension{targetLevel= l1, state= s1, continuation= pCont} : _)) consumer@Done{}+ | l1 == level, Put _ cont <- pCont+ = assert (track (indent level ++ "Failed producer put " ++ show ps ++ " from " ++ show level)) $+ proceed (cont False) s1 >>= \p'-> reduce pairMonads level p' consumer+ | l1 == level, CanPut cont <- pCont+ = assert (track (indent level ++ "Finish producer " ++ show ps ++ " from " ++ show level)) $+ proceed (cont False) s1 >>= \p'-> reduce pairMonads level p' consumer+ | l1 < level = assert (track (indent level ++ "Suspend producer " ++ show ps ++ " from " ++ show level)) $+ return $ Suspend $ map (delay (\ps'-> reduce pairMonads level ps' consumer)) ps+ | otherwise = error (show l1 ++ ">" ++ show level ++ " | producer : " ++ show ps)+reduce pairMonads level producer@Done{} (Suspend cs@(Suspension{targetLevel= l2, state= s2, continuation= cCont} : _))+ | l2 == level, Get cont <- cCont+ = assert (track (indent level ++ "Finish consumer " ++ show cs ++ " from " ++ show level)) $+ proceed (cont Nothing) s2 >>= reduce pairMonads level producer+ | l2 < level+ = assert (track (indent level ++ "Suspend consumer " ++ show cs ++ " from " ++ show level)) $+ return $ Suspend $ map (delay (reduce pairMonads level producer)) cs+ | otherwise = error (show l2 ++ ">" ++ show level ++ " | consumer : " ++ show cs)+reduce pairMonads level producer@(Suspend ps@(Suspension{targetLevel= l1, state= s1, continuation= pc} : _))+ consumer@(Suspend cs@(Suspension{targetLevel= l2, state= s2, continuation= Get cCont} : _))+ | l1 == level && l2 == level, CanPut pCont <- pc+ = assert (track (indent level ++ "CanPut Match at " ++ show level ++ " : " ++ show ps ++ " -> " ++ show cs)) $+ proceed (pCont True) s1 >>= \p'-> reduce pairMonads level p' consumer+ | l1 == level, Put x pCont <- pc+ = assert (track (indent level ++ "Match at " ++ show level ++ " : " ++ show ps ++ " -> " ++ show cs)) $+ do (p', c') <- pairMonads (assert (track "producer (") $ proceed (pCont True) (synchronizeState s1 s2))+ (assert (track ") consumer (") $ proceed (cCont (cast x)) (synchronizeState s2 s1))+ assert (track ") combined ->") reduce pairMonads level p' c'+reduce pairMonads level producer@(Suspend ps) consumer@(Suspend cs) = assert (track (indent level ++ "Suspend producer & consumer, "+ ++ show ps ++ " from " ++ show level ++ " & "+ ++ show cs ++ " from " ++ show level)) $+ keepSuspending ps cs+ where keepSuspending (Suspension{targetLevel=level'} : pTail) cs | level' == level = keepSuspending pTail cs+ keepSuspending ps (Suspension{targetLevel= level'} : cTail) | level' == level = keepSuspending ps cTail+ keepSuspending ps cs = assert (track (indent level ++ "Suspend' producer & consumer, "+ ++ show ps ++ " from " ++ show level ++ " & "+ ++ show cs ++ " from " ++ show level)) $+ return $ Suspend $+ merge (map (\p-> delay (\p'-> reduce pairMonads level p' consumer) p) ps)+ (map (delay (reduce pairMonads level producer)) cs) -merge :: Monad m => [Suspension context m r] -> [Suspension context m r] -> [Suspension context m r]+merge :: [Suspension context m r] -> [Suspension context m r] -> [Suspension context m r] merge [] l = l merge l [] = l-merge l1@(h1@Suspension{pid= pid1, clock= c1} : tail1) l2@(h2@Suspension{pid= pid2, clock= c2} : tail2)- | pid1 > pid2 = h1 : merge tail1 l2- | pid1 < pid2 = h2 : merge l1 tail2+merge l1@(h1@Suspension{targetLevel= level1, state= PipeState _ c1} : tail1)+ l2@(h2@Suspension{targetLevel= level2, state= PipeState _ c2} : tail2)+ | level1 > level2 = h1 : merge tail1 l2+ | level1 < level2 = h2 : merge l1 tail2 | c1 < c2 = h1 : merge tail1 l2 | otherwise = h2 : merge l1 tail2 -delay :: Monad m => (PipeState context m r1 -> m (PipeState context m r2)) -> Suspension context m r1 -> Suspension context m r2-delay f = delay' (\p-> Pipe $ \context pid clock-> proceed p context pid clock >>= f)+delay :: Monad m =>+ (PipeRendezvous context m r1 -> m (PipeRendezvous context m r2)) -> Suspension context m r1 -> Suspension context m r2+delay f = delay' (\p-> Pipe $ \state-> proceed p state >>= f) -delay' :: Monad m => (Pipe context m r1 -> Pipe context m r2) -> Suspension context m r1 -> Suspension context m r2+delay' :: (Pipe context m r1 -> Pipe context m r2) -> Suspension context m r1 -> Suspension context m r2 delay' f s@Suspension{description= desc, continuation= Get cont} = s{description= "delayed " ++ desc, continuation= Get (f . cont)} delay' f s@Suspension{description= desc, continuation= Put x cont}@@ -169,72 +231,76 @@ delay' f s@Suspension{description= desc, continuation= CanPut cont} = s{description= "delayed " ++ desc, continuation= CanPut (f . cont)} +synchronizeState :: PipeState context -> PipeState context -> PipeState context+synchronizeState (PipeState pid1 clock1) (PipeState pid2 clock2) = (PipeState pid1 (max clock1 clock2))+ indent 0 = "" indent n = ' ' : indent (n `div` 2) -- | Function 'get' tries to get a value from the given 'Source' argument. The intervening 'Pipe' computations suspend -- all the way to the 'pipe' function invocation that created the source. The result of 'get' is 'Nothing' iff the -- argument source is empty.-get :: forall context context' x m r. (Monad m, Typeable x)- => Source context' x -> Pipe context m (Maybe x)-get (Source _ pid desc) = assert (track (indent pid ++ "Get from " ++ desc ++ "@" ++ show pid)) $- Pipe (\context pid' clock->- assert (track (indent pid ++ "Get<- " ++ desc ++ "@" ++ show pid ++ ":" ++ show clock)) $- return $ Suspend context $- [Suspension pid clock ("get from " ++ desc ++ "@" ++ show pid ++ ":" ++ show clock) $ Get return])+get :: forall context x m r. (Monad m, Typeable x) => Source context x -> Pipe context m (Maybe x)+get (Source pid desc) = assert (track (indent pid ++ "Get from " ++ desc ++ "@" ++ show pid)) $+ Pipe (\state@(PipeState pid' clock)->+ assert (track (indent pid ++ "Get<- " ++ desc ++ "@" ++ show pid ++ ":" ++ show clock)) $+ return $ Suspend $+ [Suspension pid state ("get from " ++ desc ++ "@" ++ show pid ++ ":" ++ show clock) $ Get return]) -getSuccess :: forall context context' x m. (Monad m, Typeable x)- => Source context' x+getSuccess :: forall context x m. (Monad m, Typeable x)+ => Source context x -> (x -> Pipe context m ()) -- ^ Success continuation -> Pipe context m () getSuccess source succeed = get source >>= maybe (return ()) succeed -- | Function 'put' tries to put a value into the given sink. The intervening 'Pipe' computations suspend up to the -- 'pipe' invocation that has created the argument sink. The result of 'put' indicates whether the operation succeded.-put :: forall context context' x m r. (Monad m, Typeable x) => Sink context' x -> x -> Pipe context m Bool-put (Sink _ pid desc) x = assert (track (indent pid ++ "Put into " ++ desc ++ "@" ++ show pid)) $- Pipe (\context pid' clock->- assert (track (indent pid ++ "Put-> " ++ desc ++ "@" ++ show pid ++ ":" ++ show clock)) $- return $ Suspend context $- [Suspension pid clock ("put into " ++ desc ++ "@" ++ show pid ++ ":" ++ show clock)- (Put x return)])+put :: forall context x m r. (Monad m, Typeable x) => Sink context x -> x -> Pipe context m Bool+put (Sink pid desc) x = assert (track (indent pid ++ "Put into " ++ desc ++ "@" ++ show pid)) $+ Pipe (\state@(PipeState pid' clock)->+ assert (track (indent pid ++ "Put-> " ++ desc ++ "@" ++ show pid ++ ":" ++ show clock)) $+ return $ Suspend $+ [Suspension pid state ("put into " ++ desc ++ "@" ++ show pid ++ ":" ++ show clock)+ (Put x return)]) -- | Function 'canPut' checks if the argument sink accepts values, i.e., whether a 'put' operation would succeed on the -- sink.-canPut :: forall context context' x m r. (Monad m, Typeable x) => Sink context' x -> Pipe context m Bool-canPut (Sink _ pid desc) = assert (track (indent pid ++ "CanPut into " ++ desc ++ "@" ++ show pid)) $- Pipe (\context pid' clock->- assert (track (indent pid ++ "CanPut-> " ++ desc ++ "@" ++ show pid ++ ":" ++ show clock)) $- return $ Suspend context $- [Suspension pid clock ("canPut into " ++ desc ++ "@" ++ show pid ++ ":" ++ show clock)- (CanPut return)])+canPut :: forall context x m r. (Monad m, Typeable x) => Sink context x -> Pipe context m Bool+canPut (Sink pid desc) = assert (track (indent pid ++ "CanPut into " ++ desc ++ "@" ++ show pid)) $+ Pipe (\state@(PipeState pid' clock)->+ assert (track (indent pid ++ "CanPut-> " ++ desc ++ "@" ++ show pid ++ ":" ++ show clock)) $+ return $ Suspend $+ [Suspension pid state ("canPut into " ++ desc ++ "@" ++ show pid ++ ":" ++ show clock)+ (CanPut return)]) -- | 'pour' copies all data from the /source/ argument into the /sink/ argument, as long as there is anything to copy -- and the sink accepts it.-pour :: forall c c1 c2 x m. (Monad m, Typeable x) => Source c1 x -> Sink c2 x -> Pipe c m ()+pour :: forall c x m. (Monad m, Typeable x) => Source c x -> Sink c x -> Pipe c m () pour source sink = fill' where fill' = canPut sink >>= flip when (getSuccess source (\x-> put sink x >> fill')) -- | 'tee' is similar to 'pour' except it distributes every input value from the /source/ arguments into both /sink1/ -- and /sink2/.-tee :: (Monad m, Typeable x) => Source c1 x -> Sink c2 x -> Sink c3 x -> Pipe c m ()+tee :: (Monad m, Typeable x) => Source c x -> Sink c x -> Sink c x -> Pipe c m [x] tee source sink1 sink2 = distribute where distribute = do c1 <- canPut sink1 c2 <- canPut sink2- when (c1 && c2) (getSuccess source $ \x-> put sink1 x >> put sink2 x >> distribute)+ if c1 && c2+ then get source >>= maybe (return []) (\x-> put sink1 x >> put sink2 x >> distribute)+ else getList source -- | 'putList' puts entire list into its /sink/ argument, as long as the sink accepts it. The remainder that wasn't -- accepted by the sink is the result value.-putList :: forall x c c1 m. (Monad m, Typeable x) => [x] -> Sink c1 x -> Pipe c m [x]+putList :: forall x c m. (Monad m, Typeable x) => [x] -> Sink c x -> Pipe c m [x] putList [] sink = return [] putList l@(x:rest) sink = put sink x >>= cond (putList rest sink) (return l) -- | 'getList' returns the list of all values generated by the source.-getList :: forall x c c1 m. (Monad m, Typeable x) => Source c1 x -> Pipe c m [x]+getList :: forall x c m. (Monad m, Typeable x) => Source c x -> Pipe c m [x] getList source = get source >>= maybe (return []) (\x-> liftM (x:) (getList source)) -- | 'consumeAndSuppress' consumes the entire source ignoring the values it generates.-consumeAndSuppress :: forall x c c1 m. (Monad m, Typeable x) => Source c1 x -> Pipe c m ()+consumeAndSuppress :: forall x c m. (Monad m, Typeable x) => Source c x -> Pipe c m () consumeAndSuppress source = getSuccess source (\x-> consumeAndSuppress source) -- | A utility function wrapping if-then-else, useful for handling monadic truth values
Makefile view
@@ -1,23 +1,27 @@-SourceFiles=$(addprefix Control/Concurrent/SCC/, Foundation.hs ComponentTypes.hs Components.hs Combinators.hs) Test.hs Shell.hs-DocumentationFiles=$(shell echo $(SourceFiles) | ./shsh -c 'stdin | select (>! (substring " Shell.hs" >| substring " Test.hs"))')+LibraryFiles=$(addprefix Control/Concurrent/SCC/, Foundation.hs ComponentTypes.hs Components.hs Combinators.hs)+DocumentationFiles=$(LibraryFiles)+CommonOptions=-hidir obj -odir obj all: test test-prof shsh shsh-prof docs docs: doc/index.html -test: $(SourceFiles)- ghc --make Test.hs -main-is Test -O -o test -hidir obj -odir obj+test: $(LibraryFiles) Test.hs | obj+ ghc --make Test.hs -O2 -threaded -o test $(CommonOptions) -test-prof: $(SourceFiles)- ghc --make Test.hs -main-is Test -o test-prof -prof -auto-all -hidir prof -odir prof+test-prof: $(LibraryFiles) Test.hs | obj+ ghc --make Test.hs -o test-prof -prof -auto-all $(CommonOptions) -shsh: $(SourceFiles)- ghc --make Shell.hs -O -o shsh -hidir obj -odir obj+shsh: $(LibraryFiles) Shell.hs | obj+ ghc --make Shell.hs -O2 -threaded -o shsh $(CommonOptions) -shsh-prof: $(SourceFiles)- ghc --make Shell.hs -main-is Shell -o shsh-prof -prof -auto-all -hidir prof -odir prof+shsh-prof: $(LibraryFiles) Shell.hs | obj+ ghc --make Shell.hs -o shsh-prof -prof -auto-all $(CommonOptions) doc/index.html: $(DocumentationFiles) haddock -h -o doc $^ +obj:+ mkdir -p $@+ clean:- rm obj/* prof/* doc/*+ rm -r obj/* prof/* doc/*
Shell.hs view
@@ -14,718 +14,771 @@ <http://www.gnu.org/licenses/>. -} -{-# LANGUAGE ScopedTypeVariables, Rank2Types, GADTs, PatternSignatures #-}--module Main where--import Prelude hiding ((&&), (||), appendFile, interact, last)-import Data.List (intersperse)-import Data.Maybe (fromJust)-import Data.Typeable (Typeable)-import Control.Monad (liftM, when)-import Text.ParserCombinators.Parsec hiding (between, count)-import Text.ParserCombinators.Parsec.Language (emptyDef)-import Text.ParserCombinators.Parsec.Token-import System.Console.GetOpt-import System.Console.Readline-import System.Environment (getArgs)-import System.IO (hFlush, hPutStrLn, stderr, stdout)-import System.Process (runCommand, runInteractiveCommand)--import Control.Concurrent.SCC.Foundation-import Control.Concurrent.SCC.ComponentTypes-import Control.Concurrent.SCC.Components-import Control.Concurrent.SCC.Combinators--data VoidExpression where- NativeVoidCommand :: String -> VoidExpression- VoidPipe :: Typeable x => ProducerExpression x -> ConsumerExpression x -> VoidExpression- Exit :: VoidExpression--data ProducerExpression x where- PrimitiveProducer :: Typeable x => String -> Producer IO x () -> ProducerExpression x- NativeProducerCommand :: String -> ProducerExpression Char- VoidSource :: Typeable x => VoidExpression -> ProducerExpression x- ProducerPipe :: (Typeable x, Typeable y) => ProducerExpression x -> TransducerExpression x y -> ProducerExpression y- FileSource :: String -> ProducerExpression Char- StdInSource :: ProducerExpression Char- Sequence :: Typeable x => ProducerExpression x -> ProducerExpression x -> ProducerExpression x--data ConsumerExpression x where- NativeConsumerCommand :: String -> ConsumerExpression Char- VoidSink :: Typeable x => VoidExpression -> ConsumerExpression x- ConsumerPipe :: (Typeable x, Typeable y) => TransducerExpression x y -> ConsumerExpression y -> ConsumerExpression x- FileSink :: String -> ConsumerExpression Char- FileAppendSink :: String -> ConsumerExpression Char- SuppressingConsumer :: Typeable x => ConsumerExpression x- ErrorSink :: Typeable x => String -> ConsumerExpression x- Tee :: Typeable x => ConsumerExpression x -> ConsumerExpression x -> ConsumerExpression x--data TransducerExpression x y where- PrimitiveTransducer :: (Typeable x, Typeable y) => String -> Transducer IO x y -> TransducerExpression x y- NativeTransducerCommand :: String -> TransducerExpression Char Char- TransducerPipe :: (Typeable x, Typeable y, Typeable z)- => TransducerExpression x y -> TransducerExpression y z -> TransducerExpression x z- TransducerJoin :: (Typeable x, Typeable y) => TransducerExpression x y -> TransducerExpression x y -> TransducerExpression x y- Select :: Typeable x => SplitterExpression x -> TransducerExpression x x- If :: (Typeable x, Typeable y)- => SplitterExpression x -> TransducerExpression x y -> TransducerExpression x y -> TransducerExpression x y- While :: Typeable x => SplitterExpression x -> TransducerExpression x x -> TransducerExpression x x- ForEach :: (Typeable x, Typeable y)- => SplitterExpression x -> TransducerExpression x y -> TransducerExpression x y -> TransducerExpression x y--data SplitterExpression x where- PrimitiveSplitter :: Typeable x => String -> Splitter IO x -> SplitterExpression x- And :: Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x- Or :: Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x- ZipWithAnd :: Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x- ZipWithOr :: Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x- Not :: Typeable x => SplitterExpression x -> SplitterExpression x- FollowedBy :: Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x- Nested :: Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x- Having :: Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x- HavingOnly :: Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x- Between :: Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x- BetweenInclusive :: Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x- First :: Typeable x => SplitterExpression x -> SplitterExpression x- Last :: Typeable x => SplitterExpression x -> SplitterExpression x- Prefix :: Typeable x => SplitterExpression x -> SplitterExpression x- Suffix :: Typeable x => SplitterExpression x -> SplitterExpression x--instance Show VoidExpression where- show (NativeVoidCommand cmd) = "NativeVoidCommand \"" ++ cmd ++ "\""- show (VoidPipe p c) = "(VoidPipe " ++ shows p (" " ++ shows c ")")- show (Exit) = "Exit"--instance Show (ProducerExpression x) where- show (PrimitiveProducer name p) = name- show (NativeProducerCommand cmd) = cmd- show (VoidSource v) = "(VoidSource " ++ shows v ")"- show (ProducerPipe p t) = "(" ++ shows p (" | " ++ shows t ")")- show (FileSource f) = "FileSource \"" ++ f ++ "\""- show (Sequence p1 p2) = "(Sequence " ++ shows p1 (" "++ shows p2 ")")--instance Show (ConsumerExpression x) where- show (NativeConsumerCommand cmd) = cmd- show (VoidSink v) = "(VoidSink " ++ shows v ")"- show (ConsumerPipe t c) = "(ConsumerPipe " ++ shows t (" " ++ shows c ")")- show (FileSink f) = "> \"" ++ f ++ "\""- show (FileAppendSink f) = ">> \"" ++ f ++ "\""- show (SuppressingConsumer) = "SuppressingConsumer"- show (ErrorSink e) = "ErrorSink \"" ++ e ++ "\""- show (Tee c1 c2) = "(" ++ shows c1 (" tee " ++ shows c2 ")")--instance Show (TransducerExpression x y) where- show (PrimitiveTransducer name t) = name- show (NativeTransducerCommand cmd) = cmd- show (TransducerPipe t1 t2) = "(" ++ shows t1 (" | " ++ shows t2 ")")- show (TransducerJoin t1 t2) = "(" ++ shows t1 (" >< " ++ shows t2 ")")- show (Select s) = "(select " ++ shows s ")"- show (If s t1 t2) = "if " ++ shows s (" then " ++ shows t1 (" else " ++ shows t2 " end if"))- show (While s t) = "while " ++ shows s (" do " ++ shows t " end while")- show (ForEach s t1 t2) = "foreach " ++ shows s (" then " ++ shows t1 (" else " ++ shows t2 " end foreach"))--instance Show (SplitterExpression x) where- show (PrimitiveSplitter name s) = name- show (And s1 s2) = shows s1 (" >& " ++ show s2)- show (Or s1 s2) = shows s1 (" >| " ++ show s2)- show (ZipWithAnd s1 s2) = shows s1 (" >& " ++ show s2)- show (ZipWithOr s1 s2) = shows s1 (" >| " ++ show s2)- show (FollowedBy s1 s2) = shows s1 (", " ++ show s2)- show (Not s) = "Not " ++ show s- show (Nested s1 s2) = shows s1 (" nested in " ++ show s2)- show (Having s1 s2) = shows s1 (" having " ++ show s2)- show (HavingOnly s1 s2) = shows s1 (" having-only " ++ show s2)- show (Between s1 s2) = shows s1 (" having " ++ show s2)- show (BetweenInclusive s1 s2) = shows s1 (" having " ++ show s2)- show (First s) = "first " ++ show s- show (Last s) = "last " ++ show s- show (Prefix s) = "prefix " ++ show s- show (Suffix s) = "suffix " ++ show s--data TaggedExpression where- TaggedCommand :: VoidExpression -> TaggedExpression- TaggedConsumer :: Typeable x => TypeTag x -> ConsumerExpression x -> TaggedExpression- TaggedProducer :: Typeable x => TypeTag x -> ProducerExpression x -> TaggedExpression- TaggedSplitter :: Typeable x => TypeTag x -> SplitterExpression x -> TaggedExpression- TaggedTransducer :: (Typeable x, Typeable y) => TypeTag x -> TypeTag y -> TransducerExpression x y -> TaggedExpression- GenericInputExpression :: (forall x. Typeable x => TypeTag x -> TaggedExpression) -> TaggedExpression- TypeErrorExpression :: TypeTag x -> TypeTag y -> String -> TaggedExpression--instance Show TaggedExpression where- show (TaggedCommand e) = "TaggedCommand " ++ show e- show (TaggedConsumer tag e) = "TaggedConsumer " ++ shows e (" :: " ++ show tag)- show (TaggedProducer tag e) = "TaggedProducer " ++ shows e (" :: " ++ show tag)- show (TaggedSplitter tag e) = "TaggedSplitter " ++ shows e (" :: " ++ show tag)- show (TaggedTransducer tag1 tag2 e) = "TaggedSplitter " ++ shows e (" :: " ++ show tag1 ++ " -> " ++ show tag2)- show (TypeErrorExpression tag1 tag2 s) = "TypeError " ++ shows s (" :: " ++ show tag1 ++ " -> " ++ show tag2)- show GenericInputExpression{} = "Cannot show a generic expression!"--data TypeTag x where- AnyTag :: TypeTag ()- ShowableTag :: (Typeable x, Show x) => TypeTag x- CharTag :: TypeTag Char- IntTag :: TypeTag Integer- ListTag :: Typeable x => TypeTag x -> TypeTag [x]- PairTag :: TypeTag x -> TypeTag y -> TypeTag (x, y)--instance Show (TypeTag x) where- show AnyTag = "Any"- show CharTag = "Char"- show IntTag = "Int"- show (ListTag x) = '[' : shows x "]"- show (PairTag x y) = "(" ++ shows x (", " ++ shows y ")")---- we use Weirich's higher-order type-safe cast to avoid deep traversals--- one can replace the type_cast with a more simple traversal-based--- version.--data CList c a = CList (c [a])-data CFlip c b a = CFlip (c a b)-data CL c a d = CL (c (d,a))-data CR c a d = CR (c (a,d))--typecast :: forall a b c. TypeTag a -> TypeTag b -> c a -> Maybe (c b)-typecast CharTag CharTag x = Just x-typecast IntTag IntTag x = Just x-typecast (ListTag a) (ListTag b) x = fmap (\(CList y)-> y) (typecast a b (CList x))-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'-typecast _ _ _ = Nothing--typecast2 :: forall a a' b b' c. TypeTag a -> TypeTag b -> TypeTag a' -> TypeTag b' -> c a b -> Maybe (c a' b')-typecast2 a b a' b' x = typecast a a' (CFlip x) >>= \(CFlip x')-> typecast b b' x'--trycast :: forall a b c. Show (c a) => TypeTag a -> TypeTag b -> (c b -> TaggedExpression) -> c a -> TaggedExpression-trycast a b wrap x = case typecast a b x of Just y -> wrap y- Nothing -> TypeErrorExpression a b (show x)--data Flag = Command | Help | Interactive | ScriptFile String | StandardInput- deriving Eq--options = [Option "c" ["command"] (NoArg Command) "Execute a single command",- Option "h" ["help"] (NoArg Help) "Show help",- Option "f" ["file"] (ReqArg ScriptFile "file") "Execute commands from a script file",- Option "i" ["interactive"] (NoArg Interactive) "Execute commands interactively",- Option "s" ["stdin"] (NoArg StandardInput) "Execute commands from the standard input"]--usageSyntax = "Usage: shsh (-c <command> | -f <file> | -i | -s) "--main = do args <- getArgs- case getOpt Permute options args- of (_, _, errors) | not (null errors) -> putStr (concat errors)- (option, _, []) | Help `elem` option -> showHelp- (options, arguments, []) | Command `elem` options -> interpret (concat (intersperse " " arguments)) >> return ()- ([ScriptFile name], [], []) -> readFile name >>= interpret >> return ()- ([Interactive], [], []) -> interact- ([StandardInput], [], []) -> getContents >>= interpret >> return ()- _ -> showHelp--showHelp = putStrLn (usageInfo usageSyntax options)--interact = do Just command <- readline "> "- addHistory command- finish <- interpret command- when (not finish) interact--interpret command = case parseExpression command- of Left position -> putStrLn ("Error at " ++ show position) >> return False- Right (TaggedCommand Exit, "", _) -> return True- Right (expression, "", _) -> execute expression >> return False- Right (expression, rest, _) -> putStrLn ("Cannot parse " ++ show rest) >> return False---execute :: TaggedExpression -> IO ()-execute (TaggedCommand command) = runPipes (evaluateVoidExpression command)-execute (TaggedProducer CharTag producer) = liftM fst (runPipes (pipe (evaluateProducerExpression producer) toStdOut))- >> hFlush stdout-execute (TaggedProducer tag _) = hPutStrLn stderr ("Expecting a Char Producer, received a " ++ shows tag " producer.")-execute (TypeErrorExpression tag1 tag2 e) = hPutStrLn stderr ("Expecting " ++ show tag2 ++ ", received " ++ show tag1- ++ " in expression " ++ e)--evaluateConsumerExpression :: Typeable x => ConsumerExpression x -> Consumer IO x ()-evaluateConsumerExpression (NativeConsumerCommand command) =- \source-> do (stdin, _, _, pid) <- liftPipe (runInteractiveCommand command)- toHandle stdin source-evaluateConsumerExpression (ConsumerPipe filter sink) = evaluateTransducerExpression filter ->> evaluateConsumerExpression sink-evaluateConsumerExpression (FileSink path) = toFile path-evaluateConsumerExpression (FileAppendSink path) = appendFile path-evaluateConsumerExpression SuppressingConsumer = consumeAndSuppress-evaluateConsumerExpression (ErrorSink message) = undefined-evaluateConsumerExpression (Tee ce1 ce2) = \source-> pipe (\sink1-> pipe (\sink2-> tee source sink1 sink2)- (evaluateConsumerExpression ce2)- )- (evaluateConsumerExpression ce1)- >> return ()--evaluateProducerExpression :: Typeable x => ProducerExpression x -> Producer IO x ()-evaluateProducerExpression (PrimitiveProducer _ producer) = producer-evaluateProducerExpression (NativeProducerCommand command) =- \sink-> do (_, stdout, _, pid) <- liftPipe (runInteractiveCommand command)- fromHandle stdout sink-evaluateProducerExpression (ProducerPipe source filter) = evaluateTransducerExpression filter <<- evaluateProducerExpression source-evaluateProducerExpression (FileSource path) = fromFile path-evaluateProducerExpression StdInSource = fromStdIn--evaluateVoidExpression :: VoidExpression -> Pipe c IO ()-evaluateVoidExpression (NativeVoidCommand command) = liftPipe (runCommand command >> return ())-evaluateVoidExpression (VoidPipe source sink) =- do pipe (evaluateProducerExpression source) (evaluateConsumerExpression sink)- return ()--evaluateTransducerExpression :: (Typeable x, Typeable y) => TransducerExpression x y -> Transducer IO x y-evaluateTransducerExpression (PrimitiveTransducer _ filter) = filter-evaluateTransducerExpression (NativeTransducerCommand command) = Transducer f- where f source sink = do (stdin, stdout, _, pid) <- liftPipe (runInteractiveCommand command)- interleavedPour source (toHandle stdin) (fromHandle stdout) sink- return []-- interleavedPour :: forall c c1 c2 m x y. (Monad m, Typeable x, Typeable y)- => Source c1 x -> Consumer m x () -> Producer m y () -> Sink c2 y -> Pipe c m ()- interleavedPour source consumer producer sink = pipe (\sink-> pipe producer (interleave sink)) consumer- >> return ()- where interleave consumerSink producerSource = interleave1- where interleave1 = canPut consumerSink- >>= flip when (get source >>= maybe interleaveEnd (\x-> put consumerSink x >> interleave2))- interleave2 = canPut sink- >>= flip when (getSuccess producerSource (\y-> put sink y >> interleave1))- interleaveEnd = canPut sink- >>= flip when (getSuccess producerSource (\y-> put sink y >> interleaveEnd))--evaluateTransducerExpression (TransducerPipe f1 f2) = evaluateTransducerExpression f1 >-> evaluateTransducerExpression f2-evaluateTransducerExpression (TransducerJoin f1 f2) = evaluateTransducerExpression f1 `join` evaluateTransducerExpression f2-evaluateTransducerExpression (Select splitter) = select (evaluateSplitterExpression splitter)-evaluateTransducerExpression (If splitter f1 f2) =- ifs (evaluateSplitterExpression splitter) (evaluateTransducerExpression f1) (evaluateTransducerExpression f2)-evaluateTransducerExpression (While splitter filter) =- evaluateTransducerExpression filter `while` evaluateSplitterExpression splitter-evaluateTransducerExpression (ForEach splitter f1 f2) =- foreach (evaluateSplitterExpression splitter) (evaluateTransducerExpression f1) (evaluateTransducerExpression f2)--evaluateSplitterExpression :: Typeable x => SplitterExpression x -> Splitter IO x-evaluateSplitterExpression (PrimitiveSplitter _ splitter) = splitter-evaluateSplitterExpression (FollowedBy s1 s2) = evaluateSplitterExpression s1 `followedBy` evaluateSplitterExpression s2-evaluateSplitterExpression (And s1 s2) = evaluateSplitterExpression s1 >& evaluateSplitterExpression s2-evaluateSplitterExpression (Or s1 s2) = evaluateSplitterExpression s1 >| evaluateSplitterExpression s2-evaluateSplitterExpression (ZipWithAnd s1 s2) = evaluateSplitterExpression s1 && evaluateSplitterExpression s2-evaluateSplitterExpression (ZipWithOr s1 s2) = evaluateSplitterExpression s1 || evaluateSplitterExpression s2-evaluateSplitterExpression (Not splitter) = snot (evaluateSplitterExpression splitter)-evaluateSplitterExpression (Nested s1 s2) = evaluateSplitterExpression s1 `nestedIn` evaluateSplitterExpression s2-evaluateSplitterExpression (Having s1 s2) = evaluateSplitterExpression s1 `having` evaluateSplitterExpression s2-evaluateSplitterExpression (HavingOnly s1 s2) = evaluateSplitterExpression s1 `havingOnly` evaluateSplitterExpression s2-evaluateSplitterExpression (Between s1 s2) = evaluateSplitterExpression s1 `between` evaluateSplitterExpression s2-evaluateSplitterExpression (BetweenInclusive s1 s2) = evaluateSplitterExpression s1 ... evaluateSplitterExpression s2-evaluateSplitterExpression (First splitter) = first (evaluateSplitterExpression splitter)-evaluateSplitterExpression (Last splitter) = last (evaluateSplitterExpression splitter)-evaluateSplitterExpression (Prefix splitter) = prefix (evaluateSplitterExpression splitter)-evaluateSplitterExpression (Suffix splitter) = suffix (evaluateSplitterExpression splitter)--specialize :: Typeable x => TypeTag x -> Parser TaggedExpression -> Parser TaggedExpression-specialize tag parser = do e <- parser- return (case e- of GenericInputExpression g -> g tag- _ -> e)--combineTransducers :: (forall x y. (Typeable x, Typeable y)- => TypeTag x -> TypeTag y -> TransducerExpression x y -> TransducerExpression x y- -> TransducerExpression x y)- -> TaggedExpression -> TaggedExpression -> TaggedExpression-combineTransducers combinator e1 e2 = - case (e1, e2)- of (TaggedTransducer tag1 tag2 t1, TaggedTransducer tag1' tag2' t2) ->- case typecast2 tag1' tag2' tag1 tag2 t2- of Just t2' -> TaggedTransducer tag1 tag2 (combinator tag1 tag2 t1 t2')- Nothing -> TypeErrorExpression tag2' tag2 (show t1)- (GenericInputExpression ge, TaggedTransducer tag1 _ _) -> combineTransducers combinator (ge tag1) e2- (TaggedTransducer tag1 _ _, GenericInputExpression ge) -> combineTransducers combinator e1 (ge tag1)- (GenericInputExpression g1, GenericInputExpression g2)- -> GenericInputExpression (\tag-> combineTransducers combinator (g1 tag) (g2 tag))- (TypeErrorExpression{}, _) -> e1- (_, TypeErrorExpression{}) -> e2--foldPipeline :: [TaggedExpression] -> TaggedExpression-foldPipeline list = foldl1 combine list- where combine :: TaggedExpression -> TaggedExpression -> TaggedExpression- combine (TaggedProducer tag p) (TaggedTransducer tag1 tag2 t)- = trycast tag tag1 (\p'-> TaggedProducer tag2 (ProducerPipe p' t)) p- combine (TaggedTransducer tag1 tag2 t1) (TaggedTransducer tag1' tag2' t2)- = trycast tag2 tag1' (\t1'-> TaggedTransducer tag1 tag2' (TransducerPipe t1' t2)) t1- combine p@(TaggedProducer tag _) (GenericInputExpression ge) = combine p (ge tag)- combine (GenericInputExpression ge) other = GenericInputExpression (\tag-> combine (ge tag) other)- combine t@(TaggedTransducer tag1 tag2 _) (GenericInputExpression ge) = combine t (ge tag2)- combine e@TypeErrorExpression{} _ = e- combine _ e@TypeErrorExpression{} = e--parseExpression :: String -> Either Int (TaggedExpression, [Char], Int)-parseExpression s = case parse partialExpressionParser "" s of- Left error -> Left (sourceLine (errorPos error))- Right result -> Right result--lexer = (makeTokenParser emptyDef{commentLine= "#"}){stringLiteral= stringLexemeParser}--partialExpressionParser :: Parser (TaggedExpression, [Char], Int)-partialExpressionParser = do whiteSpace lexer- t <- expressionParser- rest <- getInput- pos <- getPosition- return (t, rest, sourceLine pos - 1)--expressionParser :: Parser TaggedExpression-expressionParser = do tp@(TaggedProducer tag producer) <- producerPrimaryParser- whiteSpace lexer- transducers <- many (try (char '|' >> whiteSpace lexer >> transducerPrimaryParser))- let tpt = foldPipeline (tp:transducers)- whiteSpace lexer- option tpt (liftM ((,) tpt) (try (char '|' >> whiteSpace lexer >> specialize tag consumerPrimaryParser))- >>= \(TaggedTransducer tag1 tag2 transducer, TaggedConsumer tag' consumer)- -> return (trycast tag tag' (\p'-> TaggedCommand (VoidPipe p' consumer)) producer))--producerExpressionParser :: Parser TaggedExpression-producerExpressionParser = do tp@(TaggedProducer tag producer) <- producerPrimaryParser- whiteSpace lexer- (try (do char '|'- whiteSpace lexer- TaggedTransducer tag1 tag2 transducer <- transducerExpressionParser- return (trycast tag tag1 (\p'-> TaggedProducer tag2 (ProducerPipe p' transducer)) producer))- <|>- return tp)--consumerExpressionParser :: Parser TaggedExpression-consumerExpressionParser = try consumerForkParser- <|>- do TaggedTransducer tag1 tag2 transducer <- transducerExpressionParser- whiteSpace lexer- char '|'- TaggedConsumer tag' consumer <- consumerForkParser- return (trycast tag' tag2 (TaggedConsumer tag1 . ConsumerPipe transducer) consumer)--consumerForkParser :: Parser TaggedExpression-consumerForkParser = do tc@(TaggedConsumer tag first) <- consumerPrimaryParser- whiteSpace lexer- (try (do symbol lexer "tee"- TaggedConsumer tag' rest <- consumerForkParser- return (trycast tag tag' (\first'-> TaggedConsumer tag' (Tee first' rest)) first))- <|>- return tc)--voidPrimaryParser = try (symbol lexer "exit" >> return Exit)- <|> liftM NativeVoidCommand nativeCommand--producerPrimaryParser :: Parser TaggedExpression-producerPrimaryParser = try (do char '('- whiteSpace lexer- (try (do command <- nativeCommand- whiteSpace lexer- char ')'- whiteSpace lexer- char '>'- return (TaggedProducer CharTag (NativeProducerCommand command)))- <|>- do source <- producerExpressionParser- whiteSpace lexer- char ')'- return source))- <|> try (nativeSourceParser "cat")--- <|> try (nativeSourceParser "echo")- <|> try (do symbol lexer "echo"- string <- parameterParser True- return (TaggedProducer CharTag $- PrimitiveProducer ("echo " ++ string) (\sink-> putList string sink >> return ())))- <|> try (symbol lexer "stdin" >> return (TaggedProducer CharTag StdInSource))- <|> nativeSourceParser "ls"--nativeSourceParser :: String -> Parser TaggedExpression-nativeSourceParser command = do symbol lexer command- params <- nativeCommand- return (TaggedProducer CharTag (NativeProducerCommand (command ++ " " ++ params)))--consumerPrimaryParser :: Parser TaggedExpression-consumerPrimaryParser = try (do symbol lexer ">>"- file <- parameterParser True- return (TaggedConsumer CharTag (FileAppendSink file)))- <|>- try (do symbol lexer ">"- symbol lexer "("- command <- nativeCommand- whiteSpace lexer- symbol lexer ")"- return (TaggedConsumer CharTag (NativeConsumerCommand command)))- <|>- try (do symbol lexer ">"- file <- parameterParser True- return (TaggedConsumer CharTag (FileSink file)))- <|>- try (do symbol lexer "null"- return (GenericInputExpression ((\tag-> TaggedConsumer tag SuppressingConsumer))))- <|>- do symbol lexer "error"- message <- (try (parameterParser True) <|> return "Error sink reached!")- return (GenericInputExpression (\tag-> TaggedConsumer tag (ErrorSink message)))--transducerExpressionParser :: Parser TaggedExpression-transducerExpressionParser = do first <- transducerPrimaryParser- (try (do rest <- many1 (try (whiteSpace lexer >> symbol lexer "|" >> transducerPrimaryParser))- return (foldPipeline (first:rest)))- <|>- try (do rest <- many1 (try (whiteSpace lexer >> symbol lexer "><" >> transducerPrimaryParser))- return (foldr1 (combineTransducers (const $ const TransducerJoin)) (first:rest)))- <|>- return first)- where tagged :: (forall x y. (Typeable x, Typeable y)- => TransducerExpression x y -> TransducerExpression x y -> TransducerExpression x y)- -> TaggedExpression -> TaggedExpression -> TaggedExpression- tagged combinator (TaggedTransducer tag1 tag2 t1) (TaggedTransducer tag1' tag2' t2)- = case typecast2 tag1 tag2 tag1' tag2' t1 of Just t1' -> TaggedTransducer tag1' tag2' (combinator t1' t2)- Nothing -> TypeErrorExpression tag1 tag1' (show t1)--splitterExpressionParser :: Parser TaggedExpression-splitterExpressionParser = do first@(TaggedSplitter tag one) <- splitterPrimaryParser- whiteSpace lexer- (try (do rest <- many1 (try (symbol lexer ">," >> splitterPrimaryParser))- return (foldr1 (tagged FollowedBy) (first:rest)))- <|>- try (do rest <- many1 (try (symbol lexer ">|" >> splitterPrimaryParser))- return (foldr1 (tagged Or) (first:rest)))- <|>- try (do rest <- many1 (try (symbol lexer ">&" >> splitterPrimaryParser))- return (foldr1 (tagged And) (first:rest)))- <|>- try (do rest <- many1 (try (symbol lexer "||" >> splitterPrimaryParser))- return (foldr1 (tagged ZipWithOr) (first:rest)))- <|>- try (do rest <- many1 (try (symbol lexer "&&" >> splitterPrimaryParser))- return (foldr1 (tagged ZipWithAnd) (first:rest)))- <|>- try (do rest <- many1 (try (symbol lexer "..." >> splitterPrimaryParser))- return (foldr1 (tagged BetweenInclusive) (first:rest)))- <|>- try (do symbol lexer "having"- TaggedSplitter tag' other <- splitterPrimaryParser- return (trycast tag tag' (\one'-> TaggedSplitter tag' (Having one' other)) one))- <|>- try (do symbol lexer "having-only"- TaggedSplitter tag' other <- splitterPrimaryParser- return (trycast tag tag' (\one'-> TaggedSplitter tag' (HavingOnly one' other)) one))- <|>- return first)- where tagged :: (forall x. Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x)- -> TaggedExpression -> TaggedExpression -> TaggedExpression- tagged combinator (TaggedSplitter tag1 s1) (TaggedSplitter tag2 s2)- = trycast tag1 tag2 (\s1'-> TaggedSplitter tag2 (combinator s1' s2)) s1--transducerPrimaryParser :: Parser TaggedExpression-transducerPrimaryParser = try (do symbol lexer "("- filter <- transducerExpressionParser- symbol lexer ")"- return filter)- <|>- try (do symbol lexer "id"- return (GenericInputExpression (\tag-> TaggedTransducer tag tag (PrimitiveTransducer "id" asis))))- <|>- try (do symbol lexer "suppress"- return (GenericInputExpression (\tag-> TaggedTransducer tag tag (PrimitiveTransducer "suppress" suppress))))- <|>- try (do symbol lexer "uppercase"- return (TaggedTransducer CharTag CharTag (PrimitiveTransducer "uppercase" uppercase)))- <|>- try (do symbol lexer "count"- return (GenericInputExpression (\tag-> TaggedTransducer tag IntTag (PrimitiveTransducer "count" count))))- <|>- try (do symbol lexer "show"- return (TaggedTransducer IntTag (ListTag CharTag) (PrimitiveTransducer "show" toString)))- <|>- try (do symbol lexer "concatenate"- return (GenericInputExpression $- \tag-> case tag- of ListTag tag'- -> TaggedTransducer tag tag' (PrimitiveTransducer "concatenate" concatenate)- _ -> TypeErrorExpression tag (ListTag AnyTag) "concatenate"))- <|>- try (do symbol lexer "group"- return (GenericInputExpression $- \tag-> TaggedTransducer tag (ListTag tag) (PrimitiveTransducer "group" group)))- <|>- try (do symbol lexer "prepend"- prefix <- parameterParser True- return (TaggedTransducer CharTag CharTag (PrimitiveTransducer ("prepend " ++ prefix) (prepend prefix))))- <|>- try (do symbol lexer "append"- suffix <- parameterParser True- return (TaggedTransducer CharTag CharTag (PrimitiveTransducer ("append " ++ suffix) (append suffix))))- <|>- try (do symbol lexer "substitute"- replacement <- parameterParser True- return (TaggedTransducer CharTag CharTag- (PrimitiveTransducer ("substitute " ++ replacement) (substitute replacement))))- <|>- try (do symbol lexer "select"- TaggedSplitter tag splitter <- splitterPrimaryParser- return (TaggedTransducer tag tag (Select splitter)))- <|>- try (do symbol lexer "if"- TaggedSplitter tag splitter <- splitterExpressionParser- whiteSpace lexer- symbol lexer "then"- true <- transducerExpressionParser- false <- (try (symbol lexer "else" >> transducerExpressionParser)- <|> return (TaggedTransducer tag tag (PrimitiveTransducer "id" asis)))- symbol lexer "end"- option "" (symbol lexer "if")- return (combineBranches (If splitter) tag true false))- <|>- try (do symbol lexer "while"- TaggedSplitter tag splitter <- splitterExpressionParser- whiteSpace lexer- symbol lexer "do"- TaggedTransducer tag' tag'' body <- transducerExpressionParser- whiteSpace lexer- symbol lexer "end"- option "" (symbol lexer "while")- return (case (typecast tag tag' splitter, typecast tag'' tag' body)- of (Just test, Just body) -> TaggedTransducer tag' tag' (While test body)))- <|>- try (do symbol lexer "foreach"- TaggedSplitter tag splitter <- splitterExpressionParser- whiteSpace lexer- symbol lexer "then"- trueBranch <- transducerExpressionParser- whiteSpace lexer- falseBranch <- (try (symbol lexer "else" >> transducerExpressionParser)- <|> return (TaggedTransducer tag tag (PrimitiveTransducer "id" asis)))- whiteSpace lexer- symbol lexer "end"- option "" (symbol lexer "foreach")- return (combineBranches (ForEach splitter) tag trueBranch falseBranch))- <|>- liftM (TaggedTransducer CharTag CharTag . NativeTransducerCommand) nativeCommand--combineBranches :: forall x. Typeable x- => (forall y. Typeable y => TransducerExpression x y -> TransducerExpression x y -> TransducerExpression x y)- -> TypeTag x -> TaggedExpression -> TaggedExpression -> TaggedExpression-combineBranches combinator tag b1 b2 = - case (b1, b2)- of (TaggedTransducer tag1 tag2 true, TaggedTransducer tag1' tag2' false) ->- case (typecast2 tag1 tag2 tag tag2 true, typecast2 tag1' tag2' tag tag2 false)- of (Just true', Just false') -> TaggedTransducer tag tag2 (combinator true' false')- (Nothing, _) -> TypeErrorExpression tag1 tag (show true)- (_, Nothing) -> TypeErrorExpression tag2' tag2 (show true)- (GenericInputExpression ge, _) -> combineBranches combinator tag (ge tag) b2- (_, GenericInputExpression ge) -> combineBranches combinator tag b1 (ge tag)- (TypeErrorExpression{}, _) -> b1- (_, TypeErrorExpression{}) -> b2--splitterPrimaryParser :: Parser TaggedExpression-splitterPrimaryParser = try (do symbol lexer "("- splitter <- splitterExpressionParser- symbol lexer ")"- return splitter)- <|>- try (do symbol lexer ">!"- TaggedSplitter tag splitter <- splitterPrimaryParser- return (TaggedSplitter tag (Not splitter)))- <|>- try (do symbol lexer "prefix"- TaggedSplitter tag splitter <- splitterPrimaryParser- return (TaggedSplitter tag (Prefix splitter)))- <|>- try (do symbol lexer "suffix"- TaggedSplitter tag splitter <- splitterPrimaryParser- return (TaggedSplitter tag (Suffix splitter)))- <|>- try (do symbol lexer "first"- TaggedSplitter tag splitter <- splitterPrimaryParser- return (TaggedSplitter tag (First splitter)))- <|>- try (do symbol lexer "last"- TaggedSplitter tag splitter <- splitterPrimaryParser- return (TaggedSplitter tag (Last splitter)))- <|>- try (do symbol lexer "whitespace"- return (TaggedSplitter CharTag (PrimitiveSplitter "whitespace" whitespace)))- <|>- try (do symbol lexer "line"- return (TaggedSplitter CharTag (PrimitiveSplitter "line" line)))- <|>- try (do symbol lexer "letters"- return (TaggedSplitter CharTag (PrimitiveSplitter "letters" letters)))- <|>- try (do symbol lexer "digits"- return (TaggedSplitter CharTag (PrimitiveSplitter "digits" digits)))- <|>- try (do symbol lexer "substring"- part <- parameterParser True- return (TaggedSplitter CharTag (PrimitiveSplitter ("substring " ++ part) (substring part))))- <|>- do symbol lexer "nested"- TaggedSplitter tag1 core <- splitterExpressionParser- whiteSpace lexer- symbol lexer "in"- TaggedSplitter tag2 shell <- splitterExpressionParser- whiteSpace lexer- symbol lexer "end"- option "" (symbol lexer "nested")- return (trycast tag1 tag2 (\core'-> TaggedSplitter tag2 (Nested core' shell)) core)- <|>- do symbol lexer "between"- TaggedSplitter tag1 left <- splitterExpressionParser- whiteSpace lexer- symbol lexer "and"- TaggedSplitter tag2 right <- splitterExpressionParser- whiteSpace lexer- symbol lexer "end"- option "" (symbol lexer "between")- return (trycast tag1 tag2 (\left'-> TaggedSplitter tag2 (Between left' right)) left)--nativeCommand :: Parser String-nativeCommand = do parts <- many (try (lexeme lexer (parameterParser False)))- return (concat (intersperse " " parts))--parameterParser :: Bool -> Parser String-parameterParser normalize = do chars <- many (noneOf " \t\n'\"`\\()[]{}<>|&")- (do try (string "\\n")- rest <- (parameterParser normalize <|> return "")- return (chars ++ '\n' : rest)- <|>- do try (string "\\t")- rest <- (parameterParser normalize <|> return "")- return (chars ++ '\t' : rest)- <|>- do next <- escape- rest <- (parameterParser normalize <|> return "")- return (chars ++ next : rest)- <|>- do quote <- oneOf "'\"`"- string <- many (noneOf (quote : "\\") <|> escape)- char quote- rest <- (parameterParser normalize <|> return "")- return (chars ++ (if normalize then string else quote : (string ++ [quote])) ++ rest)- <|>- do try (char '(')- whiteSpace lexer- inside <- nativeCommand- char ')'- rest <- (parameterParser normalize <|> return "")- return (chars ++ '(' : inside ++ ')' : rest)- <|>- do try (char '[')- whiteSpace lexer- inside <- nativeCommand- char ']'- rest <- parameterParser normalize- return (chars ++ '[' : inside ++ ']' : rest)- <|>- do try (char '{')- whiteSpace lexer- inside <- nativeCommand- char '}'- rest <- (parameterParser normalize <|> return "")- return (chars ++ '{' : inside ++ '}' : rest)- <|>- do when (null chars) pzero+{-# LANGUAGE ScopedTypeVariables, Rank2Types, GADTs, FlexibleContexts, PatternSignatures #-}++module Main where++import Prelude hiding ((&&), (||), appendFile, interact, last, sequence)+import qualified Prelude+import Data.List (intersperse, partition)+import Data.Maybe (fromJust)+import Data.Typeable (Typeable)+import Control.Concurrent (forkIO)+import Control.Exception (evaluate)+import Control.Monad (liftM, when)+import Text.Parsec hiding (count)+import Text.Parsec.String+import Text.Parsec.Language (emptyDef)+import Text.Parsec.Token+import System.Console.GetOpt+import System.Console.Readline+import System.Environment (getArgs)+import System.IO (BufferMode (NoBuffering), hFlush, hIsWritable, hPutStrLn, hReady, hSetBuffering, stderr, stdout)+import qualified System.Process as Process++import Control.Concurrent.MVar+import Debug.Trace (trace)+import System.IO (Handle, IOMode (ReadMode, WriteMode, AppendMode), openFile, hClose,+ hGetChar, hGetContents, hPutChar, hFlush, hIsEOF, hClose, putChar, isEOF, stdout)++import Control.Concurrent.SCC.Foundation+import Control.Concurrent.SCC.ComponentTypes+import Control.Concurrent.SCC.Components+import Control.Concurrent.SCC.Combinators++data Expression where+ -- Compiled expressions+ Compiled :: Component x => TypeTag x -> x -> Expression+ -- Generic expressions+ NativeCommand :: String -> Expression+ TypeError :: TypeTag x -> TypeTag y -> Expression -> Expression+ Join :: Expression -> Expression -> Expression+ Sequence :: Expression -> Expression -> Expression+ Pipe :: Expression -> Expression -> Expression+ If :: Expression -> Expression -> Expression -> Expression+ ForEach :: Expression -> Expression -> Expression -> Expression+ -- Void expressions, i.e. commands+ Exit :: Expression+ -- Producer constructs+ FromList :: String -> Expression+ FileProducer :: String -> Expression+ StdInProducer :: Expression+ -- Consumer constructs+ FileConsumer :: String -> Expression+ FileAppend :: String -> Expression+ Suppress :: Expression+ ErrorConsumer :: String -> Expression+ -- Transducer constructs+ Select :: Expression -> Expression+ While :: Expression -> Expression -> Expression+ IdentityTransducer :: Expression+ Count :: Expression+ Concatenate :: Expression+ Group :: Expression+ Uppercase :: Expression+ ShowTransducer :: Expression+ -- Splitter constructs+ EverythingSplitter :: Expression+ NothingSplitter :: Expression+ WhitespaceSplitter :: Expression+ LineSplitter :: Expression+ LetterSplitter :: Expression+ DigitSplitter :: Expression+ OneSplitter :: Expression+ SubstringSplitter :: String -> Expression+ And :: Expression -> Expression -> Expression+ Or :: Expression -> Expression -> Expression+ ZipWithAnd :: Expression -> Expression -> Expression+ ZipWithOr :: Expression -> Expression -> Expression+ Not :: Expression -> Expression+ FollowedBy :: Expression -> Expression -> Expression+ Nested :: Expression -> Expression -> Expression+ Having :: Expression -> Expression -> Expression+ HavingOnly :: Expression -> Expression -> Expression+ Between :: Expression -> Expression -> Expression+ First :: Expression -> Expression+ Last :: Expression -> Expression+ Prefix :: Expression -> Expression+ Suffix :: Expression -> Expression+ Prepend :: Expression -> Expression+ Append :: Expression -> Expression+ Substitute :: Expression -> Expression+ StartOf :: Expression -> Expression+ EndOf :: Expression -> Expression++instance Show Expression where+ showsPrec _ (Compiled tag c) rest = "compiled " ++ shows tag rest+ showsPrec _ (NativeCommand cmd) rest = "native \"" ++ cmd ++ "\"" ++ rest+ showsPrec p (Pipe left right) rest | p < 3 = showsPrec 3 left (" | " ++ showsPrec 2 right rest)+ showsPrec _ (If s t f) rest = "if " ++ showsPrec 0 s (" then " ++ showsPrec 0 t (" else " ++ showsPrec 0 f (" end if" ++ rest)))+ showsPrec _ (ForEach s t f) rest = "foreach " ++ showsPrec 0 s (" then " ++ showsPrec 0 t+ (" else " ++ showsPrec 0 f (" end foreach" ++ rest)))+ showsPrec _ Exit rest = "Exit" ++ rest+ showsPrec _ (FileProducer f) rest = "FileProducer \"" ++ f ++ "\"" ++ rest+ showsPrec _ (FromList str) rest = "echo \"" ++ str ++ "\"" ++ rest+ showsPrec 0 (Sequence p1 p2) rest = showsPrec 2 p1 (";\n" ++ showsPrec 0 p2 rest)+ showsPrec 1 (Sequence p1 p2) rest = showsPrec 2 p1 ("; " ++ showsPrec 1 p2 rest)+ showsPrec p e@Sequence{} rest = "(" ++ showsPrec 1 e (')' : rest)+ showsPrec 0 (Join p1 p2) rest = showsPrec 2 p1 (" &\n" ++ showsPrec 0 p2 rest)+ showsPrec 1 (Join p1 p2) rest = showsPrec 2 p1 (" & " ++ showsPrec 1 p2 rest)+ showsPrec p e@Join{} rest = "(" ++ showsPrec 1 e (')' : rest)+ showsPrec _ (FileConsumer f) rest = "> \"" ++ f ++ "\"" ++ rest+ showsPrec _ (FileAppend f) rest = ">> \"" ++ f ++ "\"" ++ rest+ showsPrec _ (Suppress) rest = "suppress" ++ rest+ showsPrec _ (ErrorConsumer e) rest = "error \"" ++ e ++ "\"" ++ rest+ showsPrec p (Select s) rest | p < 4 = "select " ++ showsPrec 4 s rest+ showsPrec _ (While s t) rest = "while " ++ showsPrec 0 s (" do " ++ showsPrec 0 t (" end while" ++ rest))+ showsPrec p (And s1 s2) rest | p < 4 = showsPrec 4 s1 (" >& " ++ showsPrec 4 s2 rest)+ showsPrec p (Or s1 s2) rest | p < 4 = showsPrec 4 s1 (" >| " ++ showsPrec 4 s2 rest)+ showsPrec p (ZipWithAnd s1 s2) rest | p < 4 = showsPrec 4 s1 (" && " ++ showsPrec 4 s2 rest)+ showsPrec p (ZipWithOr s1 s2) rest | p < 4 = showsPrec 4 s1 (" || " ++ showsPrec 4 s2 rest)+ showsPrec p (FollowedBy s1 s2) rest | p < 4 = showsPrec 4 s1 (", " ++ showsPrec 4 s2 rest)+ showsPrec p (Not s) rest | p < 4 = ">! " ++ showsPrec 4 s rest+ showsPrec p (Nested s1 s2) rest | p < 4 = showsPrec 4 s1 (" nested in " ++ showsPrec 4 s2 rest)+ showsPrec p (Having s1 s2) rest | p < 4 = showsPrec 4 s1 (" having " ++ showsPrec 4 s2 rest)+ showsPrec p (HavingOnly s1 s2) rest | p < 4 = showsPrec 4 s1 (" having-only " ++ showsPrec 4 s2 rest)+ showsPrec p (Between s1 s2) rest | p < 4 = showsPrec 4 s1 (" ... " ++ showsPrec 4 s2 rest)+ showsPrec p (First s) rest | p < 4 = "first " ++ showsPrec 4 s rest+ showsPrec p (Last s) rest | p < 4 = "last " ++ showsPrec 4 s rest+ showsPrec p (Prefix s) rest | p < 4 = "prefix " ++ showsPrec 4 s rest+ showsPrec p (Suffix s) rest | p < 4 = "suffix " ++ showsPrec 4 s rest+ showsPrec p (Prepend s) rest | p < 4 = "prepend " ++ showsPrec 4 s rest+ showsPrec p (Append s) rest | p < 4 = "append " ++ showsPrec 4 s rest+ showsPrec p (Substitute s) rest | p < 4 = "substitute " ++ showsPrec 4 s rest+ showsPrec p (StartOf s) rest | p < 4 = "start-of " ++ showsPrec 4 s rest+ showsPrec p (EndOf s) rest | p < 4 = "end-of " ++ showsPrec 4 s rest+ showsPrec _ IdentityTransducer rest = "id" ++ rest+ showsPrec _ Count rest = "count" ++ rest+ showsPrec _ Concatenate rest = "concatenate" ++ rest+ showsPrec _ Group rest = "group" ++ rest+ showsPrec _ Uppercase rest = "uppercase" ++ rest+ showsPrec _ ShowTransducer rest = "show" ++ rest+ showsPrec _ EverythingSplitter rest = "everything" ++ rest+ showsPrec _ NothingSplitter rest = "nothing" ++ rest+ showsPrec _ WhitespaceSplitter rest = "whitespace" ++ rest+ showsPrec _ LineSplitter rest = "line" ++ rest+ showsPrec _ LetterSplitter rest = "letters" ++ rest+ showsPrec _ DigitSplitter rest = "digits" ++ rest+ showsPrec _ OneSplitter rest = "one" ++ rest+ showsPrec _ (SubstringSplitter s) rest = "substring " ++ shows s rest+ showsPrec _ (TypeError tag1 tag2 e) rest = ("Type error: expecting " ++ show tag2 ++ ", received " ++ show tag1+ ++ "\nin expression " ++ showsPrec 9 e rest)+ showsPrec p e rest | p > 0 = "(" ++ showsPrec 0 e (')' : rest)++data TypeTag x where+ -- Data type tags+ AnyTag :: TypeTag ()+ UnitTag :: TypeTag ()+ ShowableTag :: (Typeable x, Show x) => TypeTag x+ CharTag :: TypeTag Char+ IntTag :: TypeTag Integer+ ListTag :: Typeable x => TypeTag x -> TypeTag [x]+ PairTag :: TypeTag x -> TypeTag y -> TypeTag (x, y)+ -- Streaming component type tags+ CommandTag :: TypeTag (Performer IO ())+ ConsumerTag :: Typeable x => TypeTag x -> TypeTag (Consumer IO x ())+ ProducerTag :: Typeable x => TypeTag x -> TypeTag (Producer IO x ())+ SplitterTag :: Typeable x => TypeTag x -> TypeTag (Splitter IO x)+ TransducerTag :: (Typeable x, Typeable y) => TypeTag x -> TypeTag y -> TypeTag (Transducer IO x y)+ GenericInputTag :: forall x y. (Typeable x, Typeable y) => (TypeTag x -> TypeTag y) -> TypeTag y++instance Show (TypeTag x) where+ show AnyTag = "Any"+ show UnitTag = "()"+ show CharTag = "Char"+ show IntTag = "Int"+ show (ListTag x) = '[' : shows x "]"+ show (PairTag x y) = "(" ++ shows x (", " ++ shows y ")")+ show CommandTag = "Command"+ show (ConsumerTag x) = "Consumer " ++ show x+ show (ProducerTag x) = "Producer " ++ show x+ show (SplitterTag x) = "Splitter " ++ show x+ 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 CSplitter c x = CSplitter (c (Splitter IO x))++data CList c a = CList (c [a])+data CFlip c b a = CFlip (c a b)+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))++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 IntTag IntTag x = Just x+typecast (ListTag a) (ListTag b) x = fmap (\(CList y)-> y) (typecast a b (CList x))+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'+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 (SplitterTag a) (SplitterTag b) x = fmap (\(CSplitter y)-> y) (typecast a b (CSplitter 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 Just (CTL x') -> case h (CTR x')+ of Just (CTR y') -> Just y'+typecast _ _ _ = 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)+ of Just (Just y) -> constructor y+ Nothing -> TypeError tag1 tag2 e++data Flag = Command | Help | Interactive | PrettyPrint | ScriptFile String | StandardInput | Threads String+ deriving Eq++data InputSource = UnspecifiedSource | CommandLineSource | InteractiveSource | ScriptFileSource String | StandardInputSource++data Flags = Flags {helpFlag :: Bool,+ inputSourceFlag :: InputSource,+ prettyPrintFlag :: Bool,+ threadCount :: Maybe Int}++flagList = [Option "c" ["command"] (NoArg Command) "Execute a single command",+ Option "p" ["prettyprint"] (NoArg PrettyPrint) "Pretty print the input expression instead of executing it",+ Option "h" ["help"] (NoArg Help) "Show help",+ Option "f" ["file"] (ReqArg ScriptFile "file") "Execute commands from a script file",+ Option "i" ["interactive"] (NoArg Interactive) "Execute commands interactively",+ Option "s" ["stdin"] (NoArg StandardInput) "Execute commands from the standard input",+ Option "t" ["threads"] (ReqArg Threads "threads") "Specify number of threads to use"]++usageSyntax = "Usage: shsh (-c <command> | -f <file> | -i | -s) "++main = do args <- getArgs+ let (specifiedOptions, arguments, errors) = getOpt Permute flagList args+ emptyOptions = Flags {helpFlag = False,+ inputSourceFlag = UnspecifiedSource,+ prettyPrintFlag = False,+ threadCount = Nothing}+ options = foldr extractOption emptyOptions specifiedOptions+ extractOption Command options@Flags{inputSourceFlag= UnspecifiedSource} = options{inputSourceFlag= CommandLineSource}+ extractOption Help options = options{helpFlag= True}+ extractOption Interactive options@Flags{inputSourceFlag= UnspecifiedSource}+ = options{inputSourceFlag= InteractiveSource}+ extractOption StandardInput options@Flags{inputSourceFlag= UnspecifiedSource}+ = options{inputSourceFlag= StandardInputSource}+ extractOption PrettyPrint options = options{prettyPrintFlag= True}+ extractOption (ScriptFile name) options@Flags{inputSourceFlag= UnspecifiedSource}+ = options{inputSourceFlag= ScriptFileSource name}+ extractOption (Threads count) options@Flags{threadCount= Nothing} = options{threadCount= Just (read count)}+ if not (null errors) Prelude.|| helpFlag options+ then showHelp+ else case inputSourceFlag options+ of CommandLineSource -> interpret options (concat (intersperse " " arguments)) >> return ()+ InteractiveSource -> interact options+ ScriptFileSource name -> readFile name >>= interpret options >> return ()+ StandardInputSource -> getContents >>= interpret options >> return ()+ UnspecifiedSource -> interact options++prettyprint options expression = print expression+ >> case compile UnitTag expression+ of Compiled tag component -> putStrLn "::" >> print tag+ >> putStrLn (showComponentTree $ adjust options component)+ e@TypeError{} -> print e++showHelp = putStrLn (usageInfo usageSyntax flagList)++interact options = do Just command <- readline "> "+ addHistory command+ finish <- interpret options command+ when (not finish) (interact options)++interpret options command = case parseExpression command+ of Left position -> hPutStrLn stderr ("Error at " ++ show position) >> return False+ Right (Exit, "", _) -> return True+ Right (expression, "", _) -> (if (prettyPrintFlag options)+ then prettyprint options expression+ else case compile UnitTag expression+ of e@Compiled{} -> execute options e+ e@TypeError{} -> print e)+ >> return False+ Right (expression, rest, _) -> hPutStrLn stderr ("Cannot parse \"" ++ rest+ ++ "\"\nafter " ++ show expression)+ >> return False++execute :: Flags -> Expression -> IO ()+execute options (Compiled CommandTag command) = runPipes (perform $ adjust options command)+execute options (Compiled (ProducerTag CharTag) producer) = liftM fst (runPipes (pipe (produce $ adjust options producer)+ (consume toStdOut)))+ >> hFlush stdout+execute options (Compiled tag _) = hPutStrLn stderr ("Expecting a command or a Producer Char, received a " ++ show tag)++adjust Flags{threadCount= Just threads} component = usingThreads threads component+adjust _ component = component++compile :: Typeable x => TypeTag x -> Expression -> Expression+compile inputTag e@Compiled{} = e+compile inputTag e@TypeError{} = e+compile inputTag (Pipe left right)+ = case compile inputTag left+ of Compiled tag@(ProducerTag tag1) p+ -> case compile tag1 right+ of Compiled (ConsumerTag tag2) c -> trycast tag (ProducerTag tag2) p left $ \p'-> Compiled CommandTag (p' >-> c)+ Compiled (TransducerTag tag2 tag3) t -> trycast tag (ProducerTag tag2) p left $+ \p'-> Compiled (ProducerTag tag3) (p' >-> t)+ e@TypeError{} -> e+ Compiled (TransducerTag tag1 tag2) t+ -> case compile tag2 right+ of Compiled tag3@ConsumerTag{} c -> trycast tag3 (ConsumerTag tag2) c right $+ \c'-> Compiled (ConsumerTag tag1) (t >-> c')+ Compiled tag@(TransducerTag tag3 tag4) t2 -> trycast tag (TransducerTag tag2 tag4) t2 right $+ \t2'-> Compiled (TransducerTag tag1 tag4) (t >-> t2')+ e@TypeError{} -> e+ e@TypeError{} -> e+compile UnitTag (NativeCommand command)+ = Compiled (ProducerTag CharTag) (liftAtomicProducer command ioCost $+ \sink-> do (_, stdout, _, pid) <- liftPipe (Process.runInteractiveCommand command)+ produce (fromHandle stdout True) sink)+compile UnitTag (FileProducer path) = Compiled (ProducerTag CharTag) (fromFile path)+compile UnitTag StdInProducer = Compiled (ProducerTag CharTag) fromStdIn+compile inputTag (FromList string) = Compiled (ProducerTag CharTag) (liftAtomicProducer "putList" 1 $+ \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) (liftAtomicTransducer command ioCost f)+ where f source sink = do (stdin, stdout, stderr, pid) <- liftPipe (Process.runInteractiveCommand command)+ liftPipe (do hSetBuffering stdin NoBuffering+ hSetBuffering stdout NoBuffering+ err <- hGetContents stderr+ forkIO (evaluate (length err) >> return ()))+ interleave source stdin pid stdout sink+ return []+ interleave :: forall c. Source c Char -> Handle -> Process.ProcessHandle -> Handle -> Sink c Char -> Pipe c IO ()+ interleave source stdin pid stdout sink = interleave1+ where interleave1 = get source+ >>= maybe+ (liftPipe (hClose stdin) >> interleaveEnd)+ (\x-> liftPipe (Process.getProcessExitCode pid)+ >>= maybe+ (liftPipe (hPutChar stdin x) >> interleave2)+ (const interleave2))+ interleave2 = canPut sink+ >>= flip when (liftPipe (hReady stdout)+ >>= flip when (liftPipe (hGetChar stdout)+ >>= put sink+ >> return ())+ >> interleave1)+ interleaveEnd = canPut sink+ >>= flip when (liftPipe (hIsEOF stdout)+ >>= cond+ (liftPipe $ hClose stdout)+ (liftPipe (hGetChar stdout)+ >>= put sink+ >> interleaveEnd))+compile inputTag (Select e) = case compile inputTag e+ of Compiled (SplitterTag tag) s -> Compiled (TransducerTag tag tag) (select s)+ Compiled tag _ -> TypeError tag (SplitterTag inputTag) e+ e'@TypeError{} -> e'+compile inputTag (While condition body)+ = case (compile inputTag condition, compile inputTag body)+ of (Compiled (SplitterTag tag1) s, Compiled tag2@TransducerTag{} t)+ -> let tag2' = TransducerTag tag1 tag1+ in trycast tag2 tag2' t body (\t'-> Compiled tag2' (while t' s))+compile inputTag (FollowedBy left right) = combineSplittersOfSameType followedBy inputTag left right+compile inputTag (And left right) = combineSplittersOfSameType (>&) inputTag left right+compile inputTag (Or left right) = combineSplittersOfSameType (>|) inputTag left right+compile inputTag (ZipWithAnd left right) = combineSplittersOfSameType (&&) inputTag left right+compile inputTag (ZipWithOr left right) = combineSplittersOfSameType (||) inputTag left right+compile inputTag (Nested left right) = combineSplittersOfSameType nestedIn inputTag left right+compile inputTag (Having left right) = combineSplittersOfSameType having inputTag left right+compile inputTag (HavingOnly left right) = combineSplittersOfSameType havingOnly inputTag left right+compile inputTag (Between left right) = combineSplittersOfSameType (...) inputTag left right+compile inputTag (Not splitter) = wrapSplitter snot inputTag splitter+compile inputTag (First splitter) = wrapSplitter first inputTag splitter+compile inputTag (Last splitter) = wrapSplitter last inputTag splitter+compile inputTag (Prefix splitter) = wrapSplitter prefix inputTag splitter+compile inputTag (Suffix splitter) = wrapSplitter suffix inputTag splitter+compile inputTag (StartOf splitter) = wrapSplitter startOf inputTag splitter+compile inputTag (EndOf splitter) = wrapSplitter endOf inputTag splitter+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 IdentityTransducer = Compiled (TransducerTag inputTag inputTag) asis+compile inputTag Count = Compiled (TransducerTag inputTag IntTag) count+compile inputTag@(ListTag itemTag) Concatenate = Compiled (TransducerTag inputTag itemTag) concatenate+compile inputTag Concatenate = TypeError inputTag (ListTag AnyTag) Concatenate+compile inputTag Group = Compiled (TransducerTag inputTag (ListTag inputTag)) group+compile CharTag Uppercase = Compiled (TransducerTag CharTag CharTag) uppercase+compile inputTag Uppercase = TypeError (TransducerTag CharTag CharTag) (TransducerTag inputTag inputTag) Uppercase+compile inputTag@CharTag ShowTransducer = Compiled (TransducerTag inputTag (ListTag CharTag)) toString+compile inputTag@IntTag ShowTransducer = 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) everything+compile inputTag NothingSplitter = Compiled (SplitterTag inputTag) nothing+compile inputTag WhitespaceSplitter = Compiled (SplitterTag CharTag) whitespace+compile inputTag LineSplitter = Compiled (SplitterTag CharTag) line+compile inputTag LetterSplitter = Compiled (SplitterTag CharTag) letters+compile inputTag DigitSplitter = Compiled (SplitterTag CharTag) digits+compile inputTag OneSplitter = Compiled (SplitterTag inputTag) one+compile CharTag (SubstringSplitter part) = Compiled (SplitterTag CharTag) (substring part)+compile inputTag e@SubstringSplitter{} = TypeError (SplitterTag CharTag) (SplitterTag inputTag) e++compile inputTag expression = error ("Cannot compile " ++ show expression ++ " with input " ++ show inputTag)++compileJoin :: forall t. Typeable t =>+ (forall t1 t2 t3 m x y c1 c2 c3. JoinableComponentPair t1 t2 t3 m x y c1 c2 c3 => c1 -> c2 -> c3)+ -> TypeTag t -> Expression -> Expression -> Expression+compileJoin combinator inputTag e1 e2 = case (compile inputTag e1, compile inputTag e2)+ of (Compiled CommandTag c1, Compiled CommandTag c2)+ -> Compiled CommandTag (combinator c1 c2)+ (Compiled tag1@ProducerTag{} p1, Compiled tag2@ProducerTag{} p2)+ -> trycast tag2 tag1 p2 e2 (\p2'-> Compiled tag1 (combinator p1 p2'))+ (Compiled tag1@ConsumerTag{} c1, Compiled tag2@ConsumerTag{} c2)+ -> trycast tag2 tag1 c2 e2 (\c2'-> Compiled tag1 (combinator c1 c2'))+ (Compiled tag1@TransducerTag{} t1, Compiled tag2@TransducerTag{} t2)+ -> trycast tag2 tag1 t2 e2 (\t2'-> Compiled tag1 (combinator t1 t2'))+ (Compiled CommandTag c, Compiled tag@ProducerTag{} p) -> Compiled tag (combinator c p)+ (Compiled tag@ProducerTag{} p, Compiled CommandTag c) -> Compiled tag (combinator p c)+ (Compiled CommandTag c1, Compiled tag@ConsumerTag{} c2)+ -> Compiled tag (combinator c1 c2)+ (Compiled tag@ConsumerTag{} c1, Compiled CommandTag c2)+ -> Compiled tag (combinator c1 c2)+ (Compiled CommandTag c, Compiled tag@TransducerTag{} t) -> Compiled tag (combinator c t)+ (Compiled tag@TransducerTag{} t, Compiled CommandTag c) -> Compiled tag (combinator t c)+ (Compiled (ProducerTag tag1) p, Compiled (ConsumerTag tag2) c)+ -> Compiled (TransducerTag tag2 tag1) (combinator p c)+ (Compiled (ConsumerTag tag1) p, Compiled (ProducerTag tag2) c)+ -> Compiled (TransducerTag tag1 tag2) (combinator p c)+ (Compiled (ProducerTag tag1) p, Compiled tag@(TransducerTag tag2 tag3) t)+ -> let tag' = TransducerTag tag2 tag1+ in trycast tag tag' t e2 (\t'-> Compiled tag' (combinator p t'))+ (Compiled tag@(TransducerTag tag1 tag2) t, Compiled tag3@ProducerTag{} p)+ -> let tag' = TransducerTag tag2 tag1+ in trycast tag3 (ProducerTag tag2) p e2 (\p'-> Compiled tag (combinator t p'))+ (Compiled (ConsumerTag tag1) c, Compiled tag@(TransducerTag tag2 tag3) t)+ -> let tag' = TransducerTag tag1 tag3+ in trycast tag tag' t e2 (\t'-> Compiled tag' (combinator c t'))+ (Compiled tag@(TransducerTag tag1 tag2) t, Compiled tag3@ConsumerTag{} c)+ -> let tag' = TransducerTag tag2 tag1+ in trycast tag3 (ConsumerTag tag1) c e2 (\c'-> Compiled tag (combinator t c'))+ (e@TypeError{}, _) -> e+ (_, e@TypeError{}) -> e+ (Compiled tag@SplitterTag{} _, _) -> TypeError tag (ProducerTag AnyTag) e1+ (_, Compiled tag@SplitterTag{} _) -> TypeError tag (ProducerTag AnyTag) e2++wrapSplitter :: forall x. Typeable x =>+ (forall x. Typeable x => Splitter IO x -> Splitter IO x) -> TypeTag x -> Expression -> Expression+wrapSplitter combinator inputTag expression = case compile inputTag expression+ of Compiled tag@SplitterTag{} splitter -> Compiled tag (combinator splitter)+ Compiled tag _ -> TypeError tag (SplitterTag inputTag) expression+ e@TypeError{} -> e++wrapProducerIntoTransducer :: forall x. Typeable x =>+ (Producer IO x () -> Transducer IO x x) -> TypeTag x -> Expression -> Expression+wrapProducerIntoTransducer combinator inputTag expression+ = case compile inputTag expression+ of Compiled tag@ProducerTag{} p+ -> trycast tag (ProducerTag inputTag) p expression (\p'-> Compiled (TransducerTag inputTag inputTag) (combinator p'))+ Compiled tag _ -> TypeError tag (ProducerTag inputTag) expression+ e@TypeError{} -> e++wrapGenericProducerIntoTransducer :: forall x. Typeable x =>+ (forall y r. Typeable y => Producer IO y r -> Transducer IO x y)+ -> TypeTag x -> Expression -> Expression+wrapGenericProducerIntoTransducer combinator inputTag expression+ = case compile inputTag expression of Compiled (ProducerTag outTag) p -> Compiled (TransducerTag inputTag outTag) (combinator p)+ Compiled tag _ -> TypeError tag (ProducerTag inputTag) expression+ e@TypeError{} -> e++combineSplittersOfSameType :: forall x. Typeable x =>+ (forall x. Typeable x => Splitter IO x -> Splitter IO x -> Splitter IO x)+ -> TypeTag x -> Expression -> Expression -> Expression+combineSplittersOfSameType combinator inputTag left right+ = case (compile inputTag left, compile inputTag right)+ of (Compiled tag1@SplitterTag{} s1, Compiled tag2@SplitterTag{} s2)+ -> trycast tag2 tag1 s2 right (\s2'-> Compiled tag1 (combinator s1 s2'))++combineTransducersOfSameType :: forall x. Typeable x =>+ (forall x y. (Typeable x, Typeable y)=> Transducer IO x y -> Transducer IO x y -> Transducer IO x y)+ -> TypeTag x -> Expression -> Expression -> Expression+combineTransducersOfSameType combinator inputTag left right+ = case (compile inputTag left, compile inputTag right)+ of (Compiled tag1@TransducerTag{} t1, Compiled tag2@TransducerTag{} t2)+ -> trycast tag2 tag1 t2 right (\t2'-> Compiled tag1 (combinator t1 t2'))++combineSplitterAndBranches :: forall x. Typeable x =>+ (forall x cc. (Typeable x, BranchComponent cc IO x [x])=> Splitter IO x -> cc -> cc -> cc)+ -> TypeTag x -> Expression -> Expression -> Expression -> Expression+combineSplitterAndBranches combinator inputTag splitter true false+ = case (compile inputTag splitter, compile inputTag true, compile inputTag false)+ of (Compiled (SplitterTag tag1) s, Compiled tag2@ConsumerTag{} t, Compiled tag3@ConsumerTag{} f)+ -> trycast tag2 (ConsumerTag tag1) t true $+ \t'-> trycast tag3 (ConsumerTag tag1) f false $+ \f'-> Compiled (ConsumerTag tag1) (combinator s t' f')+ (Compiled tag1@SplitterTag{} s, Compiled tag2@SplitterTag{} t, Compiled tag3@SplitterTag{} f)+ -> trycast tag2 tag1 t true $+ \t'-> trycast tag3 tag1 f false $+ \f'-> Compiled tag1 (combinator s t' f')+ (Compiled (SplitterTag tag1) s, Compiled tag2@(TransducerTag tag2a tag2b) t, Compiled tag3@TransducerTag{} f)+ -> let tag2' = TransducerTag tag1 tag2b+ in trycast tag2 tag2' t true $+ \t'-> trycast tag3 tag2' f false $+ \f'-> Compiled tag2' (combinator s t' f')+ (Compiled (SplitterTag tag1) s, Compiled tag2@(TransducerTag tag2a tag2b) t, Compiled tag3@ConsumerTag{} f)+ -> let tag2' = TransducerTag tag1 tag2b+ in trycast tag2 tag2' t true $+ \t'-> trycast tag3 (ConsumerTag tag1) f false $+ \f'-> Compiled tag2' (combinator s t' (consumeBy f'))+ (Compiled (SplitterTag tag1) s, Compiled tag2@ConsumerTag{} t, Compiled tag3@(TransducerTag tag3a tag3b) f)+ -> let tag3' = TransducerTag tag1 tag3b+ in trycast tag2 (ConsumerTag tag1) t true $+ \t'-> trycast tag3 tag3' f false $+ \f'-> Compiled tag3' (combinator s (consumeBy t') f')+ (e@TypeError{}, _, _) -> e+ (_, e@TypeError{}, _) -> e+ (_, _, e@TypeError{}) -> e+ (Compiled SplitterTag{} _, Compiled tag _, _) -> TypeError tag (TransducerTag inputTag AnyTag) true+ (Compiled SplitterTag{} _, _, Compiled tag _) -> TypeError tag (TransducerTag inputTag AnyTag) false+ (Compiled tag _, _, _) -> TypeError tag (SplitterTag inputTag) splitter++parseExpression :: String -> Either Int (Expression, [Char], Int)+parseExpression s = case parse partialExpressionParser "" s of+ Left error -> Left (sourceLine (errorPos error))+ Right result -> Right result++lexer = (makeTokenParser language) {stringLiteral= stringLexemeParser}++language = emptyDef{commentLine= "#",+ reservedOpNames= ["...", ">!", ">", ">&", ">,", ">>", ">|", "|", "||", ";", "&"],+ reservedNames= ["append", "concatenate", "count", "digits", "do",+ "else", "end", "error", "exit", "everything", "first", "foreach",+ "group", "having", "having-only", "id", "if", "in",+ "last", "letters", "line", "nested", "nothing", "prefix", "prepend",+ "select", "show", "stdin", "substitute", "substring", "suffix", "suppress",+ "then", "uppercase", "while", "whitespace"]}++reservedTokens = reservedOpNames language ++ reservedNames language++partialExpressionParser :: Parser (Expression, [Char], Int)+partialExpressionParser = do whiteSpace lexer+ t <- expressionParser+ whiteSpace lexer+ rest <- getInput+ pos <- getPosition+ return (t, rest, sourceLine pos - 1)++expressionParser :: Parser Expression+expressionParser = do head <- stepParser+ whiteSpace lexer+ (do tail <- many1 (try (symbol lexer ";" >> stepParser))+ return (foldr1 Sequence (head:tail))+ <|>+ do tail <- many1 (try (symbol lexer "&" >> stepParser))+ return (foldr1 Join (head:tail))+ <|>+ return head+ )++stepParser :: Parser Expression+stepParser = do head <- termParser+ whiteSpace lexer+ tail <- many (try (char '|' >> whiteSpace lexer >> termParser))+ return (foldr1 Pipe (head:tail))++termParser :: Parser Expression+termParser =+ do first <- prefixTermParser+ whiteSpace lexer+ option first (liftM (foldr1 FollowedBy . (first :)) (many1 $ try (symbol lexer ">," >> prefixTermParser))+ <|>+ liftM (foldr1 Or . (first :)) (many1 $ try (symbol lexer ">|" >> prefixTermParser))+ <|>+ liftM (foldr1 And . (first :)) (many1 $ try (symbol lexer ">&" >> prefixTermParser))+ <|>+ liftM (foldr1 ZipWithOr . (first :)) (many1 $ try (symbol lexer "||" >> prefixTermParser))+ <|>+ liftM (foldr1 ZipWithAnd . (first :)) (many1 $ try (symbol lexer "&&" >> prefixTermParser))+ <|>+ liftM (Between first) (try (symbol lexer "..." >> prefixTermParser))+ <|>+ liftM (Having first) (try (symbol lexer "having" >> prefixTermParser))+ <|>+ liftM (HavingOnly first) (try (symbol lexer "having-only" >> prefixTermParser))+ )++prefixTermParser :: Parser Expression+prefixTermParser =+ try (symbol lexer ">!" >> liftM Not prefixTermParser)+ <|> try (symbol lexer "prefix" >> liftM Prefix prefixTermParser)+ <|> try (symbol lexer "suffix" >> liftM Suffix prefixTermParser)+ <|> try (symbol lexer "prepend" >> liftM Prepend prefixTermParser)+ <|> try (symbol lexer "append" >> liftM Append prefixTermParser)+ <|> try (symbol lexer "substitute" >> liftM Substitute prefixTermParser)+ <|> try (symbol lexer "first" >> liftM First prefixTermParser)+ <|> try (symbol lexer "last" >> liftM Last prefixTermParser)+ <|> try (symbol lexer "start-of" >> liftM StartOf prefixTermParser)+ <|> try (symbol lexer "end-of" >> liftM EndOf prefixTermParser)+ <|> try (symbol lexer "select" >> liftM Select prefixTermParser)+ <|> primaryParser++primaryParser :: Parser Expression+primaryParser =+ try (do char '('+ whiteSpace lexer+ expression <- expressionParser+ whiteSpace lexer+ char ')'+ return expression)+ <|> try (symbol lexer "exit" >> return Exit)+ <|> try (nativeSourceParser "cat")+ <|> try (nativeSourceParser "ls")+ <|> try (do symbol lexer "echo"+ string <- nativeCommand True+ return (FromList string))+ <|> try (symbol lexer "stdin" >> return StdInProducer)+ <|> try (do symbol lexer ">>"+ file <- parameterParser True+ return (FileAppend file))+ <|> try (do symbol lexer ">"+ file <- parameterParser True+ return (FileConsumer file))+ <|> try (symbol lexer "suppress" >> return Suppress)+ <|> try (do symbol lexer "error"+ message <- (try (parameterParser True) <|> return "Error sink reached!")+ return (ErrorConsumer message))+ <|> try (symbol lexer "id" >> return IdentityTransducer)+ <|> try (symbol lexer "uppercase" >> return Uppercase)+ <|> try (symbol lexer "count" >> return Count)+ <|> try (symbol lexer "show" >> return ShowTransducer)+ <|> try (symbol lexer "concatenate" >> return Concatenate)+ <|> try (symbol lexer "group" >> return Group)+ <|> try (symbol lexer "everything" >> return EverythingSplitter)+ <|> try (symbol lexer "nothing" >> return NothingSplitter)+ <|> try (symbol lexer "whitespace" >> return WhitespaceSplitter)+ <|> try (symbol lexer "line" >> return LineSplitter)+ <|> try (symbol lexer "letters" >> return LetterSplitter)+ <|> try (symbol lexer "digits" >> return DigitSplitter)+ <|> try (symbol lexer "one" >> return OneSplitter)+ <|> try (do symbol lexer "substring"+ part <- parameterParser True+ return (SubstringSplitter part))+ <|> try (do symbol lexer "if"+ splitter <- expressionParser+ whiteSpace lexer+ symbol lexer "then"+ true <- expressionParser+ false <- (try (symbol lexer "else" >> expressionParser)+ <|> return Suppress)+ symbol lexer "end"+ option "" (symbol lexer "if")+ return (If splitter true false))+ <|> try (do symbol lexer "nested"+ core <- expressionParser+ whiteSpace lexer+ symbol lexer "in"+ shell <- expressionParser+ whiteSpace lexer+ symbol lexer "end"+ option "" (symbol lexer "nested")+ return (Nested core shell))+ <|> try (do symbol lexer "while"+ test <- expressionParser+ whiteSpace lexer+ symbol lexer "do"+ body <- expressionParser+ whiteSpace lexer+ symbol lexer "end"+ option "" (symbol lexer "while")+ return (While test body))+ <|> try (do symbol lexer "foreach"+ splitter <- expressionParser+ whiteSpace lexer+ symbol lexer "then"+ trueBranch <- expressionParser+ whiteSpace lexer+ falseBranch <- (try (symbol lexer "else" >> expressionParser)+ <|> return IdentityTransducer)+ whiteSpace lexer+ symbol lexer "end"+ option "" (symbol lexer "foreach")+ return (ForEach splitter trueBranch falseBranch))+ <|> liftM NativeCommand (nativeCommand False)++nativeSourceParser :: String -> Parser Expression+nativeSourceParser command = do symbol lexer command+ params <- nativeCommand False+ return (NativeCommand (command ++ " " ++ params))++nativeCommand :: Bool -> Parser String+nativeCommand normalize = do parts <- try (lexeme lexer (parameterParser normalize)+ `manyTill`+ ((eof >> return "") <|> lookAhead (choice (map (try . symbol lexer) reservedTokens))))+ return (concat (intersperse " " parts))+ where manyTill :: GenParser tok st a -> GenParser tok st end -> GenParser tok st [a]+ manyTill p end = scan+ where scan = do{ end; return [] }+ <|>+ do{ x <- p; xs <- scan; return (x:xs) }+ <|>+ return []++parameterParser :: Bool -> Parser String+parameterParser normalize = do chars <- many (noneOf " \t\n'\"`\\()[]{}<>|&;")+ (do try (string "\\n")+ rest <- option "" (parameterParser normalize)+ return (chars ++ '\n' : rest)+ <|>+ do try (string "\\t")+ rest <- option "" (parameterParser normalize)+ return (chars ++ '\t' : rest)+ <|>+ do next <- escape+ rest <- option "" (parameterParser normalize)+ return (chars ++ next : rest)+ <|>+ do quote <- oneOf "'\"`"+ string <- many (try (noneOf (quote : "\\")) <|> escape)+ char quote+ rest <- option "" (parameterParser normalize)+ return (chars ++ (if normalize then string else quote : (string ++ [quote])) ++ rest)+ <|>+ do try (char '(')+ whiteSpace lexer+ inside <- nativeCommand normalize+ char ')'+ rest <- option "" (parameterParser normalize)+ return (chars ++ '(' : inside ++ ')' : rest)+ <|>+ do try (char '[')+ whiteSpace lexer+ inside <- nativeCommand normalize+ char ']'+ rest <- parameterParser normalize+ return (chars ++ '[' : inside ++ ']' : rest)+ <|>+ do try (char '{')+ whiteSpace lexer+ inside <- nativeCommand normalize+ char '}'+ rest <- option "" (parameterParser normalize)+ return (chars ++ '{' : inside ++ '}' : rest)+ <|>+ do when (null chars) parserZero return chars) escape :: Parser Char
Test.hs view
@@ -16,7 +16,7 @@ {-# LANGUAGE DeriveDataTypeable, FlexibleInstances, ScopedTypeVariables, PatternSignatures #-} -module Test where+module Main where import Control.Concurrent.SCC.Foundation import Control.Concurrent.SCC.ComponentTypes@@ -25,6 +25,7 @@ import qualified Control.Concurrent.SCC.Combinators as Combinators import Control.Monad (liftM)+import Control.Monad.Identity (Identity (Identity)) import Data.Char (ord, isLetter, isSpace, toUpper) import Data.Dynamic (Typeable) import Data.List (find, stripPrefix, groupBy, intersect, union, intercalate, isInfixOf, isPrefixOf, isSuffixOf, sort)@@ -32,7 +33,7 @@ import qualified Data.List as List import qualified Data.Foldable as Foldable import qualified Data.Sequence as Seq-import Data.Sequence (Seq, (|>), ViewL (EmptyL, (:<)))+import Data.Sequence (Seq, (|>), (><), ViewL (EmptyL, (:<))) import Debug.Trace (trace) import Prelude hiding (even, last) import qualified Prelude@@ -55,18 +56,28 @@ label "substitute" prop_substitute, label "prepend" prop_prepend, label "append" prop_append,- label "allTrue" prop_allTrue,- label "allFalse" prop_allFalse,+ label "everything" prop_allTrue,+ label "nothing" prop_allFalse, label "substring" prop_substring, label "group" prop_group, label "concatenate" prop_concatenate, label "concatSeparate" prop_concatSeparate,- label "uppercase ->>" $ \s-> runPipes (pipe (putList s) (uppercase ->> getList)) == Just ([], map toUpper s),- label "uppercase <<-" $ \s-> runPipes (pipe (uppercase <<- putList s) getList) == Just ([], map toUpper s),+ label "uppercase ->>" $ \s-> runPipes (pipe (putList s) (consume $ uppercase >-> liftAtomicConsumer "getList" 1 getList))+ == Just ([], map toUpper s),+ label "uppercase <<-" $ \s-> runPipes (pipe (produce $ liftAtomicProducer "putList" 1 (putList s) >-> uppercase) getList)+ == Just ([], map toUpper s), label "uppercase `join` asis" $ \s-> transducerOutput (uppercase `join` asis) s == map toUpper s ++ s,- label "prepend >-> append" $ \s-> transducerOutput (prepend "Hello, " >-> append "!") s == "Hello, "++ s ++ "!",+ label "prepend >-> append" (\(s :: String) prefix suffix->+ transducerOutput (prepend (fromList prefix) >-> append (fromList suffix)) s+ == prefix ++ s ++ suffix),+ label "prepend == (`join` asis) . substitute" $+ \(s :: String) prefix-> transducerOutput (prepend (fromList prefix)) s+ == transducerOutput (substitute (fromList prefix) `join` asis) s,+ label "append == (asis `join`) . substitute" $+ \(s :: String) suffix-> transducerOutput (append (fromList suffix)) s+ == transducerOutput (asis `join` substitute (fromList suffix)) s, label "whitespace" $ \s-> splitterOutputs whitespace s == (filter isSpace s, filter (not . isSpace) s),- label "ifs allTrue asis asis" $ \(s :: [TestEnum])-> transducerOutput (ifs allTrue asis asis) s == s,+ label "ifs everything asis asis" $ \(s :: [TestEnum])-> transducerOutput (ifs everything asis asis) s == s, label "substring" $ \s (c :: TestEnum)-> splitterOutputs (substring [c]) s == (filter (==c) s, filter (/=c) s), label "ifs (substring X) uppercase asis" $ \s (LowercaseLetter c)-> transducerOutput (ifs (substring [c]) uppercase asis) s@@ -74,7 +85,8 @@ label "count >-> toString >-> concatenate" $ \(s :: [TestEnum])-> transducerOutput (count >-> toString >-> concatenate) s == show (length s), label "foreach whitespace asis (prepend \"[\" >-> append \"]\")" $- \s-> transducerOutput (foreach whitespace asis (prepend "[" >-> append "]")) s == mapWords (("[" ++) . (++ "]")) s,+ \s-> transducerOutput (foreach whitespace asis (prepend (fromList "[") >-> append (fromList "]"))) s+ == mapWords (("[" ++) . (++ "]")) s, label "foreach whitespace asis (count >-> toString >-> concatenate)" $ \s-> transducerOutput (foreach whitespace asis (count >-> toString >-> concatenate)) s == mapWords (show . length) s, label "uppercase `wherever` (snot whitespace `having` substring X)" $@@ -136,9 +148,12 @@ label "first followedBy" $ \trace1 trace2 n-> prop_followedBy2 (splitterFromTrace trace1) (splitterFromTrace trace2) n, label "substring followedBy substring 1" prop_followedBy3, label "substring followedBy substring 2" prop_followedBy4,- label "between..." $ \trace1 trace2 n-> prop_between_first_last (simpleSplitterFromTrace trace1)- (simpleSplitterFromTrace trace2) n]+ label "substring followedBy substring 3" prop_followedBy5,+ label "... followedBy ..." prop_followedByBetween,+ label "start ... end" $ \trace n-> prop_between1 (simpleSplitterFromTrace trace) n,+ label "start everything ... end" $ \trace n-> prop_between2 (simpleSplitterFromTrace trace) n] + prop_pour :: [Int] -> Bool prop_pour input = runPipes (pipeD "input" (putList input) (\source-> pipeD "output" (\sink-> pour source sink) getList)) == Just ([], ((), input))@@ -147,22 +162,24 @@ prop_asis input = transducerOutput asis input == input prop_suppress :: [Int] -> Bool-prop_suppress input = null (transducerOutput (suppress :: Transducer Maybe Int ()) input)+prop_suppress input = null (transducerOutput (consumeBy suppress :: Transducer Identity Int ()) input) prop_substitute :: [Int] -> [Maybe Int] -> Bool-prop_substitute input replacement = transducerOutput (substitute replacement) input == replacement+prop_substitute input replacement = transducerOutput (substitute $ fromList replacement) input == replacement -prop_prepend :: [Int] -> [Int] -> Bool-prop_prepend input prefix = transducerOutput (prepend prefix) input == prefix ++ input+prop_prepend :: [Int] -> [Int] -> Int -> Property+prop_prepend input prefix threads = threads > 0 ==>+ transducerOutput (usingThreads threads $ prepend $ fromList prefix) input == prefix ++ input -prop_append :: [Int] -> [Int] -> Bool-prop_append input suffix = transducerOutput (append suffix) input == input ++ suffix+prop_append :: [Int] -> [Int] -> Int -> Property+prop_append input suffix threads = threads > 0 ==>+ transducerOutput (usingThreads threads $ append $ fromList suffix) input == input ++ suffix prop_allTrue :: [Int] -> Bool-prop_allTrue input = splitterOutputs allTrue input == (input, [])+prop_allTrue input = splitterOutputs everything input == (input, []) prop_allFalse :: [Int] -> Bool-prop_allFalse input = splitterOutputs allFalse input == ([], input)+prop_allFalse input = splitterOutputs nothing input == ([], input) prop_substring :: [TestEnum] -> [TestEnum] -> Property prop_substring input sublist = trivial (not (isInfixOf sublist input)) (fst (splitterOutputs (substring sublist) input)@@ -177,69 +194,76 @@ prop_concatSeparate :: [[TestEnum]] -> [TestEnum] -> Bool prop_concatSeparate input separator = transducerOutput (concatSeparate separator) input == intercalate separator input -prop_snot :: Splitter Maybe Int -> [Int] -> Bool+prop_snot :: Splitter Identity Int -> [Int] -> Bool prop_snot splitter input = splitterOutputs (snot splitter) input == swap (splitterOutputs splitter input) -prop_andAssoc :: SplitterTrace -> SplitterTrace -> SplitterTrace -> [Int] -> Bool-prop_andAssoc st1 st2 st3 input = --trace (show $ (splitterOutputs (s1 >& (s2 >& s3)) input, splitterOutputs ((s1 >& s2) >& s3) input)) $- splitterOutputs (s1 >& (s2 >& s3)) input == splitterOutputs ((s1 >& s2) >& s3) input+prop_andAssoc :: SplitterTrace -> SplitterTrace -> SplitterTrace -> [Int] -> Int -> Int -> Property+prop_andAssoc st1 st2 st3 input t1 t2+ = t1 > 0 && t2 > 0+ ==> splitterOutputs (usingThreads t1 $ s1 >& (s2 >& s3)) input == splitterOutputs (usingThreads t2 $ (s1 >& s2) >& s3) input where s1 = splitterFromTrace st1 s2 = splitterFromTrace st2 s3 = splitterFromTrace st3 -prop_orAssoc :: SplitterTrace -> SplitterTrace -> SplitterTrace -> [Int] -> Bool-prop_orAssoc st1 st2 st3 input = splitterOutputs (s1 >| (s2 >| s3)) input == splitterOutputs ((s1 >| s2) >| s3) input+prop_orAssoc :: SplitterTrace -> SplitterTrace -> SplitterTrace -> [Int] -> Int -> Int -> Property+prop_orAssoc st1 st2 st3 input t1 t2+ = t1 > 0 && t2 > 0+ ==> splitterOutputs (usingThreads t1 $ s1 >| (s2 >| s3)) input == splitterOutputs (usingThreads t2 $ (s1 >| s2) >| s3) input where s1 = splitterFromTrace st1 s2 = splitterFromTrace st2 s3 = splitterFromTrace st3 -prop_DeMorgan1 :: Splitter Maybe Int -> Splitter Maybe Int -> [Int] -> Bool-prop_DeMorgan1 s1 s2 input = splitterOutputs (snot (s1 >& s2)) input == splitterOutputs (snot s1 >| snot s2) input+prop_DeMorgan1 :: Splitter Identity Int -> Splitter Identity Int -> [Int] -> Int -> Int -> Property+prop_DeMorgan1 s1 s2 input t1 t2+ = t1 > 0 && t2 > 0+ ==> splitterOutputs (usingThreads t1 $ snot (s1 >& s2)) input == splitterOutputs (usingThreads t2 $ snot s1 >| snot s2) input -prop_DeMorgan2 :: Splitter Maybe Int -> Splitter Maybe Int -> [Int] -> Bool-prop_DeMorgan2 s1 s2 input = splitterOutputs (snot (s1 >| s2)) input == splitterOutputs (snot s1 >& snot s2) input+prop_DeMorgan2 :: Splitter Identity Int -> Splitter Identity Int -> [Int] -> Int -> Int -> Property+prop_DeMorgan2 s1 s2 input t1 t2+ = t1 > 0 && t2 > 0+ ==> splitterOutputs (usingThreads t1 $ snot (s1 >| s2)) input == splitterOutputs (usingThreads t2 $ snot s1 >& snot s2) input -prop_and :: Splitter Maybe Int -> Splitter Maybe Int -> Int -> Bool+prop_and :: Splitter Identity Int -> Splitter Identity Int -> Int -> Bool prop_and s1 s2 n = fst (splitterOutputs (s1 Combinators.&& s2) l) == fst (splitterOutputs s1 l) `intersect` fst (splitterOutputs s2 l) where l = [1 .. abs n] -prop_or :: Splitter Maybe Int -> Splitter Maybe Int -> Int -> Bool+prop_or :: Splitter Identity Int -> Splitter Identity Int -> Int -> Bool prop_or s1 s2 n = fst (splitterOutputs (s1 Combinators.|| s2) l) == sort (fst (splitterOutputs s1 l) `union` fst (splitterOutputs s2 l)) where l = [1 .. abs n] -prop_even :: Splitter Maybe TestEnum -> [TestEnum] -> Bool+prop_even :: Splitter Identity TestEnum -> [TestEnum] -> Bool prop_even splitter input = let splitOddEven [] = ([], []) splitOddEven (head:tail) = let (evens, odds) = splitOddEven tail in (head:odds, evens) in fst (splitterOutputs (even splitter) input)- == concat (snd $ splitOddEven $ transducerOutput (foreach splitter group suppress) input)+ == concat (snd $ splitOddEven $ transducerOutput (foreach splitter group (consumeBy suppress)) input) -prop_prefix_1 :: Splitter Maybe TestEnum -> [TestEnum] -> Bool+prop_prefix_1 :: Splitter Identity TestEnum -> [TestEnum] -> Bool prop_prefix_1 splitter input = let (pfx, rest) = splitterOutputs (prefix splitter) input (true, false) = splitterOutputs splitter input in pfx ++ rest == input && pfx `isPrefixOf` true -prop_prefix_2 :: Splitter Maybe TestEnum -> [TestEnum] -> Bool+prop_prefix_2 :: Splitter Identity TestEnum -> [TestEnum] -> Bool prop_prefix_2 splitter input = let (prefix1, rest1) = splitterOutputs (prefix splitter) input in case splitterOutputChunks splitter input of (prefix2, True):rest2 -> prefix1 == prefix2 && rest1 == concat (map fst rest2) (prefix2, False):rest2 -> prefix1 == [] && rest1 == prefix2 ++ concat (map fst rest2) [] -> prefix1 ++ rest1 == [] -prop_suffix_1 :: Splitter Maybe TestEnum -> [TestEnum] -> Bool+prop_suffix_1 :: Splitter Identity TestEnum -> [TestEnum] -> Bool prop_suffix_1 splitter input = let (sfx, rest) = splitterOutputs (suffix splitter) input (true, false) = splitterOutputs splitter input in rest ++ sfx == input && sfx `isSuffixOf` true -prop_suffix_2 :: Splitter Maybe TestEnum -> [TestEnum] -> Bool+prop_suffix_2 :: Splitter Identity TestEnum -> [TestEnum] -> Bool prop_suffix_2 splitter input = let (suffix1, rest1) = splitterOutputs (suffix splitter) input in case reverse (splitterOutputChunks splitter input) of (suffix2, True):rest2 -> suffix1 == suffix2 && rest1 == concat (map fst (reverse rest2)) (suffix2, False):rest2 -> suffix1 == [] && rest1 == concat (map fst (reverse rest2)) ++ suffix2 [] -> rest1 ++ suffix1 == [] -prop_first :: Splitter Maybe TestEnum -> [TestEnum] -> Bool+prop_first :: Splitter Identity TestEnum -> [TestEnum] -> Bool prop_first splitter input = let (first1, rest1) = splitterOutputs (first splitter) input in case splitterOutputChunks splitter input of (first2, True):rest2 -> first1 == first2 && rest1 == concat (map fst rest2)@@ -248,7 +272,7 @@ (prefix, False):[] -> first1 == [] && rest1 == prefix [] -> first1 ++ rest1 == [] -prop_last :: Splitter Maybe TestEnum -> [TestEnum] -> Bool+prop_last :: Splitter Identity TestEnum -> [TestEnum] -> Bool prop_last splitter input = let (last1, rest1) = splitterOutputs (last splitter) input in -- trace (show (last1, rest1)) $ trace (show (splitterOutputChunks splitter input)) $ case reverse (splitterOutputChunks splitter input)@@ -258,7 +282,7 @@ (suffix, False):[] -> last1 == [] && rest1 == suffix [] -> last1 ++ rest1 == [] -prop_uptoFirst :: Splitter Maybe TestEnum -> [TestEnum] -> Bool+prop_uptoFirst :: Splitter Identity TestEnum -> [TestEnum] -> Bool prop_uptoFirst splitter input = let (first1, rest1) = splitterOutputs (uptoFirst splitter) input in case splitterOutputChunks splitter input of (first2, True):rest2 -> first1 == first2 && rest1 == concat (map fst rest2)@@ -267,7 +291,7 @@ (prefix, False):[] -> first1 == [] && rest1 == prefix [] -> first1 ++ rest1 == [] -prop_lastAndAfter :: Splitter Maybe TestEnum -> [TestEnum] -> Bool+prop_lastAndAfter :: Splitter Identity TestEnum -> [TestEnum] -> Bool prop_lastAndAfter splitter input = let (last1, rest1) = splitterOutputs (lastAndAfter splitter) input in case reverse (splitterOutputChunks splitter input) of (last2, True):rest2 -> last1 == last2 && rest1 == concat (map fst (reverse rest2))@@ -276,11 +300,11 @@ (suffix, False):[] -> last1 == [] && rest1 == suffix [] -> last1 ++ rest1 == [] -prop_followedBy1 :: Splitter Maybe Int -> Splitter Maybe Int -> Int -> Bool+prop_followedBy1 :: Splitter Identity Int -> Splitter Identity Int -> Int -> Bool prop_followedBy1 s1 s2 n = splitterOutputs (s1 `followedBy` s2) l == splitterOutputs (s1 `followedBy` prefix s2) l where l = [1 .. abs n] -prop_followedBy2 :: Splitter Maybe Int -> Splitter Maybe Int -> Int -> Bool+prop_followedBy2 :: Splitter Identity Int -> Splitter Identity Int -> Int -> Bool prop_followedBy2 s1 s2 n = splitterOutputs (first (s1 `followedBy` s2)) l == splitterOutputs (first s1 `followedBy` s2) l where l = [1 .. abs n] @@ -294,27 +318,45 @@ `followedBy` substring l2) l3) == sublists (l1 ++ l2) l3) -prop_between_first_last :: Splitter Maybe Int -> Splitter Maybe Int -> Int -> Bool-prop_between_first_last s1 s2 n = fst (splitterOutputs (first s1 ... last s2) l)- == sort (fst (splitterOutputs (first s1 `between` last s2) l)- `union`- limits (fst $ splitterOutputs (first s1) l) (fst $ splitterOutputs (last s2) l))- where limits [] _ = []- limits l1 [] = l1- limits l1 l2 | head l1 <= head l2 = l1 `union` l2 - | head l1 <= Prelude.last l2 = [head l1 .. Prelude.last l2]- | otherwise = l1- l = [1 .. abs n]+prop_followedBy5 :: Int -> Int -> Int -> Int -> Bool+prop_followedBy5 i1 i2 i3 i4 = let n1 = abs i1+ n2 = n1 + abs i2+ n3 = n2 + abs i3 + 1+ n4 = n3 + abs i4+ in splitterOutputs (substring [n1 .. n2] `followedBy` substring [n2 + 1 .. n3]) [0 .. n4]+ == ([n1 .. n3], [0 .. n1 - 1] ++ [n3 + 1 .. n4]) -transducerOutput :: (Typeable x, Typeable y) => Transducer Maybe x y -> [x] -> [y]+prop_followedByBetween :: Int -> Int -> Int -> Int -> Bool+prop_followedByBetween i1 i2 i3 i4 = let n1 = abs i1+ n2 = n1 + abs i2+ n3 = n2 + abs i3 + 1+ n4 = n3 + abs i4+ in splitterOutputs+ ((substring [n1] ... substring [n2])+ `followedBy` (substring [n2 + 1] ... substring [n3]))+ [0 .. n4]+ + == ([n1 .. n3], [0 .. n1 - 1] ++ [n3 + 1 .. n4])++prop_between1 :: Splitter Identity Int -> Int -> Bool+prop_between1 splitter n = splitterOutputs (startOf splitter ... endOf splitter) input == splitterOutputs splitter input+ && splitterOutputs (endOf splitter ... startOf splitter) input == ([], input)+ where input = [1 .. abs n]++prop_between2 :: Splitter Identity Int -> Int -> Bool+prop_between2 splitter n = splitterOutputs (startOf everything ... endOf splitter) input == splitterOutputs (uptoFirst splitter) input+ || null (fst $ splitterOutputs splitter input)+ where input = [1 .. abs n]++transducerOutput :: (Typeable x, Typeable y) => Transducer Identity x y -> [x] -> [y] transducerOutput t input = case runPipes (pipeD "transducerOutput input" (putList input) (\source-> pipeD "transducerOutput output" (\sink-> transduce t source sink) getList))- of Just ([], ([], output)) -> output+ of Identity ([], ([], output)) -> output -splitterOutputs :: Typeable x => Splitter Maybe x -> [x] -> ([x], [x])+splitterOutputs :: Typeable x => Splitter Identity x -> [x] -> ([x], [x]) splitterOutputs s input = case runPipes (pipeD "splitterOutputs input" (putList input) (\source-> pipeD "splitterOutputs true"@@ -322,19 +364,19 @@ (split s source true) getList) getList))- of Just ([], (([], false), true)) -> (true, false)+ of Identity ([], (([], false), true)) -> (true, false) -splitterOutputChunks :: Typeable x => Splitter Maybe x -> [x] -> [([x], Bool)]+splitterOutputChunks :: Typeable x => Splitter Identity x -> [x] -> [([x], Bool)] splitterOutputChunks s input = transducerOutput (foreach s- (group >-> lift121Transducer (\chunk-> (chunk, True)))- (group >-> lift121Transducer (\chunk-> (chunk, False))))+ (group >-> lift121Transducer "true" (\chunk-> (chunk, True)))+ (group >-> lift121Transducer "false" (\chunk-> (chunk, False)))) input -simpleSplitterFromTrace :: (Show x, Typeable x) => SimpleSplitterTrace -> Splitter Maybe x+simpleSplitterFromTrace :: (Show x, Typeable x) => SimpleSplitterTrace -> Splitter Identity x simpleSplitterFromTrace (init, last) = splitterFromTrace (map (maybe Nothing (Just . (,) True)) init, last) -splitterFromTrace :: (Show x, Typeable x) => SplitterTrace -> Splitter Maybe x-splitterFromTrace trace1 = liftSectionSplitter $+splitterFromTrace :: (Show x, Typeable x) => SplitterTrace -> Splitter Identity x+splitterFromTrace trace1 = liftAtomicSectionSplitter "splitterFromTrace" 1 $ \source true false-> let follow trace2@(head:tail) q = get source >>= maybe fail succeed where succeed x = let q' = q |> Just x@@ -363,7 +405,7 @@ type SplitterTrace = ([Maybe (Bool, Bool)], Bool) -data TestEnum = One | Two | Three | Four | Five deriving (Eq, Show, Typeable)+data TestEnum = One | Two | Three | Four | Five deriving (Enum, Eq, Show, Typeable) newtype LowercaseLetter = LowercaseLetter Char deriving (Eq, Show, Typeable) @@ -379,9 +421,9 @@ arbitrary = fmap LowercaseLetter (choose ('a', 'z')) coarbitrary (LowercaseLetter c) = variant ((ord c - 65) `rem` 26) -instance Arbitrary (Splitter Maybe Int) where+instance Arbitrary (Splitter Identity Int) where arbitrary = fmap splitterFromTrace arbitrary coarbitrary s gen = sized (\n-> coarbitrary (transducerOutput (ifs s- (lift121Transducer $ const True)- (lift121Transducer $ const False))+ (lift121Transducer "true" $ const True)+ (lift121Transducer "false" $ const False)) [1..n]) gen)
grammar.bnf view
@@ -1,76 +1,59 @@ Expression ::=- ProducerPrimary {"|" TransducerPrimary} ["|" ConsumerPrimary].+ Step {";" Step}+ | Step {"&" Step}. -ProducerExpression ::=- ProducerPrimary- | ProducerPrimary "|" TransducerExpression.+Step ::=+ Term {"|" Term}. -ProducerPrimary ::=- "(" NativeCommand ")" ">"+Term ::=+ PrefixTerm+ [ {"&&" PrefixTerm}+ | {"||" PrefixTerm}+ | {">&" PrefixTerm}+ | {">|" PrefixTerm}+ | {">," PrefixTerm}+ | "having" PrefixTerm+ | "having-only" PrefixTerm+ | "..." PrefixTerm].++PrefixTerm ::=+ Primary+ | "first" PrefixTerm+ | "last" PrefixTerm+ | "prefix" PrefixTerm+ | "suffix" PrefixTerm+ | "start-of" PrefixTerm+ | "end-of" PrefixTerm+ | "prepend" PrefixTerm+ | "append" PrefixTerm+ | "substitute" PrefixTerm+ | "select" PrefixTerm+ | ">!" PrefixTerm.++Primary ::=+ "(" Expression ")"+ | "exit" | "cat" Parameters | "echo" Parameters | "ls" Parameters | "stdin" | "{" [String {"," String}] "}"- | "(" ProducerExpression ")".--ConsumerExpression ::=- ConsumerFork- | TransducerExpression "|" ConsumerFork.--ConsumerFork ::=- ConsumerPrimary {"tee" ConsumerPrimary}.--ConsumerPrimary ::=- "(" ConsumerExpression ")"- | ">" "(" NativeCommand ")" | "error" [String]- | "null"+ | "suppress" | ">" File- | ">>" File.--TransducerExpression ::=- TransducerPrimary {"|" TransducerPrimary}- | TransducerPrimary {"><" TransducerPrimary}.--TransducerPrimary ::=- "(" TransducerExpression ")"+ | ">>" File+ | "if" Expression "then" Expression ["else" Expression] "end" ["if"]+ | "foreach" Expression "then" Expression ["else" Expression] "end" ["foreach"]. | "id"- | "suppress" | "count" | "group" | "concatenate" | "uppercase"- | "prepend" String- | "append" String- | "substitute" String- | "select" SplitterPrimary- | "if" SplitterExpression "then" TransducerExpression ["else" TransducerExpression] "end" ["if"]- | "while" SplitterExpression "do" TransducerExpression "end" ["while"]- | "foreach" SplitterExpression "then" TransducerExpression ["else" TransducerExpression] "end" ["foreach"]- | NativeCommand.--SplitterExpression ::=- SplitterPrimary {"&&" SplitterPrimary}- | SplitterPrimary {"||" SplitterPrimary}- | SplitterPrimary {">&" SplitterPrimary}- | SplitterPrimary {">|" SplitterPrimary}- | SplitterPrimary {">," SplitterPrimary}- | SplitterPrimary "having" SplitterPrimary- | SplitterPrimary "having-only" SplitterPrimary- | SplitterPrimary "..." SplitterPrimary- | "first" SplitterPrimary- | "last" SplitterPrimary- | "prefix" SplitterPrimary- | "suffix" SplitterPrimary.--SplitterPrimary ::=- "(" SplitterExpression ")"- | ">!" SplitterPrimary+ | "while" Expression "do" Expression "end" ["while"]+ | "nested" Expression "in" Expression "end" ["nested"] | "whitespace" | "line" | "letters" | "digits" | "substring" String- | "nested" SplitterExpression "in" SplitterExpression "end" ["nested"]- | "between" SplitterExpression "and" SplitterExpression "end" ["between"].+ | NativeCommand.
scc.cabal view
@@ -1,5 +1,5 @@ Name: scc-Version: 0.1+Version: 0.2 Cabal-Version: >= 1.2 Build-Type: Simple Synopsis: Streaming component combinators@@ -10,7 +10,7 @@ types, a number of primitive streaming components and a set of component combinators. Finally, there is an executable that exposes all functionality in a command-line shell. .- The library design is based on paper <http://www.idealliance.org/papers/extreme/Proceedings/html/2006/Blazevic01/EML2006Blazevic01.html>+ The original library design is based on paper <http://www.idealliance.org/papers/extreme/Proceedings/html/2006/Blazevic01/EML2006Blazevic01.html> . Mario Blažević, Streaming component combinators, Extreme Markup Languages, 2006. @@ -25,9 +25,10 @@ Main-is: Shell.hs Other-Modules: Control.Concurrent.SCC.Foundation, Control.Concurrent.SCC.ComponentTypes, Control.Concurrent.SCC.Components, Control.Concurrent.SCC.Combinators- Build-Depends: base, containers, process, readline, parsec+ Build-Depends: base, containers, mtl, parallel, process, readline, parsec >= 3+ GHC-options: "-threaded" Library Exposed-Modules: Control.Concurrent.SCC.Foundation, Control.Concurrent.SCC.ComponentTypes, Control.Concurrent.SCC.Components, Control.Concurrent.SCC.Combinators- Build-Depends: base, containers+ Build-Depends: base, containers, mtl, parallel