diff --git a/Control/Concurrent/SCC/Combinators.hs b/Control/Concurrent/SCC/Combinators.hs
--- a/Control/Concurrent/SCC/Combinators.hs
+++ b/Control/Concurrent/SCC/Combinators.hs
@@ -14,652 +14,1080 @@
.
-}
--- | 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
diff --git a/Control/Concurrent/SCC/ComponentTypes.hs b/Control/Concurrent/SCC/ComponentTypes.hs
--- a/Control/Concurrent/SCC/ComponentTypes.hs
+++ b/Control/Concurrent/SCC/ComponentTypes.hs
@@ -14,100 +14,415 @@
.
-}
-{-# 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
diff --git a/Control/Concurrent/SCC/Components.hs b/Control/Concurrent/SCC/Components.hs
--- a/Control/Concurrent/SCC/Components.hs
+++ b/Control/Concurrent/SCC/Components.hs
@@ -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
diff --git a/Control/Concurrent/SCC/Foundation.hs b/Control/Concurrent/SCC/Foundation.hs
--- a/Control/Concurrent/SCC/Foundation.hs
+++ b/Control/Concurrent/SCC/Foundation.hs
@@ -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
diff --git a/Makefile b/Makefile
--- a/Makefile
+++ b/Makefile
@@ -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/*
diff --git a/Shell.hs b/Shell.hs
--- a/Shell.hs
+++ b/Shell.hs
@@ -14,718 +14,771 @@
.
-}
-{-# 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 | -f | -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 | -f | -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
diff --git a/Test.hs b/Test.hs
--- a/Test.hs
+++ b/Test.hs
@@ -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)
diff --git a/grammar.bnf b/grammar.bnf
--- a/grammar.bnf
+++ b/grammar.bnf
@@ -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.
diff --git a/scc.cabal b/scc.cabal
--- a/scc.cabal
+++ b/scc.cabal
@@ -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
+ The original library design is based on paper
.
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