scc (empty) → 0.1
raw patch · 11 files changed
+3254/−0 lines, 11 filesdep +basedep +containersdep +parsecsetup-changed
Dependencies added: base, containers, parsec, process, readline
Files
- Control/Concurrent/SCC/Combinators.hs +665/−0
- Control/Concurrent/SCC/ComponentTypes.hs +113/−0
- Control/Concurrent/SCC/Components.hs +284/−0
- Control/Concurrent/SCC/Foundation.hs +249/−0
- LICENSE.txt +674/−0
- Makefile +23/−0
- Setup.lhs +4/−0
- Shell.hs +746/−0
- Test.hs +387/−0
- grammar.bnf +76/−0
- scc.cabal +33/−0
+ Control/Concurrent/SCC/Combinators.hs view
@@ -0,0 +1,665 @@+{- + Copyright 2008 Mario Blazevic++ This file is part of the Streaming Component Combinators (SCC) project.++ The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public+ License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later+ version.++ SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty+ of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.++ You should have received a copy of the GNU General Public License along with SCC. If not, see+ <http://www.gnu.org/licenses/>.+-}++-- | 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++fst3 :: (a, b, c) -> a+fst3 (a, b, c) = a
+ Control/Concurrent/SCC/ComponentTypes.hs view
@@ -0,0 +1,113 @@+{- + Copyright 2008 Mario Blazevic++ This file is part of the Streaming Component Combinators (SCC) project.++ The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public+ License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later+ version.++ SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty+ of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.++ You should have received a copy of the GNU General Public License along with SCC. If not, see+ <http://www.gnu.org/licenses/>.+-}++{-# LANGUAGE ScopedTypeVariables, Rank2Types #-}++module Control.Concurrent.SCC.ComponentTypes+ (-- * Types+ Splitter(..), Transducer(..),+ -- * Lifting functions+ lift121Transducer, liftStatelessTransducer, liftFoldTransducer, liftStatefulTransducer,+ liftSimpleSplitter, liftSectionSplitter, liftStatelessSplitter)+where++import Control.Concurrent.SCC.Foundation++import Control.Monad (liftM, when)+import Data.Maybe (maybe)+import Data.Typeable (Typeable, cast)++-- | 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]}++-- | 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]}++-- | 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 [])++-- | 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 [])+-- | 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 [])++-- | 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 [])++-- | 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)++-- | 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+ = 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++-- | 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+ = 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))
+ Control/Concurrent/SCC/Components.hs view
@@ -0,0 +1,284 @@+{- + Copyright 2008 Mario Blazevic++ This file is part of the Streaming Component Combinators (SCC) project.++ The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public+ License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later+ version.++ SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty+ of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.++ You should have received a copy of the GNU General Public License along with SCC. If not, see+ <http://www.gnu.org/licenses/>.+-}++-- | Module "Components" defines primitive components of 'Producer', 'Consumer', 'Transducer' and 'Splitter' types,+-- defined in the "Foundation" and "ComponentTypes" modules.++{-# LANGUAGE ScopedTypeVariables, Rank2Types #-}++module Control.Concurrent.SCC.Components+ (-- * IO components+ fromFile, fromHandle, fromStdIn,+ appendFile, toFile, toHandle, toStdOut, toPrint,+ -- * Generic transducers+ asis, suppress, erroneous,+ prepend, append, substitute,+ -- * Generic splitters+ allTrue, allFalse, one, substring, substringMatch,+ -- * List transducers+ -- | The following laws hold:+ --+ -- * 'group' '>->' 'concatenate' == 'asis'+ --+ -- * 'concatenate' == 'concatSeparate' []+ group, concatenate, concatSeparate,+ -- * Character stream components+ lowercase, uppercase, whitespace, letters, digits, line, nonEmptyLine,+ -- * Oddballs+ count, toString+)+where++import Control.Concurrent.SCC.Foundation+import Control.Concurrent.SCC.ComponentTypes++import Prelude hiding (appendFile, last)+import Control.Monad (liftM, when)+import qualified Control.Monad as Monad+import Data.Char (isAlpha, isDigit, isPrint, isSpace, toLower, toUpper)+import Data.List (isPrefixOf, stripPrefix)+import Data.Maybe (fromJust)+import qualified Data.Foldable as Foldable+import qualified Data.Sequence as Seq+import Data.Sequence (Seq, (|>), ViewL (EmptyL, (:<)))+import Data.Typeable (Typeable)+import Debug.Trace (trace)+import System.IO (Handle, IOMode (ReadMode, WriteMode, AppendMode), openFile, hClose,+ hGetChar, hPutChar, hFlush, hIsEOF, hClose, putChar, isEOF, stdout)+++-- | Consumer 'toStdOut' copies the given source into the standard output.+toStdOut :: Consumer IO Char ()+toStdOut source = getSuccess source (\x-> liftPipe (putChar x) >> toStdOut source)++toPrint :: forall x. (Show x, Typeable x) => Consumer IO x ()+toPrint source = getSuccess source (\x-> liftPipe (print x) >> toPrint source)++-- | 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)++-- | 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++-- | 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)++-- | 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++-- | 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++-- | 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)++-- | Transducer 'asis' passes its input through unmodified.+asis :: (Monad m, Typeable x) => Transducer m x x+asis = Transducer (\source sink-> pour source sink >> return [])++-- | 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 [])++-- | 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.")++-- | 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++-- | 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 [])++-- | 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 []))++toString :: (Monad m, Show x, Typeable x) => Transducer m x String+toString = lift121Transducer 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)++-- | 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++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))++-- | Splitter 'whitespace' feeds all white-space characters into its /true/ sink, all others into /false/.+whitespace :: Monad m => Splitter m Char+whitespace = liftStatelessSplitter 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++-- | Splitter 'digits' feeds all digits into its /true/ sink, all other characters into /false/.+digits :: Monad m => Splitter m Char+digits = liftStatelessSplitter 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')++-- | 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+ split1 x = if x == '\n' || x == '\r'+ then split2 x+ else lineChar x+ split2 x = put false (Just x)+ >>= cond+ (get source+ >>= maybe+ (return [])+ (\y-> if x == y+ then emptyLine x+ else if y == '\n' || y == '\r'+ then split3 x+ else lineChar y))+ (return [x])+ split3 x = put false (Just x)+ >>= cond+ (get source+ >>= maybe+ (return [])+ (\y-> if y == '\n' || y == '\r'+ then emptyLine y+ else lineChar y))+ (return [x])+ emptyLine x = put true Nothing >>= cond (split2 x) (return [])+ lineChar x = put true (Just x) >>= cond split0 (return [x])+ 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 'allFalse' feeds its entire input into its /false/ sink.+allFalse :: (Monad m, Typeable x) => Splitter m x+allFalse = liftStatelessSplitter (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)++-- | 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++-- | 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++substringPrim _ [] = liftSectionSplitter (\ source true false ->+ do put true Nothing+ rest <- splitSections one source false true+ put true Nothing+ return rest)+substringPrim overlap list+ = liftSectionSplitter $+ \ source true false ->+ let getNext rest q separate = get source+ >>= maybe+ (liftM (map fromJust) $+ putList (map Just $ Foldable.toList (Seq.viewl q)) false)+ (\x-> do when separate (put false Nothing >> return ())+ advance rest q x)+ advance rest@(head:tail) q x = if x == head+ then if null tail+ then liftM (map fromJust) (putList (map Just list) true)+ >>= whenNull (if overlap+ then fallback True (Seq.drop 1 q)+ else getNext list Seq.empty True)+ else getNext tail (q |> x) False+ else fallback False (q |> x)+ fallback committed q = case stripPrefix (Foldable.toList (Seq.viewl q)) list+ of Just rest -> getNext rest q committed+ Nothing -> let view@(head :< tail) = Seq.viewl q+ in if committed+ then fallback committed tail+ else put false (Just head)+ >>= cond+ (fallback committed tail)+ (return (Foldable.toList view))+ in getNext list Seq.empty False
+ Control/Concurrent/SCC/Foundation.hs view
@@ -0,0 +1,249 @@+{- + Copyright 2008 Mario Blazevic++ This file is part of the Streaming Component Combinators (SCC) project.++ The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public+ License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later+ version.++ SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty+ of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.++ You should have received a copy of the GNU General Public License along with SCC. If not, see+ <http://www.gnu.org/licenses/>.+-}++-- | Module "Foundation" defines the pipe computations and their basic building blocks.++{-# LANGUAGE ScopedTypeVariables, Rank2Types, PatternGuards, ExistentialQuantification #-}++module Control.Concurrent.SCC.Foundation+ (-- * Types+ Pipe, Source, Sink, Consumer, Producer,+ -- * Flow-control functions+ pipe, pipeD, get, getSuccess, canPut, put,+ liftPipe, runPipes,+ -- * Utility functions+ cond, whenNull, pour, tee, getList, putList, consumeAndSuppress)+where++import Control.Exception (assert)+import Control.Monad (liftM, when)+import Data.Maybe (maybe)+import Data.Typeable (Typeable, cast)++import Debug.Trace (trace)++-- | '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,+ description :: String,+ continuation :: SuspendedContinuation context m r}+data SuspendedContinuation context m r = forall x. Typeable x => Get (Maybe x -> Pipe context m r)+ | forall x. Typeable x => Put x (Bool -> Pipe context m r)+ | CanPut (Bool -> Pipe context m r)++-- | A 'Source' is the read-only end of a 'Pipe' communication channel.+data Source context x = Source context Int String+-- | A 'Sink' is the write-only end of a 'Pipe' communication channel.+data Sink context x = Sink context 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+-- | 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++-- | 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)++-- | 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++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)}++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++-- | 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 = 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)++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)) $+ 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)++merge :: Monad m => [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+ | 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 => (Pipe context m r1 -> Pipe context m r2) -> Suspension context m r1 -> Suspension context m r2+delay' f s@Suspension{description= desc, continuation= Get cont}+ = s{description= "delayed " ++ desc, continuation= Get (f . cont)}+delay' f s@Suspension{description= desc, continuation= Put x cont}+ = s{description= "delayed " ++ desc, continuation= Put x (f . cont)}+delay' f s@Suspension{description= desc, continuation= CanPut cont}+ = s{description= "delayed " ++ desc, continuation= CanPut (f . cont)}++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])++getSuccess :: forall context 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)])++-- | 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)])++-- | '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 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 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)++-- | '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 [] 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 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 source = getSuccess source (\x-> consumeAndSuppress source)++-- | A utility function wrapping if-then-else, useful for handling monadic truth values+cond :: a -> a -> Bool -> a+cond x y test = if test then x else y++-- | A utility function, useful for handling monadic list values where empty list means success+whenNull :: forall a m. Monad m => m [a] -> [a] -> m [a]+whenNull action list = if null list then action else return list++track :: String -> Bool+track message = True
+ LICENSE.txt view
@@ -0,0 +1,674 @@+ GNU GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++ Preamble++ The GNU General Public License is a free, copyleft license for+software and other kinds of works.++ The licenses for most software and other practical works are designed+to take away your freedom to share and change the works. By contrast,+the GNU General Public License is intended to guarantee your freedom to+share and change all versions of a program--to make sure it remains free+software for all its users. We, the Free Software Foundation, use the+GNU General Public License for most of our software; it applies also to+any other work released this way by its authors. You can apply it to+your programs, too.++ When we speak of free software, we are referring to freedom, not+price. Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+them if you wish), that you receive source code or can get it if you+want it, that you can change the software or use pieces of it in new+free programs, and that you know you can do these things.++ To protect your rights, we need to prevent others from denying you+these rights or asking you to surrender the rights. Therefore, you have+certain responsibilities if you distribute copies of the software, or if+you modify it: responsibilities to respect the freedom of others.++ For example, if you distribute copies of such a program, whether+gratis or for a fee, you must pass on to the recipients the same+freedoms that you received. You must make sure that they, too, receive+or can get the source code. And you must show them these terms so they+know their rights.++ Developers that use the GNU GPL protect your rights with two steps:+(1) assert copyright on the software, and (2) offer you this License+giving you legal permission to copy, distribute and/or modify it.++ For the developers' and authors' protection, the GPL clearly explains+that there is no warranty for this free software. For both users' and+authors' sake, the GPL requires that modified versions be marked as+changed, so that their problems will not be attributed erroneously to+authors of previous versions.++ Some devices are designed to deny users access to install or run+modified versions of the software inside them, although the manufacturer+can do so. This is fundamentally incompatible with the aim of+protecting users' freedom to change the software. The systematic+pattern of such abuse occurs in the area of products for individuals to+use, which is precisely where it is most unacceptable. Therefore, we+have designed this version of the GPL to prohibit the practice for those+products. If such problems arise substantially in other domains, we+stand ready to extend this provision to those domains in future versions+of the GPL, as needed to protect the freedom of users.++ Finally, every program is threatened constantly by software patents.+States should not allow patents to restrict development and use of+software on general-purpose computers, but in those that do, we wish to+avoid the special danger that patents applied to a free program could+make it effectively proprietary. To prevent this, the GPL assures that+patents cannot be used to render the program non-free.++ The precise terms and conditions for copying, distribution and+modification follow.++ TERMS AND CONDITIONS++ 0. Definitions.++ "This License" refers to version 3 of the GNU General Public License.++ "Copyright" also means copyright-like laws that apply to other kinds of+works, such as semiconductor masks.++ "The Program" refers to any copyrightable work licensed under this+License. Each licensee is addressed as "you". "Licensees" and+"recipients" may be individuals or organizations.++ To "modify" a work means to copy from or adapt all or part of the work+in a fashion requiring copyright permission, other than the making of an+exact copy. The resulting work is called a "modified version" of the+earlier work or a work "based on" the earlier work.++ A "covered work" means either the unmodified Program or a work based+on the Program.++ To "propagate" a work means to do anything with it that, without+permission, would make you directly or secondarily liable for+infringement under applicable copyright law, except executing it on a+computer or modifying a private copy. Propagation includes copying,+distribution (with or without modification), making available to the+public, and in some countries other activities as well.++ To "convey" a work means any kind of propagation that enables other+parties to make or receive copies. Mere interaction with a user through+a computer network, with no transfer of a copy, is not conveying.++ An interactive user interface displays "Appropriate Legal Notices"+to the extent that it includes a convenient and prominently visible+feature that (1) displays an appropriate copyright notice, and (2)+tells the user that there is no warranty for the work (except to the+extent that warranties are provided), that licensees may convey the+work under this License, and how to view a copy of this License. If+the interface presents a list of user commands or options, such as a+menu, a prominent item in the list meets this criterion.++ 1. Source Code.++ The "source code" for a work means the preferred form of the work+for making modifications to it. "Object code" means any non-source+form of a work.++ A "Standard Interface" means an interface that either is an official+standard defined by a recognized standards body, or, in the case of+interfaces specified for a particular programming language, one that+is widely used among developers working in that language.++ The "System Libraries" of an executable work include anything, other+than the work as a whole, that (a) is included in the normal form of+packaging a Major Component, but which is not part of that Major+Component, and (b) serves only to enable use of the work with that+Major Component, or to implement a Standard Interface for which an+implementation is available to the public in source code form. A+"Major Component", in this context, means a major essential component+(kernel, window system, and so on) of the specific operating system+(if any) on which the executable work runs, or a compiler used to+produce the work, or an object code interpreter used to run it.++ The "Corresponding Source" for a work in object code form means all+the source code needed to generate, install, and (for an executable+work) run the object code and to modify the work, including scripts to+control those activities. However, it does not include the work's+System Libraries, or general-purpose tools or generally available free+programs which are used unmodified in performing those activities but+which are not part of the work. For example, Corresponding Source+includes interface definition files associated with source files for+the work, and the source code for shared libraries and dynamically+linked subprograms that the work is specifically designed to require,+such as by intimate data communication or control flow between those+subprograms and other parts of the work.++ The Corresponding Source need not include anything that users+can regenerate automatically from other parts of the Corresponding+Source.++ The Corresponding Source for a work in source code form is that+same work.++ 2. Basic Permissions.++ All rights granted under this License are granted for the term of+copyright on the Program, and are irrevocable provided the stated+conditions are met. This License explicitly affirms your unlimited+permission to run the unmodified Program. The output from running a+covered work is covered by this License only if the output, given its+content, constitutes a covered work. This License acknowledges your+rights of fair use or other equivalent, as provided by copyright law.++ You may make, run and propagate covered works that you do not+convey, without conditions so long as your license otherwise remains+in force. You may convey covered works to others for the sole purpose+of having them make modifications exclusively for you, or provide you+with facilities for running those works, provided that you comply with+the terms of this License in conveying all material for which you do+not control copyright. Those thus making or running the covered works+for you must do so exclusively on your behalf, under your direction+and control, on terms that prohibit them from making any copies of+your copyrighted material outside their relationship with you.++ Conveying under any other circumstances is permitted solely under+the conditions stated below. Sublicensing is not allowed; section 10+makes it unnecessary.++ 3. Protecting Users' Legal Rights From Anti-Circumvention Law.++ No covered work shall be deemed part of an effective technological+measure under any applicable law fulfilling obligations under article+11 of the WIPO copyright treaty adopted on 20 December 1996, or+similar laws prohibiting or restricting circumvention of such+measures.++ When you convey a covered work, you waive any legal power to forbid+circumvention of technological measures to the extent such circumvention+is effected by exercising rights under this License with respect to+the covered work, and you disclaim any intention to limit operation or+modification of the work as a means of enforcing, against the work's+users, your or third parties' legal rights to forbid circumvention of+technological measures.++ 4. Conveying Verbatim Copies.++ You may convey verbatim copies of the Program's source code as you+receive it, in any medium, provided that you conspicuously and+appropriately publish on each copy an appropriate copyright notice;+keep intact all notices stating that this License and any+non-permissive terms added in accord with section 7 apply to the code;+keep intact all notices of the absence of any warranty; and give all+recipients a copy of this License along with the Program.++ You may charge any price or no price for each copy that you convey,+and you may offer support or warranty protection for a fee.++ 5. Conveying Modified Source Versions.++ You may convey a work based on the Program, or the modifications to+produce it from the Program, in the form of source code under the+terms of section 4, provided that you also meet all of these conditions:++ a) The work must carry prominent notices stating that you modified+ it, and giving a relevant date.++ b) The work must carry prominent notices stating that it is+ released under this License and any conditions added under section+ 7. This requirement modifies the requirement in section 4 to+ "keep intact all notices".++ c) You must license the entire work, as a whole, under this+ License to anyone who comes into possession of a copy. This+ License will therefore apply, along with any applicable section 7+ additional terms, to the whole of the work, and all its parts,+ regardless of how they are packaged. This License gives no+ permission to license the work in any other way, but it does not+ invalidate such permission if you have separately received it.++ d) If the work has interactive user interfaces, each must display+ Appropriate Legal Notices; however, if the Program has interactive+ interfaces that do not display Appropriate Legal Notices, your+ work need not make them do so.++ A compilation of a covered work with other separate and independent+works, which are not by their nature extensions of the covered work,+and which are not combined with it such as to form a larger program,+in or on a volume of a storage or distribution medium, is called an+"aggregate" if the compilation and its resulting copyright are not+used to limit the access or legal rights of the compilation's users+beyond what the individual works permit. Inclusion of a covered work+in an aggregate does not cause this License to apply to the other+parts of the aggregate.++ 6. Conveying Non-Source Forms.++ You may convey a covered work in object code form under the terms+of sections 4 and 5, provided that you also convey the+machine-readable Corresponding Source under the terms of this License,+in one of these ways:++ a) Convey the object code in, or embodied in, a physical product+ (including a physical distribution medium), accompanied by the+ Corresponding Source fixed on a durable physical medium+ customarily used for software interchange.++ b) Convey the object code in, or embodied in, a physical product+ (including a physical distribution medium), accompanied by a+ written offer, valid for at least three years and valid for as+ long as you offer spare parts or customer support for that product+ model, to give anyone who possesses the object code either (1) a+ copy of the Corresponding Source for all the software in the+ product that is covered by this License, on a durable physical+ medium customarily used for software interchange, for a price no+ more than your reasonable cost of physically performing this+ conveying of source, or (2) access to copy the+ Corresponding Source from a network server at no charge.++ c) Convey individual copies of the object code with a copy of the+ written offer to provide the Corresponding Source. This+ alternative is allowed only occasionally and noncommercially, and+ only if you received the object code with such an offer, in accord+ with subsection 6b.++ d) Convey the object code by offering access from a designated+ place (gratis or for a charge), and offer equivalent access to the+ Corresponding Source in the same way through the same place at no+ further charge. You need not require recipients to copy the+ Corresponding Source along with the object code. If the place to+ copy the object code is a network server, the Corresponding Source+ may be on a different server (operated by you or a third party)+ that supports equivalent copying facilities, provided you maintain+ clear directions next to the object code saying where to find the+ Corresponding Source. Regardless of what server hosts the+ Corresponding Source, you remain obligated to ensure that it is+ available for as long as needed to satisfy these requirements.++ e) Convey the object code using peer-to-peer transmission, provided+ you inform other peers where the object code and Corresponding+ Source of the work are being offered to the general public at no+ charge under subsection 6d.++ A separable portion of the object code, whose source code is excluded+from the Corresponding Source as a System Library, need not be+included in conveying the object code work.++ A "User Product" is either (1) a "consumer product", which means any+tangible personal property which is normally used for personal, family,+or household purposes, or (2) anything designed or sold for incorporation+into a dwelling. In determining whether a product is a consumer product,+doubtful cases shall be resolved in favor of coverage. For a particular+product received by a particular user, "normally used" refers to a+typical or common use of that class of product, regardless of the status+of the particular user or of the way in which the particular user+actually uses, or expects or is expected to use, the product. A product+is a consumer product regardless of whether the product has substantial+commercial, industrial or non-consumer uses, unless such uses represent+the only significant mode of use of the product.++ "Installation Information" for a User Product means any methods,+procedures, authorization keys, or other information required to install+and execute modified versions of a covered work in that User Product from+a modified version of its Corresponding Source. The information must+suffice to ensure that the continued functioning of the modified object+code is in no case prevented or interfered with solely because+modification has been made.++ If you convey an object code work under this section in, or with, or+specifically for use in, a User Product, and the conveying occurs as+part of a transaction in which the right of possession and use of the+User Product is transferred to the recipient in perpetuity or for a+fixed term (regardless of how the transaction is characterized), the+Corresponding Source conveyed under this section must be accompanied+by the Installation Information. But this requirement does not apply+if neither you nor any third party retains the ability to install+modified object code on the User Product (for example, the work has+been installed in ROM).++ The requirement to provide Installation Information does not include a+requirement to continue to provide support service, warranty, or updates+for a work that has been modified or installed by the recipient, or for+the User Product in which it has been modified or installed. Access to a+network may be denied when the modification itself materially and+adversely affects the operation of the network or violates the rules and+protocols for communication across the network.++ Corresponding Source conveyed, and Installation Information provided,+in accord with this section must be in a format that is publicly+documented (and with an implementation available to the public in+source code form), and must require no special password or key for+unpacking, reading or copying.++ 7. Additional Terms.++ "Additional permissions" are terms that supplement the terms of this+License by making exceptions from one or more of its conditions.+Additional permissions that are applicable to the entire Program shall+be treated as though they were included in this License, to the extent+that they are valid under applicable law. If additional permissions+apply only to part of the Program, that part may be used separately+under those permissions, but the entire Program remains governed by+this License without regard to the additional permissions.++ When you convey a copy of a covered work, you may at your option+remove any additional permissions from that copy, or from any part of+it. (Additional permissions may be written to require their own+removal in certain cases when you modify the work.) You may place+additional permissions on material, added by you to a covered work,+for which you have or can give appropriate copyright permission.++ Notwithstanding any other provision of this License, for material you+add to a covered work, you may (if authorized by the copyright holders of+that material) supplement the terms of this License with terms:++ a) Disclaiming warranty or limiting liability differently from the+ terms of sections 15 and 16 of this License; or++ b) Requiring preservation of specified reasonable legal notices or+ author attributions in that material or in the Appropriate Legal+ Notices displayed by works containing it; or++ c) Prohibiting misrepresentation of the origin of that material, or+ requiring that modified versions of such material be marked in+ reasonable ways as different from the original version; or++ d) Limiting the use for publicity purposes of names of licensors or+ authors of the material; or++ e) Declining to grant rights under trademark law for use of some+ trade names, trademarks, or service marks; or++ f) Requiring indemnification of licensors and authors of that+ material by anyone who conveys the material (or modified versions of+ it) with contractual assumptions of liability to the recipient, for+ any liability that these contractual assumptions directly impose on+ those licensors and authors.++ All other non-permissive additional terms are considered "further+restrictions" within the meaning of section 10. If the Program as you+received it, or any part of it, contains a notice stating that it is+governed by this License along with a term that is a further+restriction, you may remove that term. If a license document contains+a further restriction but permits relicensing or conveying under this+License, you may add to a covered work material governed by the terms+of that license document, provided that the further restriction does+not survive such relicensing or conveying.++ If you add terms to a covered work in accord with this section, you+must place, in the relevant source files, a statement of the+additional terms that apply to those files, or a notice indicating+where to find the applicable terms.++ Additional terms, permissive or non-permissive, may be stated in the+form of a separately written license, or stated as exceptions;+the above requirements apply either way.++ 8. Termination.++ You may not propagate or modify a covered work except as expressly+provided under this License. Any attempt otherwise to propagate or+modify it is void, and will automatically terminate your rights under+this License (including any patent licenses granted under the third+paragraph of section 11).++ However, if you cease all violation of this License, then your+license from a particular copyright holder is reinstated (a)+provisionally, unless and until the copyright holder explicitly and+finally terminates your license, and (b) permanently, if the copyright+holder fails to notify you of the violation by some reasonable means+prior to 60 days after the cessation.++ Moreover, your license from a particular copyright holder is+reinstated permanently if the copyright holder notifies you of the+violation by some reasonable means, this is the first time you have+received notice of violation of this License (for any work) from that+copyright holder, and you cure the violation prior to 30 days after+your receipt of the notice.++ Termination of your rights under this section does not terminate the+licenses of parties who have received copies or rights from you under+this License. If your rights have been terminated and not permanently+reinstated, you do not qualify to receive new licenses for the same+material under section 10.++ 9. Acceptance Not Required for Having Copies.++ You are not required to accept this License in order to receive or+run a copy of the Program. Ancillary propagation of a covered work+occurring solely as a consequence of using peer-to-peer transmission+to receive a copy likewise does not require acceptance. However,+nothing other than this License grants you permission to propagate or+modify any covered work. These actions infringe copyright if you do+not accept this License. Therefore, by modifying or propagating a+covered work, you indicate your acceptance of this License to do so.++ 10. Automatic Licensing of Downstream Recipients.++ Each time you convey a covered work, the recipient automatically+receives a license from the original licensors, to run, modify and+propagate that work, subject to this License. You are not responsible+for enforcing compliance by third parties with this License.++ An "entity transaction" is a transaction transferring control of an+organization, or substantially all assets of one, or subdividing an+organization, or merging organizations. If propagation of a covered+work results from an entity transaction, each party to that+transaction who receives a copy of the work also receives whatever+licenses to the work the party's predecessor in interest had or could+give under the previous paragraph, plus a right to possession of the+Corresponding Source of the work from the predecessor in interest, if+the predecessor has it or can get it with reasonable efforts.++ You may not impose any further restrictions on the exercise of the+rights granted or affirmed under this License. For example, you may+not impose a license fee, royalty, or other charge for exercise of+rights granted under this License, and you may not initiate litigation+(including a cross-claim or counterclaim in a lawsuit) alleging that+any patent claim is infringed by making, using, selling, offering for+sale, or importing the Program or any portion of it.++ 11. Patents.++ A "contributor" is a copyright holder who authorizes use under this+License of the Program or a work on which the Program is based. The+work thus licensed is called the contributor's "contributor version".++ A contributor's "essential patent claims" are all patent claims+owned or controlled by the contributor, whether already acquired or+hereafter acquired, that would be infringed by some manner, permitted+by this License, of making, using, or selling its contributor version,+but do not include claims that would be infringed only as a+consequence of further modification of the contributor version. For+purposes of this definition, "control" includes the right to grant+patent sublicenses in a manner consistent with the requirements of+this License.++ Each contributor grants you a non-exclusive, worldwide, royalty-free+patent license under the contributor's essential patent claims, to+make, use, sell, offer for sale, import and otherwise run, modify and+propagate the contents of its contributor version.++ In the following three paragraphs, a "patent license" is any express+agreement or commitment, however denominated, not to enforce a patent+(such as an express permission to practice a patent or covenant not to+sue for patent infringement). To "grant" such a patent license to a+party means to make such an agreement or commitment not to enforce a+patent against the party.++ If you convey a covered work, knowingly relying on a patent license,+and the Corresponding Source of the work is not available for anyone+to copy, free of charge and under the terms of this License, through a+publicly available network server or other readily accessible means,+then you must either (1) cause the Corresponding Source to be so+available, or (2) arrange to deprive yourself of the benefit of the+patent license for this particular work, or (3) arrange, in a manner+consistent with the requirements of this License, to extend the patent+license to downstream recipients. "Knowingly relying" means you have+actual knowledge that, but for the patent license, your conveying the+covered work in a country, or your recipient's use of the covered work+in a country, would infringe one or more identifiable patents in that+country that you have reason to believe are valid.++ If, pursuant to or in connection with a single transaction or+arrangement, you convey, or propagate by procuring conveyance of, a+covered work, and grant a patent license to some of the parties+receiving the covered work authorizing them to use, propagate, modify+or convey a specific copy of the covered work, then the patent license+you grant is automatically extended to all recipients of the covered+work and works based on it.++ A patent license is "discriminatory" if it does not include within+the scope of its coverage, prohibits the exercise of, or is+conditioned on the non-exercise of one or more of the rights that are+specifically granted under this License. You may not convey a covered+work if you are a party to an arrangement with a third party that is+in the business of distributing software, under which you make payment+to the third party based on the extent of your activity of conveying+the work, and under which the third party grants, to any of the+parties who would receive the covered work from you, a discriminatory+patent license (a) in connection with copies of the covered work+conveyed by you (or copies made from those copies), or (b) primarily+for and in connection with specific products or compilations that+contain the covered work, unless you entered into that arrangement,+or that patent license was granted, prior to 28 March 2007.++ Nothing in this License shall be construed as excluding or limiting+any implied license or other defenses to infringement that may+otherwise be available to you under applicable patent law.++ 12. No Surrender of Others' Freedom.++ If conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License. If you cannot convey a+covered work so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you may+not convey it at all. For example, if you agree to terms that obligate you+to collect a royalty for further conveying from those to whom you convey+the Program, the only way you could satisfy both those terms and this+License would be to refrain entirely from conveying the Program.++ 13. Use with the GNU Affero General Public License.++ Notwithstanding any other provision of this License, you have+permission to link or combine any covered work with a work licensed+under version 3 of the GNU Affero General Public License into a single+combined work, and to convey the resulting work. The terms of this+License will continue to apply to the part which is the covered work,+but the special requirements of the GNU Affero General Public License,+section 13, concerning interaction through a network will apply to the+combination as such.++ 14. Revised Versions of this License.++ The Free Software Foundation may publish revised and/or new versions of+the GNU General Public License from time to time. Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++ Each version is given a distinguishing version number. If the+Program specifies that a certain numbered version of the GNU General+Public License "or any later version" applies to it, you have the+option of following the terms and conditions either of that numbered+version or of any later version published by the Free Software+Foundation. If the Program does not specify a version number of the+GNU General Public License, you may choose any version ever published+by the Free Software Foundation.++ If the Program specifies that a proxy can decide which future+versions of the GNU General Public License can be used, that proxy's+public statement of acceptance of a version permanently authorizes you+to choose that version for the Program.++ Later license versions may give you additional or different+permissions. However, no additional obligations are imposed on any+author or copyright holder as a result of your choosing to follow a+later version.++ 15. Disclaimer of Warranty.++ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++ 16. Limitation of Liability.++ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF+SUCH DAMAGES.++ 17. Interpretation of Sections 15 and 16.++ If the disclaimer of warranty and limitation of liability provided+above cannot be given local legal effect according to their terms,+reviewing courts shall apply local law that most closely approximates+an absolute waiver of all civil liability in connection with the+Program, unless a warranty or assumption of liability accompanies a+copy of the Program in return for a fee.++ END OF TERMS AND CONDITIONS++ How to Apply These Terms to Your New Programs++ If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++ To do so, attach the following notices to the program. It is safest+to attach them to the start of each source file to most effectively+state the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++ <one line to give the program's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ This program is free software: you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation, either version 3 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program. If not, see <http://www.gnu.org/licenses/>.++Also add information on how to contact you by electronic and paper mail.++ If the program does terminal interaction, make it output a short+notice like this when it starts in an interactive mode:++ <program> Copyright (C) <year> <name of author>+ This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+ This is free software, and you are welcome to redistribute it+ under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License. Of course, your program's commands+might be different; for a GUI interface, you would use an "about box".++ You should also get your employer (if you work as a programmer) or school,+if any, to sign a "copyright disclaimer" for the program, if necessary.+For more information on this, and how to apply and follow the GNU GPL, see+<http://www.gnu.org/licenses/>.++ The GNU General Public License does not permit incorporating your program+into proprietary programs. If your program is a subroutine library, you+may consider it more useful to permit linking proprietary applications with+the library. If this is what you want to do, use the GNU Lesser General+Public License instead of this License. But first, please read+<http://www.gnu.org/philosophy/why-not-lgpl.html>.
+ Makefile view
@@ -0,0 +1,23 @@+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"))')++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-prof: $(SourceFiles)+ ghc --make Test.hs -main-is Test -o test-prof -prof -auto-all -hidir prof -odir prof++shsh: $(SourceFiles)+ ghc --make Shell.hs -O -o shsh -hidir obj -odir obj++shsh-prof: $(SourceFiles)+ ghc --make Shell.hs -main-is Shell -o shsh-prof -prof -auto-all -hidir prof -odir prof++doc/index.html: $(DocumentationFiles)+ haddock -h -o doc $^++clean:+ rm obj/* prof/* doc/*
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell+ +> import Distribution.Simple+> main = defaultMain
+ Shell.hs view
@@ -0,0 +1,746 @@+{- + Copyright 2008 Mario Blazevic++ This file is part of the Streaming Component Combinators (SCC) project.++ The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public+ License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later+ version.++ SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty+ of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.++ You should have received a copy of the GNU General Public License along with SCC. If not, see+ <http://www.gnu.org/licenses/>.+-}++{-# LANGUAGE ScopedTypeVariables, Rank2Types, GADTs, PatternSignatures #-}++module Main where++import Prelude hiding ((&&), (||), appendFile, interact, last)+import Data.List (intersperse)+import Data.Maybe (fromJust)+import Data.Typeable (Typeable)+import Control.Monad (liftM, when)+import Text.ParserCombinators.Parsec hiding (between, count)+import Text.ParserCombinators.Parsec.Language (emptyDef)+import Text.ParserCombinators.Parsec.Token+import System.Console.GetOpt+import System.Console.Readline+import System.Environment (getArgs)+import System.IO (hFlush, hPutStrLn, stderr, stdout)+import System.Process (runCommand, runInteractiveCommand)++import Control.Concurrent.SCC.Foundation+import Control.Concurrent.SCC.ComponentTypes+import Control.Concurrent.SCC.Components+import Control.Concurrent.SCC.Combinators++data VoidExpression where+ NativeVoidCommand :: String -> VoidExpression+ VoidPipe :: Typeable x => ProducerExpression x -> ConsumerExpression x -> VoidExpression+ Exit :: VoidExpression++data ProducerExpression x where+ PrimitiveProducer :: Typeable x => String -> Producer IO x () -> ProducerExpression x+ NativeProducerCommand :: String -> ProducerExpression Char+ VoidSource :: Typeable x => VoidExpression -> ProducerExpression x+ ProducerPipe :: (Typeable x, Typeable y) => ProducerExpression x -> TransducerExpression x y -> ProducerExpression y+ FileSource :: String -> ProducerExpression Char+ StdInSource :: ProducerExpression Char+ Sequence :: Typeable x => ProducerExpression x -> ProducerExpression x -> ProducerExpression x++data ConsumerExpression x where+ NativeConsumerCommand :: String -> ConsumerExpression Char+ VoidSink :: Typeable x => VoidExpression -> ConsumerExpression x+ ConsumerPipe :: (Typeable x, Typeable y) => TransducerExpression x y -> ConsumerExpression y -> ConsumerExpression x+ FileSink :: String -> ConsumerExpression Char+ FileAppendSink :: String -> ConsumerExpression Char+ SuppressingConsumer :: Typeable x => ConsumerExpression x+ ErrorSink :: Typeable x => String -> ConsumerExpression x+ Tee :: Typeable x => ConsumerExpression x -> ConsumerExpression x -> ConsumerExpression x++data TransducerExpression x y where+ PrimitiveTransducer :: (Typeable x, Typeable y) => String -> Transducer IO x y -> TransducerExpression x y+ NativeTransducerCommand :: String -> TransducerExpression Char Char+ TransducerPipe :: (Typeable x, Typeable y, Typeable z)+ => TransducerExpression x y -> TransducerExpression y z -> TransducerExpression x z+ TransducerJoin :: (Typeable x, Typeable y) => TransducerExpression x y -> TransducerExpression x y -> TransducerExpression x y+ Select :: Typeable x => SplitterExpression x -> TransducerExpression x x+ If :: (Typeable x, Typeable y)+ => SplitterExpression x -> TransducerExpression x y -> TransducerExpression x y -> TransducerExpression x y+ While :: Typeable x => SplitterExpression x -> TransducerExpression x x -> TransducerExpression x x+ ForEach :: (Typeable x, Typeable y)+ => SplitterExpression x -> TransducerExpression x y -> TransducerExpression x y -> TransducerExpression x y++data SplitterExpression x where+ PrimitiveSplitter :: Typeable x => String -> Splitter IO x -> SplitterExpression x+ And :: Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x+ Or :: Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x+ ZipWithAnd :: Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x+ ZipWithOr :: Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x+ Not :: Typeable x => SplitterExpression x -> SplitterExpression x+ FollowedBy :: Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x+ Nested :: Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x+ Having :: Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x+ HavingOnly :: Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x+ Between :: Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x+ BetweenInclusive :: Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x+ First :: Typeable x => SplitterExpression x -> SplitterExpression x+ Last :: Typeable x => SplitterExpression x -> SplitterExpression x+ Prefix :: Typeable x => SplitterExpression x -> SplitterExpression x+ Suffix :: Typeable x => SplitterExpression x -> SplitterExpression x++instance Show VoidExpression where+ show (NativeVoidCommand cmd) = "NativeVoidCommand \"" ++ cmd ++ "\""+ show (VoidPipe p c) = "(VoidPipe " ++ shows p (" " ++ shows c ")")+ show (Exit) = "Exit"++instance Show (ProducerExpression x) where+ show (PrimitiveProducer name p) = name+ show (NativeProducerCommand cmd) = cmd+ show (VoidSource v) = "(VoidSource " ++ shows v ")"+ show (ProducerPipe p t) = "(" ++ shows p (" | " ++ shows t ")")+ show (FileSource f) = "FileSource \"" ++ f ++ "\""+ show (Sequence p1 p2) = "(Sequence " ++ shows p1 (" "++ shows p2 ")")++instance Show (ConsumerExpression x) where+ show (NativeConsumerCommand cmd) = cmd+ show (VoidSink v) = "(VoidSink " ++ shows v ")"+ show (ConsumerPipe t c) = "(ConsumerPipe " ++ shows t (" " ++ shows c ")")+ show (FileSink f) = "> \"" ++ f ++ "\""+ show (FileAppendSink f) = ">> \"" ++ f ++ "\""+ show (SuppressingConsumer) = "SuppressingConsumer"+ show (ErrorSink e) = "ErrorSink \"" ++ e ++ "\""+ show (Tee c1 c2) = "(" ++ shows c1 (" tee " ++ shows c2 ")")++instance Show (TransducerExpression x y) where+ show (PrimitiveTransducer name t) = name+ show (NativeTransducerCommand cmd) = cmd+ show (TransducerPipe t1 t2) = "(" ++ shows t1 (" | " ++ shows t2 ")")+ show (TransducerJoin t1 t2) = "(" ++ shows t1 (" >< " ++ shows t2 ")")+ show (Select s) = "(select " ++ shows s ")"+ show (If s t1 t2) = "if " ++ shows s (" then " ++ shows t1 (" else " ++ shows t2 " end if"))+ show (While s t) = "while " ++ shows s (" do " ++ shows t " end while")+ show (ForEach s t1 t2) = "foreach " ++ shows s (" then " ++ shows t1 (" else " ++ shows t2 " end foreach"))++instance Show (SplitterExpression x) where+ show (PrimitiveSplitter name s) = name+ show (And s1 s2) = shows s1 (" >& " ++ show s2)+ show (Or s1 s2) = shows s1 (" >| " ++ show s2)+ show (ZipWithAnd s1 s2) = shows s1 (" >& " ++ show s2)+ show (ZipWithOr s1 s2) = shows s1 (" >| " ++ show s2)+ show (FollowedBy s1 s2) = shows s1 (", " ++ show s2)+ show (Not s) = "Not " ++ show s+ show (Nested s1 s2) = shows s1 (" nested in " ++ show s2)+ show (Having s1 s2) = shows s1 (" having " ++ show s2)+ show (HavingOnly s1 s2) = shows s1 (" having-only " ++ show s2)+ show (Between s1 s2) = shows s1 (" having " ++ show s2)+ show (BetweenInclusive s1 s2) = shows s1 (" having " ++ show s2)+ show (First s) = "first " ++ show s+ show (Last s) = "last " ++ show s+ show (Prefix s) = "prefix " ++ show s+ show (Suffix s) = "suffix " ++ show s++data TaggedExpression where+ TaggedCommand :: VoidExpression -> TaggedExpression+ TaggedConsumer :: Typeable x => TypeTag x -> ConsumerExpression x -> TaggedExpression+ TaggedProducer :: Typeable x => TypeTag x -> ProducerExpression x -> TaggedExpression+ TaggedSplitter :: Typeable x => TypeTag x -> SplitterExpression x -> TaggedExpression+ TaggedTransducer :: (Typeable x, Typeable y) => TypeTag x -> TypeTag y -> TransducerExpression x y -> TaggedExpression+ GenericInputExpression :: (forall x. Typeable x => TypeTag x -> TaggedExpression) -> TaggedExpression+ TypeErrorExpression :: TypeTag x -> TypeTag y -> String -> TaggedExpression++instance Show TaggedExpression where+ show (TaggedCommand e) = "TaggedCommand " ++ show e+ show (TaggedConsumer tag e) = "TaggedConsumer " ++ shows e (" :: " ++ show tag)+ show (TaggedProducer tag e) = "TaggedProducer " ++ shows e (" :: " ++ show tag)+ show (TaggedSplitter tag e) = "TaggedSplitter " ++ shows e (" :: " ++ show tag)+ show (TaggedTransducer tag1 tag2 e) = "TaggedSplitter " ++ shows e (" :: " ++ show tag1 ++ " -> " ++ show tag2)+ show (TypeErrorExpression tag1 tag2 s) = "TypeError " ++ shows s (" :: " ++ show tag1 ++ " -> " ++ show tag2)+ show GenericInputExpression{} = "Cannot show a generic expression!"++data TypeTag x where+ AnyTag :: TypeTag ()+ ShowableTag :: (Typeable x, Show x) => TypeTag x+ CharTag :: TypeTag Char+ IntTag :: TypeTag Integer+ ListTag :: Typeable x => TypeTag x -> TypeTag [x]+ PairTag :: TypeTag x -> TypeTag y -> TypeTag (x, y)++instance Show (TypeTag x) where+ show AnyTag = "Any"+ show CharTag = "Char"+ show IntTag = "Int"+ show (ListTag x) = '[' : shows x "]"+ show (PairTag x y) = "(" ++ shows x (", " ++ shows y ")")++-- we use Weirich's higher-order type-safe cast to avoid deep traversals+-- one can replace the type_cast with a more simple traversal-based+-- version.++data CList c a = CList (c [a])+data CFlip c b a = CFlip (c a b)+data CL c a d = CL (c (d,a))+data CR c a d = CR (c (a,d))++typecast :: forall a b c. TypeTag a -> TypeTag b -> c a -> Maybe (c b)+typecast CharTag CharTag x = Just x+typecast IntTag IntTag x = Just x+typecast (ListTag a) (ListTag b) x = fmap (\(CList y)-> y) (typecast a b (CList x))+typecast (PairTag (ra::TypeTag a0) (rb::TypeTag b0)) (PairTag (ra'::TypeTag a0') (rb'::TypeTag b0')) x =+ let g = (typecast ra ra' :: (CL c b0) a0 -> Maybe ((CL c b0) a0'))+ h = (typecast rb rb' :: (CR c a0') b0 -> Maybe ((CR c a0') b0'))+ in case g (CL x)+ of Just (CL x') -> case h (CR x')+ of Just (CR y') -> Just y'+typecast _ _ _ = Nothing++typecast2 :: forall a a' b b' c. TypeTag a -> TypeTag b -> TypeTag a' -> TypeTag b' -> c a b -> Maybe (c a' b')+typecast2 a b a' b' x = typecast a a' (CFlip x) >>= \(CFlip x')-> typecast b b' x'++trycast :: forall a b c. Show (c a) => TypeTag a -> TypeTag b -> (c b -> TaggedExpression) -> c a -> TaggedExpression+trycast a b wrap x = case typecast a b x of Just y -> wrap y+ Nothing -> TypeErrorExpression a b (show x)++data Flag = Command | Help | Interactive | ScriptFile String | StandardInput+ deriving Eq++options = [Option "c" ["command"] (NoArg Command) "Execute a single command",+ Option "h" ["help"] (NoArg Help) "Show help",+ Option "f" ["file"] (ReqArg ScriptFile "file") "Execute commands from a script file",+ Option "i" ["interactive"] (NoArg Interactive) "Execute commands interactively",+ Option "s" ["stdin"] (NoArg StandardInput) "Execute commands from the standard input"]++usageSyntax = "Usage: shsh (-c <command> | -f <file> | -i | -s) "++main = do args <- getArgs+ case getOpt Permute options args+ of (_, _, errors) | not (null errors) -> putStr (concat errors)+ (option, _, []) | Help `elem` option -> showHelp+ (options, arguments, []) | Command `elem` options -> interpret (concat (intersperse " " arguments)) >> return ()+ ([ScriptFile name], [], []) -> readFile name >>= interpret >> return ()+ ([Interactive], [], []) -> interact+ ([StandardInput], [], []) -> getContents >>= interpret >> return ()+ _ -> showHelp++showHelp = putStrLn (usageInfo usageSyntax options)++interact = do Just command <- readline "> "+ addHistory command+ finish <- interpret command+ when (not finish) interact++interpret command = case parseExpression command+ of Left position -> putStrLn ("Error at " ++ show position) >> return False+ Right (TaggedCommand Exit, "", _) -> return True+ Right (expression, "", _) -> execute expression >> return False+ Right (expression, rest, _) -> putStrLn ("Cannot parse " ++ show rest) >> return False+++execute :: TaggedExpression -> IO ()+execute (TaggedCommand command) = runPipes (evaluateVoidExpression command)+execute (TaggedProducer CharTag producer) = liftM fst (runPipes (pipe (evaluateProducerExpression producer) toStdOut))+ >> hFlush stdout+execute (TaggedProducer tag _) = hPutStrLn stderr ("Expecting a Char Producer, received a " ++ shows tag " producer.")+execute (TypeErrorExpression tag1 tag2 e) = hPutStrLn stderr ("Expecting " ++ show tag2 ++ ", received " ++ show tag1+ ++ " in expression " ++ e)++evaluateConsumerExpression :: Typeable x => ConsumerExpression x -> Consumer IO x ()+evaluateConsumerExpression (NativeConsumerCommand command) =+ \source-> do (stdin, _, _, pid) <- liftPipe (runInteractiveCommand command)+ toHandle stdin source+evaluateConsumerExpression (ConsumerPipe filter sink) = evaluateTransducerExpression filter ->> evaluateConsumerExpression sink+evaluateConsumerExpression (FileSink path) = toFile path+evaluateConsumerExpression (FileAppendSink path) = appendFile path+evaluateConsumerExpression SuppressingConsumer = consumeAndSuppress+evaluateConsumerExpression (ErrorSink message) = undefined+evaluateConsumerExpression (Tee ce1 ce2) = \source-> pipe (\sink1-> pipe (\sink2-> tee source sink1 sink2)+ (evaluateConsumerExpression ce2)+ )+ (evaluateConsumerExpression ce1)+ >> return ()++evaluateProducerExpression :: Typeable x => ProducerExpression x -> Producer IO x ()+evaluateProducerExpression (PrimitiveProducer _ producer) = producer+evaluateProducerExpression (NativeProducerCommand command) =+ \sink-> do (_, stdout, _, pid) <- liftPipe (runInteractiveCommand command)+ fromHandle stdout sink+evaluateProducerExpression (ProducerPipe source filter) = evaluateTransducerExpression filter <<- evaluateProducerExpression source+evaluateProducerExpression (FileSource path) = fromFile path+evaluateProducerExpression StdInSource = fromStdIn++evaluateVoidExpression :: VoidExpression -> Pipe c IO ()+evaluateVoidExpression (NativeVoidCommand command) = liftPipe (runCommand command >> return ())+evaluateVoidExpression (VoidPipe source sink) =+ do pipe (evaluateProducerExpression source) (evaluateConsumerExpression sink)+ return ()++evaluateTransducerExpression :: (Typeable x, Typeable y) => TransducerExpression x y -> Transducer IO x y+evaluateTransducerExpression (PrimitiveTransducer _ filter) = filter+evaluateTransducerExpression (NativeTransducerCommand command) = Transducer f+ where f source sink = do (stdin, stdout, _, pid) <- liftPipe (runInteractiveCommand command)+ interleavedPour source (toHandle stdin) (fromHandle stdout) sink+ return []++ interleavedPour :: forall c c1 c2 m x y. (Monad m, Typeable x, Typeable y)+ => Source c1 x -> Consumer m x () -> Producer m y () -> Sink c2 y -> Pipe c m ()+ interleavedPour source consumer producer sink = pipe (\sink-> pipe producer (interleave sink)) consumer+ >> return ()+ where interleave consumerSink producerSource = interleave1+ where interleave1 = canPut consumerSink+ >>= flip when (get source >>= maybe interleaveEnd (\x-> put consumerSink x >> interleave2))+ interleave2 = canPut sink+ >>= flip when (getSuccess producerSource (\y-> put sink y >> interleave1))+ interleaveEnd = canPut sink+ >>= flip when (getSuccess producerSource (\y-> put sink y >> interleaveEnd))++evaluateTransducerExpression (TransducerPipe f1 f2) = evaluateTransducerExpression f1 >-> evaluateTransducerExpression f2+evaluateTransducerExpression (TransducerJoin f1 f2) = evaluateTransducerExpression f1 `join` evaluateTransducerExpression f2+evaluateTransducerExpression (Select splitter) = select (evaluateSplitterExpression splitter)+evaluateTransducerExpression (If splitter f1 f2) =+ ifs (evaluateSplitterExpression splitter) (evaluateTransducerExpression f1) (evaluateTransducerExpression f2)+evaluateTransducerExpression (While splitter filter) =+ evaluateTransducerExpression filter `while` evaluateSplitterExpression splitter+evaluateTransducerExpression (ForEach splitter f1 f2) =+ foreach (evaluateSplitterExpression splitter) (evaluateTransducerExpression f1) (evaluateTransducerExpression f2)++evaluateSplitterExpression :: Typeable x => SplitterExpression x -> Splitter IO x+evaluateSplitterExpression (PrimitiveSplitter _ splitter) = splitter+evaluateSplitterExpression (FollowedBy s1 s2) = evaluateSplitterExpression s1 `followedBy` evaluateSplitterExpression s2+evaluateSplitterExpression (And s1 s2) = evaluateSplitterExpression s1 >& evaluateSplitterExpression s2+evaluateSplitterExpression (Or s1 s2) = evaluateSplitterExpression s1 >| evaluateSplitterExpression s2+evaluateSplitterExpression (ZipWithAnd s1 s2) = evaluateSplitterExpression s1 && evaluateSplitterExpression s2+evaluateSplitterExpression (ZipWithOr s1 s2) = evaluateSplitterExpression s1 || evaluateSplitterExpression s2+evaluateSplitterExpression (Not splitter) = snot (evaluateSplitterExpression splitter)+evaluateSplitterExpression (Nested s1 s2) = evaluateSplitterExpression s1 `nestedIn` evaluateSplitterExpression s2+evaluateSplitterExpression (Having s1 s2) = evaluateSplitterExpression s1 `having` evaluateSplitterExpression s2+evaluateSplitterExpression (HavingOnly s1 s2) = evaluateSplitterExpression s1 `havingOnly` evaluateSplitterExpression s2+evaluateSplitterExpression (Between s1 s2) = evaluateSplitterExpression s1 `between` evaluateSplitterExpression s2+evaluateSplitterExpression (BetweenInclusive s1 s2) = evaluateSplitterExpression s1 ... evaluateSplitterExpression s2+evaluateSplitterExpression (First splitter) = first (evaluateSplitterExpression splitter)+evaluateSplitterExpression (Last splitter) = last (evaluateSplitterExpression splitter)+evaluateSplitterExpression (Prefix splitter) = prefix (evaluateSplitterExpression splitter)+evaluateSplitterExpression (Suffix splitter) = suffix (evaluateSplitterExpression splitter)++specialize :: Typeable x => TypeTag x -> Parser TaggedExpression -> Parser TaggedExpression+specialize tag parser = do e <- parser+ return (case e+ of GenericInputExpression g -> g tag+ _ -> e)++combineTransducers :: (forall x y. (Typeable x, Typeable y)+ => TypeTag x -> TypeTag y -> TransducerExpression x y -> TransducerExpression x y+ -> TransducerExpression x y)+ -> TaggedExpression -> TaggedExpression -> TaggedExpression+combineTransducers combinator e1 e2 = + case (e1, e2)+ of (TaggedTransducer tag1 tag2 t1, TaggedTransducer tag1' tag2' t2) ->+ case typecast2 tag1' tag2' tag1 tag2 t2+ of Just t2' -> TaggedTransducer tag1 tag2 (combinator tag1 tag2 t1 t2')+ Nothing -> TypeErrorExpression tag2' tag2 (show t1)+ (GenericInputExpression ge, TaggedTransducer tag1 _ _) -> combineTransducers combinator (ge tag1) e2+ (TaggedTransducer tag1 _ _, GenericInputExpression ge) -> combineTransducers combinator e1 (ge tag1)+ (GenericInputExpression g1, GenericInputExpression g2)+ -> GenericInputExpression (\tag-> combineTransducers combinator (g1 tag) (g2 tag))+ (TypeErrorExpression{}, _) -> e1+ (_, TypeErrorExpression{}) -> e2++foldPipeline :: [TaggedExpression] -> TaggedExpression+foldPipeline list = foldl1 combine list+ where combine :: TaggedExpression -> TaggedExpression -> TaggedExpression+ combine (TaggedProducer tag p) (TaggedTransducer tag1 tag2 t)+ = trycast tag tag1 (\p'-> TaggedProducer tag2 (ProducerPipe p' t)) p+ combine (TaggedTransducer tag1 tag2 t1) (TaggedTransducer tag1' tag2' t2)+ = trycast tag2 tag1' (\t1'-> TaggedTransducer tag1 tag2' (TransducerPipe t1' t2)) t1+ combine p@(TaggedProducer tag _) (GenericInputExpression ge) = combine p (ge tag)+ combine (GenericInputExpression ge) other = GenericInputExpression (\tag-> combine (ge tag) other)+ combine t@(TaggedTransducer tag1 tag2 _) (GenericInputExpression ge) = combine t (ge tag2)+ combine e@TypeErrorExpression{} _ = e+ combine _ e@TypeErrorExpression{} = e++parseExpression :: String -> Either Int (TaggedExpression, [Char], Int)+parseExpression s = case parse partialExpressionParser "" s of+ Left error -> Left (sourceLine (errorPos error))+ Right result -> Right result++lexer = (makeTokenParser emptyDef{commentLine= "#"}){stringLiteral= stringLexemeParser}++partialExpressionParser :: Parser (TaggedExpression, [Char], Int)+partialExpressionParser = do whiteSpace lexer+ t <- expressionParser+ rest <- getInput+ pos <- getPosition+ return (t, rest, sourceLine pos - 1)++expressionParser :: Parser TaggedExpression+expressionParser = do tp@(TaggedProducer tag producer) <- producerPrimaryParser+ whiteSpace lexer+ transducers <- many (try (char '|' >> whiteSpace lexer >> transducerPrimaryParser))+ let tpt = foldPipeline (tp:transducers)+ whiteSpace lexer+ option tpt (liftM ((,) tpt) (try (char '|' >> whiteSpace lexer >> specialize tag consumerPrimaryParser))+ >>= \(TaggedTransducer tag1 tag2 transducer, TaggedConsumer tag' consumer)+ -> return (trycast tag tag' (\p'-> TaggedCommand (VoidPipe p' consumer)) producer))++producerExpressionParser :: Parser TaggedExpression+producerExpressionParser = do tp@(TaggedProducer tag producer) <- producerPrimaryParser+ whiteSpace lexer+ (try (do char '|'+ whiteSpace lexer+ TaggedTransducer tag1 tag2 transducer <- transducerExpressionParser+ return (trycast tag tag1 (\p'-> TaggedProducer tag2 (ProducerPipe p' transducer)) producer))+ <|>+ return tp)++consumerExpressionParser :: Parser TaggedExpression+consumerExpressionParser = try consumerForkParser+ <|>+ do TaggedTransducer tag1 tag2 transducer <- transducerExpressionParser+ whiteSpace lexer+ char '|'+ TaggedConsumer tag' consumer <- consumerForkParser+ return (trycast tag' tag2 (TaggedConsumer tag1 . ConsumerPipe transducer) consumer)++consumerForkParser :: Parser TaggedExpression+consumerForkParser = do tc@(TaggedConsumer tag first) <- consumerPrimaryParser+ whiteSpace lexer+ (try (do symbol lexer "tee"+ TaggedConsumer tag' rest <- consumerForkParser+ return (trycast tag tag' (\first'-> TaggedConsumer tag' (Tee first' rest)) first))+ <|>+ return tc)++voidPrimaryParser = try (symbol lexer "exit" >> return Exit)+ <|> liftM NativeVoidCommand nativeCommand++producerPrimaryParser :: Parser TaggedExpression+producerPrimaryParser = try (do char '('+ whiteSpace lexer+ (try (do command <- nativeCommand+ whiteSpace lexer+ char ')'+ whiteSpace lexer+ char '>'+ return (TaggedProducer CharTag (NativeProducerCommand command)))+ <|>+ do source <- producerExpressionParser+ whiteSpace lexer+ char ')'+ return source))+ <|> try (nativeSourceParser "cat")+-- <|> try (nativeSourceParser "echo")+ <|> try (do symbol lexer "echo"+ string <- parameterParser True+ return (TaggedProducer CharTag $+ PrimitiveProducer ("echo " ++ string) (\sink-> putList string sink >> return ())))+ <|> try (symbol lexer "stdin" >> return (TaggedProducer CharTag StdInSource))+ <|> nativeSourceParser "ls"++nativeSourceParser :: String -> Parser TaggedExpression+nativeSourceParser command = do symbol lexer command+ params <- nativeCommand+ return (TaggedProducer CharTag (NativeProducerCommand (command ++ " " ++ params)))++consumerPrimaryParser :: Parser TaggedExpression+consumerPrimaryParser = try (do symbol lexer ">>"+ file <- parameterParser True+ return (TaggedConsumer CharTag (FileAppendSink file)))+ <|>+ try (do symbol lexer ">"+ symbol lexer "("+ command <- nativeCommand+ whiteSpace lexer+ symbol lexer ")"+ return (TaggedConsumer CharTag (NativeConsumerCommand command)))+ <|>+ try (do symbol lexer ">"+ file <- parameterParser True+ return (TaggedConsumer CharTag (FileSink file)))+ <|>+ try (do symbol lexer "null"+ return (GenericInputExpression ((\tag-> TaggedConsumer tag SuppressingConsumer))))+ <|>+ do symbol lexer "error"+ message <- (try (parameterParser True) <|> return "Error sink reached!")+ return (GenericInputExpression (\tag-> TaggedConsumer tag (ErrorSink message)))++transducerExpressionParser :: Parser TaggedExpression+transducerExpressionParser = do first <- transducerPrimaryParser+ (try (do rest <- many1 (try (whiteSpace lexer >> symbol lexer "|" >> transducerPrimaryParser))+ return (foldPipeline (first:rest)))+ <|>+ try (do rest <- many1 (try (whiteSpace lexer >> symbol lexer "><" >> transducerPrimaryParser))+ return (foldr1 (combineTransducers (const $ const TransducerJoin)) (first:rest)))+ <|>+ return first)+ where tagged :: (forall x y. (Typeable x, Typeable y)+ => TransducerExpression x y -> TransducerExpression x y -> TransducerExpression x y)+ -> TaggedExpression -> TaggedExpression -> TaggedExpression+ tagged combinator (TaggedTransducer tag1 tag2 t1) (TaggedTransducer tag1' tag2' t2)+ = case typecast2 tag1 tag2 tag1' tag2' t1 of Just t1' -> TaggedTransducer tag1' tag2' (combinator t1' t2)+ Nothing -> TypeErrorExpression tag1 tag1' (show t1)++splitterExpressionParser :: Parser TaggedExpression+splitterExpressionParser = do first@(TaggedSplitter tag one) <- splitterPrimaryParser+ whiteSpace lexer+ (try (do rest <- many1 (try (symbol lexer ">," >> splitterPrimaryParser))+ return (foldr1 (tagged FollowedBy) (first:rest)))+ <|>+ try (do rest <- many1 (try (symbol lexer ">|" >> splitterPrimaryParser))+ return (foldr1 (tagged Or) (first:rest)))+ <|>+ try (do rest <- many1 (try (symbol lexer ">&" >> splitterPrimaryParser))+ return (foldr1 (tagged And) (first:rest)))+ <|>+ try (do rest <- many1 (try (symbol lexer "||" >> splitterPrimaryParser))+ return (foldr1 (tagged ZipWithOr) (first:rest)))+ <|>+ try (do rest <- many1 (try (symbol lexer "&&" >> splitterPrimaryParser))+ return (foldr1 (tagged ZipWithAnd) (first:rest)))+ <|>+ try (do rest <- many1 (try (symbol lexer "..." >> splitterPrimaryParser))+ return (foldr1 (tagged BetweenInclusive) (first:rest)))+ <|>+ try (do symbol lexer "having"+ TaggedSplitter tag' other <- splitterPrimaryParser+ return (trycast tag tag' (\one'-> TaggedSplitter tag' (Having one' other)) one))+ <|>+ try (do symbol lexer "having-only"+ TaggedSplitter tag' other <- splitterPrimaryParser+ return (trycast tag tag' (\one'-> TaggedSplitter tag' (HavingOnly one' other)) one))+ <|>+ return first)+ where tagged :: (forall x. Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x)+ -> TaggedExpression -> TaggedExpression -> TaggedExpression+ tagged combinator (TaggedSplitter tag1 s1) (TaggedSplitter tag2 s2)+ = trycast tag1 tag2 (\s1'-> TaggedSplitter tag2 (combinator s1' s2)) s1++transducerPrimaryParser :: Parser TaggedExpression+transducerPrimaryParser = try (do symbol lexer "("+ filter <- transducerExpressionParser+ symbol lexer ")"+ return filter)+ <|>+ try (do symbol lexer "id"+ return (GenericInputExpression (\tag-> TaggedTransducer tag tag (PrimitiveTransducer "id" asis))))+ <|>+ try (do symbol lexer "suppress"+ return (GenericInputExpression (\tag-> TaggedTransducer tag tag (PrimitiveTransducer "suppress" suppress))))+ <|>+ try (do symbol lexer "uppercase"+ return (TaggedTransducer CharTag CharTag (PrimitiveTransducer "uppercase" uppercase)))+ <|>+ try (do symbol lexer "count"+ return (GenericInputExpression (\tag-> TaggedTransducer tag IntTag (PrimitiveTransducer "count" count))))+ <|>+ try (do symbol lexer "show"+ return (TaggedTransducer IntTag (ListTag CharTag) (PrimitiveTransducer "show" toString)))+ <|>+ try (do symbol lexer "concatenate"+ return (GenericInputExpression $+ \tag-> case tag+ of ListTag tag'+ -> TaggedTransducer tag tag' (PrimitiveTransducer "concatenate" concatenate)+ _ -> TypeErrorExpression tag (ListTag AnyTag) "concatenate"))+ <|>+ try (do symbol lexer "group"+ return (GenericInputExpression $+ \tag-> TaggedTransducer tag (ListTag tag) (PrimitiveTransducer "group" group)))+ <|>+ try (do symbol lexer "prepend"+ prefix <- parameterParser True+ return (TaggedTransducer CharTag CharTag (PrimitiveTransducer ("prepend " ++ prefix) (prepend prefix))))+ <|>+ try (do symbol lexer "append"+ suffix <- parameterParser True+ return (TaggedTransducer CharTag CharTag (PrimitiveTransducer ("append " ++ suffix) (append suffix))))+ <|>+ try (do symbol lexer "substitute"+ replacement <- parameterParser True+ return (TaggedTransducer CharTag CharTag+ (PrimitiveTransducer ("substitute " ++ replacement) (substitute replacement))))+ <|>+ try (do symbol lexer "select"+ TaggedSplitter tag splitter <- splitterPrimaryParser+ return (TaggedTransducer tag tag (Select splitter)))+ <|>+ try (do symbol lexer "if"+ TaggedSplitter tag splitter <- splitterExpressionParser+ whiteSpace lexer+ symbol lexer "then"+ true <- transducerExpressionParser+ false <- (try (symbol lexer "else" >> transducerExpressionParser)+ <|> return (TaggedTransducer tag tag (PrimitiveTransducer "id" asis)))+ symbol lexer "end"+ option "" (symbol lexer "if")+ return (combineBranches (If splitter) tag true false))+ <|>+ try (do symbol lexer "while"+ TaggedSplitter tag splitter <- splitterExpressionParser+ whiteSpace lexer+ symbol lexer "do"+ TaggedTransducer tag' tag'' body <- transducerExpressionParser+ whiteSpace lexer+ symbol lexer "end"+ option "" (symbol lexer "while")+ return (case (typecast tag tag' splitter, typecast tag'' tag' body)+ of (Just test, Just body) -> TaggedTransducer tag' tag' (While test body)))+ <|>+ try (do symbol lexer "foreach"+ TaggedSplitter tag splitter <- splitterExpressionParser+ whiteSpace lexer+ symbol lexer "then"+ trueBranch <- transducerExpressionParser+ whiteSpace lexer+ falseBranch <- (try (symbol lexer "else" >> transducerExpressionParser)+ <|> return (TaggedTransducer tag tag (PrimitiveTransducer "id" asis)))+ whiteSpace lexer+ symbol lexer "end"+ option "" (symbol lexer "foreach")+ return (combineBranches (ForEach splitter) tag trueBranch falseBranch))+ <|>+ liftM (TaggedTransducer CharTag CharTag . NativeTransducerCommand) nativeCommand++combineBranches :: forall x. Typeable x+ => (forall y. Typeable y => TransducerExpression x y -> TransducerExpression x y -> TransducerExpression x y)+ -> TypeTag x -> TaggedExpression -> TaggedExpression -> TaggedExpression+combineBranches combinator tag b1 b2 = + case (b1, b2)+ of (TaggedTransducer tag1 tag2 true, TaggedTransducer tag1' tag2' false) ->+ case (typecast2 tag1 tag2 tag tag2 true, typecast2 tag1' tag2' tag tag2 false)+ of (Just true', Just false') -> TaggedTransducer tag tag2 (combinator true' false')+ (Nothing, _) -> TypeErrorExpression tag1 tag (show true)+ (_, Nothing) -> TypeErrorExpression tag2' tag2 (show true)+ (GenericInputExpression ge, _) -> combineBranches combinator tag (ge tag) b2+ (_, GenericInputExpression ge) -> combineBranches combinator tag b1 (ge tag)+ (TypeErrorExpression{}, _) -> b1+ (_, TypeErrorExpression{}) -> b2++splitterPrimaryParser :: Parser TaggedExpression+splitterPrimaryParser = try (do symbol lexer "("+ splitter <- splitterExpressionParser+ symbol lexer ")"+ return splitter)+ <|>+ try (do symbol lexer ">!"+ TaggedSplitter tag splitter <- splitterPrimaryParser+ return (TaggedSplitter tag (Not splitter)))+ <|>+ try (do symbol lexer "prefix"+ TaggedSplitter tag splitter <- splitterPrimaryParser+ return (TaggedSplitter tag (Prefix splitter)))+ <|>+ try (do symbol lexer "suffix"+ TaggedSplitter tag splitter <- splitterPrimaryParser+ return (TaggedSplitter tag (Suffix splitter)))+ <|>+ try (do symbol lexer "first"+ TaggedSplitter tag splitter <- splitterPrimaryParser+ return (TaggedSplitter tag (First splitter)))+ <|>+ try (do symbol lexer "last"+ TaggedSplitter tag splitter <- splitterPrimaryParser+ return (TaggedSplitter tag (Last splitter)))+ <|>+ try (do symbol lexer "whitespace"+ return (TaggedSplitter CharTag (PrimitiveSplitter "whitespace" whitespace)))+ <|>+ try (do symbol lexer "line"+ return (TaggedSplitter CharTag (PrimitiveSplitter "line" line)))+ <|>+ try (do symbol lexer "letters"+ return (TaggedSplitter CharTag (PrimitiveSplitter "letters" letters)))+ <|>+ try (do symbol lexer "digits"+ return (TaggedSplitter CharTag (PrimitiveSplitter "digits" digits)))+ <|>+ try (do symbol lexer "substring"+ part <- parameterParser True+ return (TaggedSplitter CharTag (PrimitiveSplitter ("substring " ++ part) (substring part))))+ <|>+ do symbol lexer "nested"+ TaggedSplitter tag1 core <- splitterExpressionParser+ whiteSpace lexer+ symbol lexer "in"+ TaggedSplitter tag2 shell <- splitterExpressionParser+ whiteSpace lexer+ symbol lexer "end"+ option "" (symbol lexer "nested")+ return (trycast tag1 tag2 (\core'-> TaggedSplitter tag2 (Nested core' shell)) core)+ <|>+ do symbol lexer "between"+ TaggedSplitter tag1 left <- splitterExpressionParser+ whiteSpace lexer+ symbol lexer "and"+ TaggedSplitter tag2 right <- splitterExpressionParser+ whiteSpace lexer+ symbol lexer "end"+ option "" (symbol lexer "between")+ return (trycast tag1 tag2 (\left'-> TaggedSplitter tag2 (Between left' right)) left)++nativeCommand :: Parser String+nativeCommand = do parts <- many (try (lexeme lexer (parameterParser False)))+ return (concat (intersperse " " parts))++parameterParser :: Bool -> Parser String+parameterParser normalize = do chars <- many (noneOf " \t\n'\"`\\()[]{}<>|&")+ (do try (string "\\n")+ rest <- (parameterParser normalize <|> return "")+ return (chars ++ '\n' : rest)+ <|>+ do try (string "\\t")+ rest <- (parameterParser normalize <|> return "")+ return (chars ++ '\t' : rest)+ <|>+ do next <- escape+ rest <- (parameterParser normalize <|> return "")+ return (chars ++ next : rest)+ <|>+ do quote <- oneOf "'\"`"+ string <- many (noneOf (quote : "\\") <|> escape)+ char quote+ rest <- (parameterParser normalize <|> return "")+ return (chars ++ (if normalize then string else quote : (string ++ [quote])) ++ rest)+ <|>+ do try (char '(')+ whiteSpace lexer+ inside <- nativeCommand+ char ')'+ rest <- (parameterParser normalize <|> return "")+ return (chars ++ '(' : inside ++ ')' : rest)+ <|>+ do try (char '[')+ whiteSpace lexer+ inside <- nativeCommand+ char ']'+ rest <- parameterParser normalize+ return (chars ++ '[' : inside ++ ']' : rest)+ <|>+ do try (char '{')+ whiteSpace lexer+ inside <- nativeCommand+ char '}'+ rest <- (parameterParser normalize <|> return "")+ return (chars ++ '{' : inside ++ '}' : rest)+ <|>+ do when (null chars) pzero+ return chars)++escape :: Parser Char+escape = do char '\\'+ escaped <- anyChar+ return (case escaped of 'n' -> '\n'+ 'r' -> '\r'+ 't' -> '\t'+ _ -> escaped)++stringLexemeParser :: Parser String+stringLexemeParser = do terminator <- oneOf "'\"`"+ content <- many (try (noneOf ['\\', terminator]+ <|> (string "\\t" >> return '\t')+ <|> (string "\\n" >> return '\n')+ <|> (char '\\' >> anyChar)))+ char terminator+ return (terminator : (content ++ [terminator]))
+ Test.hs view
@@ -0,0 +1,387 @@+{- + Copyright 2008 Mario Blazevic++ This file is part of the Streaming Component Combinators (SCC) project.++ The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public+ License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later+ version.++ SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty+ of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.++ You should have received a copy of the GNU General Public License along with SCC. If not, see+ <http://www.gnu.org/licenses/>.+-}++{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, ScopedTypeVariables, PatternSignatures #-}++module Test where++import Control.Concurrent.SCC.Foundation+import Control.Concurrent.SCC.ComponentTypes+import Control.Concurrent.SCC.Components+import Control.Concurrent.SCC.Combinators hiding ((&&), (||))+import qualified Control.Concurrent.SCC.Combinators as Combinators++import Control.Monad (liftM)+import Data.Char (ord, isLetter, isSpace, toUpper)+import Data.Dynamic (Typeable)+import Data.List (find, stripPrefix, groupBy, intersect, union, intercalate, isInfixOf, isPrefixOf, isSuffixOf, sort)+import Data.Maybe (fromJust)+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 Debug.Trace (trace)+import Prelude hiding (even, last)+import qualified Prelude+import Test.QuickCheck (Arbitrary, Property,+ arbitrary, coarbitrary, label, choose, oneof, sized, quickCheck, trivial, variant, (==>))+++sublists [] _ = []+sublists _ [] = []+sublists sublist input = case stripPrefix sublist input+ of Just rest -> sublist ++ sublists sublist rest+ Nothing -> sublists sublist (tail input)++main = mapM_ quickCheck tests++tests = [label "pipe" $ \(input :: [Int])-> runPipes (pipe (putList input) getList) == Just ([], input),+ label "pour" prop_pour,+ label "asis" prop_asis,+ label "suppress" prop_suppress,+ label "substitute" prop_substitute,+ label "prepend" prop_prepend,+ label "append" prop_append,+ label "allTrue" prop_allTrue,+ label "allFalse" 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 `join` asis" $ \s-> transducerOutput (uppercase `join` asis) s == map toUpper s ++ s,+ label "prepend >-> append" $ \s-> transducerOutput (prepend "Hello, " >-> append "!") s == "Hello, "++ 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 "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+ == map (\x-> if x == c then toUpper x else x) s,+ 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,+ 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)" $+ \s1 s2-> not (null s1) && length s1 < length s2 ==> trivial (not (s1 `isInfixOf` s2)) $+ transducerOutput (uppercase `wherever` (snot whitespace `having` substring s1)) s2+ == mapWords (\w-> if s1 `isInfixOf` w then map toUpper w else w) s2,+ label "(uppercase `wherever` (snot whitespace `havingOnly` letters))" $+ \s-> transducerOutput (uppercase `wherever` (snot whitespace `havingOnly` letters)) s+ == mapWords (\w-> if all isLetter w then map toUpper w else w) s,++ label "select $ substring" $ transducerOutput (select $ substring "o, ") "Hello, World!" == "o, ",++ label "(uppercase `wherever` (first letters))"+ (transducerOutput (uppercase `wherever` (first letters)) "... Hello, World !" == "... HELLO, World !"+ && transducerOutput (uppercase `wherever` (first letters)) "Hello, World !" == "HELLO, World !"),+ label "(uppercase `wherever` (prefix letters))"+ (transducerOutput (wherever uppercase (prefix letters)) "... Hello, World !" == "... Hello, World !"+ && transducerOutput (uppercase `wherever` (prefix letters)) "Hello, World !" == "HELLO, World !"),+ label "(uppercase `wherever` (suffix letters))"+ (transducerOutput (uppercase `wherever` (suffix letters)) "Hello, World!" == "Hello, World!"+ && transducerOutput (uppercase `wherever` (suffix letters)) "Hello, World" == "Hello, WORLD"),+ label "(uppercase `wherever` (last letters))"+ (transducerOutput (uppercase `wherever` (last letters)) "Hello, World!" == "Hello, WORLD!"+ && transducerOutput (uppercase `wherever` (last letters)) "Hello, World" == "Hello, WORLD"),++ label "(select (prefix letters))" (transducerOutput (select (prefix letters)) "Hello, World!" == "Hello"),+ label "(foreach letters (count >-> toString >-> concatenate) asis)"+ (transducerOutput (foreach letters (count >-> toString >-> concatenate) asis) "Hola, Mundo!" == "4, 5!"),+ label "(foreach (letters `having` prefix (substring \"H\")) uppercase asis)"+ (transducerOutput (foreach (letters `having` prefix (substring "H")) uppercase asis) "Hello, World! Hola, Mundo!"+ == "HELLO, World! HOLA, Mundo!"),+ label "(foreach (letters `having` suffix (substring \"o\")) uppercase asis)"+ (transducerOutput (foreach (letters `having` suffix (substring "o")) uppercase asis) "Hello, World! Hola, Mundo!"+ == "HELLO, World! Hola, MUNDO!"),++ label "first one" $ \s-> splitterOutputs (first one) s == if null s then ("", "") else ([head s], tail s),+ label "last one" $ \s-> splitterOutputs (last one) s == if null s then ("", "") else ([List.last s], init s),+ label "prefix one" $ \s-> splitterOutputs (prefix one) s == if null s then ("", "") else ([head s], tail s),+ label "suffix one" $ \s-> splitterOutputs (suffix one) s == if null s then ("", "") else ([List.last s], init s),+ label "uptoFirst one" $ \s-> splitterOutputs (uptoFirst one) s == if null s then ("", "") else ([head s], tail s),+ label "lastAndAfter one" $ \s-> splitterOutputs (lastAndAfter one) s == if null s then ("", "")+ else ([List.last s], init s),++ label "snot" $ prop_snot . splitterFromTrace,+ label "DeMorgan 1" $ \trace1 trace2-> prop_DeMorgan1 (splitterFromTrace trace1) (splitterFromTrace trace2),+ label "DeMorgan 2" $ \trace1 trace2-> prop_DeMorgan2 (splitterFromTrace trace1) (splitterFromTrace trace2),+ label "&&" $ \trace1 trace2-> prop_and (splitterFromTrace trace1) (splitterFromTrace trace2),+ label "||" $ \trace1 trace2-> prop_or (splitterFromTrace trace1) (splitterFromTrace trace2),+ label "even" $ prop_even . splitterFromTrace,+ label "prefix 1" $ prop_prefix_1 . splitterFromTrace,+ label "prefix 2" $ prop_prefix_2 . splitterFromTrace,+ label "suffix 1" $ prop_suffix_1 . splitterFromTrace,+ label "suffix 2" $ prop_suffix_2 . splitterFromTrace,+ label "first" $ prop_first . splitterFromTrace,+ label "last" $ prop_last . splitterFromTrace,+ label "uptoFirst" $ prop_uptoFirst . splitterFromTrace,+ label "lastAndAfter" $ prop_lastAndAfter . splitterFromTrace,+ label "followedBy prefix" $ \trace1 trace2 n-> prop_followedBy1 (splitterFromTrace trace1) (splitterFromTrace trace2) n,+ label "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]++prop_pour :: [Int] -> Bool+prop_pour input = runPipes (pipeD "input" (putList input) (\source-> pipeD "output" (\sink-> pour source sink) getList))+ == Just ([], ((), input))++prop_asis :: [Int] -> Bool+prop_asis input = transducerOutput asis input == input++prop_suppress :: [Int] -> Bool+prop_suppress input = null (transducerOutput (suppress :: Transducer Maybe Int ()) input)++prop_substitute :: [Int] -> [Maybe Int] -> Bool+prop_substitute input replacement = transducerOutput (substitute replacement) input == replacement++prop_prepend :: [Int] -> [Int] -> Bool+prop_prepend input prefix = transducerOutput (prepend prefix) input == prefix ++ input++prop_append :: [Int] -> [Int] -> Bool+prop_append input suffix = transducerOutput (append suffix) input == input ++ suffix++prop_allTrue :: [Int] -> Bool+prop_allTrue input = splitterOutputs allTrue input == (input, [])++prop_allFalse :: [Int] -> Bool+prop_allFalse input = splitterOutputs allFalse input == ([], input)++prop_substring :: [TestEnum] -> [TestEnum] -> Property+prop_substring input sublist = trivial (not (isInfixOf sublist input)) (fst (splitterOutputs (substring sublist) input)+ == sublists sublist input)++prop_group :: [Int] -> Bool+prop_group input = transducerOutput group input == [input]++prop_concatenate :: [[TestEnum]] -> Bool+prop_concatenate input = transducerOutput concatenate input == concat input++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 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+ 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+ 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_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_and :: Splitter Maybe Int -> Splitter Maybe 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 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 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)++prop_prefix_1 :: Splitter Maybe 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 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 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 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 input = let (first1, rest1) = splitterOutputs (first splitter) input+ in case splitterOutputChunks splitter input+ of (first2, True):rest2 -> first1 == first2 && rest1 == concat (map fst rest2)+ (prefix, False):(first2, True):rest2 -> first1 == first2+ && rest1 == prefix ++ concat (map fst rest2)+ (prefix, False):[] -> first1 == [] && rest1 == prefix+ [] -> first1 ++ rest1 == []++prop_last :: Splitter Maybe TestEnum -> [TestEnum] -> Bool+prop_last splitter input = let (last1, rest1) = splitterOutputs (last splitter) input+ in -- trace (show (last1, rest1)) $ trace (show (splitterOutputChunks splitter input)) $+ case reverse (splitterOutputChunks splitter input)+ of (last2, True):rest2 -> last1 == last2 && rest1 == concat (map fst (reverse rest2))+ (suffix, False):(last2, True):rest2 -> last1 == last2+ && rest1 == concat (map fst (reverse rest2)) ++ suffix+ (suffix, False):[] -> last1 == [] && rest1 == suffix+ [] -> last1 ++ rest1 == []++prop_uptoFirst :: Splitter Maybe 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)+ (prefix, False):(first2, True):rest2 -> first1 == prefix ++ first2+ && rest1 == concat (map fst rest2)+ (prefix, False):[] -> first1 == [] && rest1 == prefix+ [] -> first1 ++ rest1 == []++prop_lastAndAfter :: Splitter Maybe 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))+ (suffix, False):(last2, True):rest2 -> last1 == last2 ++ suffix+ && rest1 == concat (map fst (reverse rest2))+ (suffix, False):[] -> last1 == [] && rest1 == suffix+ [] -> last1 ++ rest1 == []++prop_followedBy1 :: Splitter Maybe Int -> Splitter Maybe 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 s1 s2 n = splitterOutputs (first (s1 `followedBy` s2)) l == splitterOutputs (first s1 `followedBy` s2) l+ where l = [1 .. abs n]++prop_followedBy3 :: [TestEnum] -> [TestEnum] -> [TestEnum] -> Property+prop_followedBy3 l1 l2 l3 = trivial (not (isInfixOf l1 l3)) (fst (splitterOutputs (substring l1 `followedBy` substring l2) l3)+ == sublists (l1 ++ l2) l3)++prop_followedBy4 :: [TestEnum] -> [TestEnum] -> [TestEnum] -> Property+prop_followedBy4 l1 l2 l3 = isInfixOf l1 l3+ ==> trivial (not (isInfixOf (l1 ++ l2) l3)) (fst (splitterOutputs (substring l1+ `followedBy` substring l2) l3)+ == sublists (l1 ++ l2) l3)++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]++transducerOutput :: (Typeable x, Typeable y) => Transducer Maybe 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++splitterOutputs :: Typeable x => Splitter Maybe x -> [x] -> ([x], [x])+splitterOutputs s input = case runPipes (pipeD "splitterOutputs input"+ (putList input)+ (\source-> pipeD "splitterOutputs true"+ (\true-> pipeD "splitterOutputs false"+ (split s source true)+ getList)+ getList))+ of Just ([], (([], false), true)) -> (true, false)++splitterOutputChunks :: Typeable x => Splitter Maybe x -> [x] -> [([x], Bool)]+splitterOutputChunks s input = transducerOutput (foreach s+ (group >-> lift121Transducer (\chunk-> (chunk, True)))+ (group >-> lift121Transducer (\chunk-> (chunk, False))))+ input++simpleSplitterFromTrace :: (Show x, Typeable x) => SimpleSplitterTrace -> Splitter Maybe x+simpleSplitterFromTrace (init, last) = splitterFromTrace (map (maybe Nothing (Just . (,) True)) init, last)++splitterFromTrace :: (Show x, Typeable x) => SplitterTrace -> Splitter Maybe x+splitterFromTrace trace1 = liftSectionSplitter $+ \source true false->+ let follow trace2@(head:tail) q = get source >>= maybe fail succeed+ where succeed x = let q' = q |> Just x+ in case head+ of Nothing -> follow tail q'+ Just (False, b) -> (if b then put true else put false) Nothing+ >>= cond+ (follow tail q')+ (return $ Foldable.toList (Seq.viewl q))+ Just (True, True) -> putList (Foldable.toList (Seq.viewl q')) true+ >>= whenNull (follow tail Seq.empty)+ Just (True, False) -> putList (Foldable.toList (Seq.viewl q')) false+ >>= whenNull (follow tail Seq.empty)+ fail = if find (maybe False fst) trace2 == Just (Just (True, True))+ then putList (Foldable.toList (Seq.viewl q)) true+ else putList (Foldable.toList (Seq.viewl q)) false+ in liftM (map fromJust) $ follow (cycle (fst trace1 ++ [Just (True, snd trace1)])) Seq.empty++swap :: (x, y) -> (y, x)+swap (x, y) = (y, x)++mapWords :: (String -> String) -> String -> String+mapWords f s = concat (map (\w@(c:_)-> if isSpace c then w else f w) (groupBy (\x y-> isSpace x == isSpace y) s))++type SimpleSplitterTrace = ([Maybe Bool], Bool)++type SplitterTrace = ([Maybe (Bool, Bool)], Bool)++data TestEnum = One | Two | Three | Four | Five deriving (Eq, Show, Typeable)++newtype LowercaseLetter = LowercaseLetter Char deriving (Eq, Show, Typeable)++instance Arbitrary TestEnum where+ arbitrary = oneof (map return [One, Two, Three, Four, Five])+ coarbitrary enum = variant (case enum of {One -> 0; Two -> 1; Three -> 2; Four -> 3; Five -> 4})++instance Arbitrary Char where+ arbitrary = choose ('\32', '\128')+ coarbitrary c = variant ((ord c - 32) `rem` 128)++instance Arbitrary LowercaseLetter where+ arbitrary = fmap LowercaseLetter (choose ('a', 'z'))+ coarbitrary (LowercaseLetter c) = variant ((ord c - 65) `rem` 26)++instance Arbitrary (Splitter Maybe Int) where+ arbitrary = fmap splitterFromTrace arbitrary+ coarbitrary s gen = sized (\n-> coarbitrary (transducerOutput (ifs s+ (lift121Transducer $ const True)+ (lift121Transducer $ const False))+ [1..n]) gen)
+ grammar.bnf view
@@ -0,0 +1,76 @@+Expression ::=+ ProducerPrimary {"|" TransducerPrimary} ["|" ConsumerPrimary].++ProducerExpression ::=+ ProducerPrimary+ | ProducerPrimary "|" TransducerExpression.++ProducerPrimary ::=+ "(" NativeCommand ")" ">"+ | "cat" Parameters+ | "echo" Parameters+ | "ls" Parameters+ | "stdin"+ | "{" [String {"," String}] "}"+ | "(" ProducerExpression ")".++ConsumerExpression ::=+ ConsumerFork+ | TransducerExpression "|" ConsumerFork.++ConsumerFork ::=+ ConsumerPrimary {"tee" ConsumerPrimary}.++ConsumerPrimary ::=+ "(" ConsumerExpression ")"+ | ">" "(" NativeCommand ")"+ | "error" [String]+ | "null"+ | ">" File+ | ">>" File.++TransducerExpression ::=+ TransducerPrimary {"|" TransducerPrimary}+ | TransducerPrimary {"><" TransducerPrimary}.++TransducerPrimary ::=+ "(" TransducerExpression ")"+ | "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+ | "whitespace"+ | "line"+ | "letters"+ | "digits"+ | "substring" String+ | "nested" SplitterExpression "in" SplitterExpression "end" ["nested"]+ | "between" SplitterExpression "and" SplitterExpression "end" ["between"].
+ scc.cabal view
@@ -0,0 +1,33 @@+Name: scc+Version: 0.1+Cabal-Version: >= 1.2+Build-Type: Simple+Synopsis: Streaming component combinators+Category: Control, Combinators+Description:+ SCC is a layered library of Streaming Component Combinators. The lowest layer defines a Pipe monad transformer that+ enables building of producer-consumer coroutine pairs. The next layer adds streaming component+ types, a number of primitive streaming components and a set of component combinators. Finally,+ there is an executable that exposes all functionality in a command-line shell.+ .+ The library design is based on paper <http://www.idealliance.org/papers/extreme/Proceedings/html/2006/Blazevic01/EML2006Blazevic01.html>+ .+ Mario Blažević, Streaming component combinators, Extreme Markup Languages, 2006.+ +License: GPL+License-file: LICENSE.txt+Copyright: (c) 2008 Mario Blazevic+Author: Mario Blazevic+Maintainer: blamario@yahoo.com+Extra-source-files: grammar.bnf Makefile LICENSE.txt Test.hs++Executable shsh+ 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++Library+ Exposed-Modules: Control.Concurrent.SCC.Foundation, Control.Concurrent.SCC.ComponentTypes,+ Control.Concurrent.SCC.Components, Control.Concurrent.SCC.Combinators+ Build-Depends: base, containers