scc 0.6.1 → 0.7

raw patch · 10 files changed

+982/−971 lines, 10 filesdep +QuickCheckdep +incremental-parserdep ~monad-coroutinenew-component:exe:test-sccPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, incremental-parser

Dependency ranges changed: monad-coroutine

API changes (from Hackage documentation)

Files

• Control/Concurrent/SCC/Combinators.hs +23/−3
• Control/Concurrent/SCC/Primitives.hs +66/−91
• Control/Concurrent/SCC/Streams.hs +64/−53
• Control/Concurrent/SCC/XML.hs +156/−176
• Makefile +14/−10
• Shell.hs +3/−2
• Test.hs +0/−628
• Test/TestSCC.hs +631/−0
• grammar.bnf +1/−0
• scc.cabal +24/−8

@@ -66,7 +66,7 @@    -- ** positional splitters    startOf, endOf, between,    -- * Parser support-   splitterToMarker, parseRegions, parseNestedRegions, parseEachNestedRegion,+   splitterToMarker, parserToSplitter, parseRegions, parseNestedRegions, parseEachNestedRegion,    -- * Helper functions    groupMarks, findsTrueIn, findsFalseIn, teeConsumers    )@@ -801,6 +801,26 @@                         (mapSink (\x-> Left (x, False)) sink)                         (mapSink Right sink) +parserToSplitter :: forall m x b. Monad m => Parser m x b -> Splitter m x (Boundary b)+parserToSplitter t = isolateSplitter $ \ source true false edge ->+                     pipe+                        (transduce t source)+                        (\source-> let true' = mapSink fromContent true+                                       false' = mapSink fromContent false+                                       topLevel = pourUntil isMarkup source false'+                                                  >>= maybe (return ()) (\x-> handleMarkup x >> topLevel)+                                       handleMarkup (Markup p@Point{}) = put edge p >> return True+                                       handleMarkup (Markup s@Start{}) = put edge s >> handleRegion >> return True+                                       handleMarkup (Markup e@End{}) = put edge e >> return False+                                       handleRegion = pourUntil isMarkup source true'+                                                      >>= maybe (return ()) (\x -> handleMarkup x +                                                                                   >>= flip when handleRegion)+                                   in topLevel)+                        >> return ()+   where isMarkup Markup{} = True+         isMarkup Content{} = False+         fromContent (Content x) = x+ splittersToPairMarker :: forall m x b1 b2. Monad m => PairBinder m -> Splitter m x b1 -> Splitter m x b2 ->                          Transducer m x (Either (x, Bool, Bool) (Either b1 b2)) splittersToPairMarker binder s1 s2 =@@ -898,11 +918,11 @@  teeConsumers :: forall m a d x r1 r2. Monad m =>                  PairBinder m -                -> (forall a'. OpenConsumer m a' (SinkFunctor d x) x r1)+                -> (forall a'. OpenConsumer m a' (SourceFunctor (SinkFunctor d x) x) x r1)                 -> (forall a'. OpenConsumer m a' (SourceFunctor d x) x r2)                 -> OpenConsumer m a d x (r1, r2) teeConsumers binder c1 c2 source = pipeG binder consume1 c2-   where consume1 sink = c1 (teeSource sink source' :: Source m (SinkFunctor d x) x)+   where consume1 sink = liftM snd $ pipe (tee source' sink) c1          source' :: Source m d x          source' = liftSource source 

@@ -1,5 +1,5 @@ {- -    Copyright 2008-2010 Mario Blazevic+    Copyright 2008-2011 Mario Blazevic      This file is part of the Streaming Component Combinators (SCC) project. @@ -48,24 +48,25 @@  import Prelude hiding (appendFile, head, tail) +import Control.Applicative (Alternative ((<|>))) import Control.Exception (assert)-import Control.Monad (liftM, when, unless)+import Control.Monad (forM_, unless, when) import Control.Monad.Trans.Class (lift) import Data.ByteString (ByteString) import Data.Char (isAlpha, isDigit, isSpace, toLower, toUpper) import Data.List (delete, stripPrefix) import qualified Data.ByteString as ByteString import qualified Data.Foldable as Foldable-import qualified Data.Sequence as Seq-import Data.Sequence (Seq, (|>), (><), ViewL (EmptyL, (:<))) import System.IO (Handle, IOMode (ReadMode, WriteMode, AppendMode),                    openFile, hClose, hGetLine, hPutStr, hIsEOF, hClose, isEOF) -import Control.Cofunctor.Ticker (tickPrefixOf)+import Text.ParserCombinators.Incremental (string, takeWhile, (<<|>))  import Control.Concurrent.SCC.Streams import Control.Concurrent.SCC.Types +import Debug.Trace (trace)+ -- | Collects the entire input source into a list. toList :: forall m x. Monad m => Consumer m x [x] toList = Consumer getList@@ -80,7 +81,7 @@  -- | Producer 'fromStdIn' feeds the given sink from the standard input. fromStdIn :: Producer IO Char ()-fromStdIn = Producer (unmapMStreamChunks_ (lift $ isEOF >>= cond (return []) (liftM (++ "\n") getLine)))+fromStdIn = Producer (unmapMStreamChunks_ (lift $ isEOF >>= cond (return []) (fmap (++ "\n") getLine)))  -- | Reads the named file and feeds the given sink from its contents. fromFile :: String -> Producer IO Char ()@@ -91,7 +92,7 @@ -- | Feeds the given sink from the open text file /handle/. fromHandle :: Handle -> Producer IO Char () fromHandle handle = Producer (unmapMStreamChunks_-                                 (lift $ hIsEOF handle >>= cond (return []) (liftM (++ "\n") $ hGetLine handle)))+                                 (lift $ hIsEOF handle >>= cond (return []) (fmap (++ "\n") $ hGetLine handle)))  -- | Feeds the given sink from the open binary file /handle/. The argument /chunkSize/ determines the size of the chunks -- read from the handle.@@ -188,15 +189,12 @@ -- line-end can be formed by any of the character sequences \"\\n\", \"\\r\", \"\\r\\n\", or \"\\n\\r\". line :: forall m. Monad m => Splitter m Char () line = Splitter $ \source true false boundaries->-       let loop = peek source >>= maybe (return ()) (( >> loop) . lineChar)-           lineChar c = put boundaries ()-                        >> if c == '\r' || c == '\n' -                           then lineEnd c -                           else pourUntil (\x-> x == '\n' || x == '\r') source true -                                >>= maybe (return ()) lineEnd-           lineEnd '\n' = pourTicked (tickPrefixOf "\n\r") source false-           lineEnd '\r' = pourTicked (tickPrefixOf "\r\n") source false-           lineEnd _ = error "Newline characters only please!"+       let loop = peek source >>= maybe (return ()) (( >> loop) . splitLine)+           lineChar c = c /= '\r' && c /= '\n'+           lineEndParser = string "\r\n" <<|> string "\n\r" <<|> string "\r" <<|> string "\n"+           splitLine c = put boundaries ()+                         >> when (lineChar c) (pourWhile lineChar source true)+                         >> pourTicked lineEndParser source false        in loop  -- | Splitter 'everything' feeds its entire input into its /true/ sink.@@ -216,7 +214,7 @@ marked :: forall m x y. (Monad m, Eq y) => Splitter m (Markup y x) () marked = markedWith (const True) --- | Splitter 'markedContent' passes the content of all marked-up input sections to its /true/ sink, while the+-- | Splitter 'markedContent' passes the content of all marked-up input sections to its /true/ sink, takeWhile the -- outermost tags and all unmarked input go to its /false/ sink. markedContent :: forall m x y. (Monad m, Eq y) => Splitter m (Markup y x) () markedContent = contentMarkedWith (const True)@@ -258,51 +256,37 @@ -- | Performs the same task as the 'substring' splitter, but instead of splitting it outputs the input as @'Markup' x -- 'OccurenceTag'@ in order to distinguish overlapping strings. parseSubstring :: forall m x. (Monad m, Eq x) => [x] -> Parser m x OccurenceTag-parseSubstring [] = Transducer $ \ source sink ->-                    put sink marker >> mapMStream_ (\x-> put sink (Content x) >> put sink marker) source+parseSubstring [] = Transducer $ +                    \ source sink -> put sink marker >> concatMapStream (\x-> [Content x, marker]) source sink    where marker = Markup (Point (toEnum 1))-parseSubstring list@(first:_)+parseSubstring list@(first:rest)    = Transducer $      \ source sink ->-        let findFirst = pourUntil (== first) source (mapSink Content sink)-                        >>= maybe (return ()) (const test)-            test = getTicked (tickPrefixOf list) source-                   >>= \prefix-> let Just rest = stripPrefix prefix list-                                     head:tail = map Content list-                                 in if null rest-                                    then put sink (Markup (Start (toEnum 0))) -                                         >> put sink head -                                         >> fallback 0 (Seq.fromList tail |> Markup (End (toEnum 0)))-                                    else getNext 0 rest (Seq.fromList $ map Content prefix)-            getNext i rest q = get source-                               >>= maybe (flush q) (advance i rest q)-            advance _ [] _ _ = error "Can't advance on an empty list!"-            advance i (head:tail) q x = let q' = q |> Content x-                                            qh@Content{} :< qt = Seq.viewl q'-                                            i' = succ i-                                        in if x == head-                                           then if null tail-                                                then put sink (Markup (Start (toEnum i')))-                                                     >> put sink qh-                                                     >> (fallback i' (qt |> Markup (End (toEnum i'))))-                                                else getNext i tail q'-                                           else fallback i q'-            fallback i q = case Seq.viewl q-                           of EmptyL -> findFirst-                              head@(Markup (End i')) :< tail -> put sink head-                                                                >> fallback-                                                                      (if i == fromEnum i' then 0 else i)-                                                                      tail-                              head@Content{} :< tail -> case stripPrefix (remainingContent q) list-                                                        of Just rest -> getNext i rest q-                                                           Nothing -> put sink head-                                                                      >> fallback i tail-                              _ -> error "Only content and ends can be fallen back on!"-            flush q = putQueue q sink >> return ()-            remainingContent :: Seq (Markup OccurenceTag x) -> [x]-            remainingContent q = extractContent (Seq.viewl q)-            extractContent :: Foldable.Foldable f => f (Markup b x) -> [x]-            extractContent = Foldable.concatMap (\e-> case e of {Content x -> [x]; _ -> []})+        let findFirst = pourWhile (/= first) source (mapSink Content sink)+                        >> test+            test = getTicked (string list) source+                   >>= \s-> case s+                            of [] -> get source >>= maybe (return ()) (\x-> put sink (Content x) >> findFirst)+                               _ -> put sink (Markup (Start (toEnum 0)))+                                    >> putList prefixContent sink+                                    >> if null shared then put sink (Markup (End (toEnum 0))) >> findFirst+                                       else testOverlap 0+            testOverlap n = getTicked (string postfix) source+                            >>= \s-> case s+                                     of [] -> forM_ [n - maxOverlaps + 1 .. n]+                                                    (\i-> putList sharedContent sink+                                                          >> put sink (Markup (End (toEnum i))))+                                              >> findFirst+                                        _ -> let n' = succ n+                                             in put sink (Markup (Start (toEnum n')))+                                                >> putList prefixContent sink+                                                >> when (n' >= maxOverlaps) +                                                        (put sink (Markup (End (toEnum (n' - maxOverlaps)))))+                                                >> testOverlap n'+            (prefix, shared, postfix) = overlap list list+            maxOverlaps = (length list - 1) `div` length prefix+            prefixContent = map Content prefix+            sharedContent = map Content shared         in findFirst  -- | Splitter 'substring' feeds to its /true/ sink all input parts that match the contents of the given list@@ -310,41 +294,32 @@ -- by an edge. substring :: forall m x. (Monad m, Eq x) => [x] -> Splitter m x () substring [] = Splitter $ \ source true false edge -> split one source false true edge >> put edge ()-substring list@(first:_)+substring list@(first:rest)    = Splitter $      \ source true false edge ->-        let findFirst = pourUntil (== first) source false-                        >>= maybe (return ()) (const test)-            test = getTicked (tickPrefixOf list) source-                   >>= \prefix-> let Just rest = stripPrefix prefix list-                                     head:tail = list-                                 in if null rest-                                    then put edge () >> put true head >> fallback (Seq.fromList tail) Seq.empty-                                    else getNext rest Seq.empty (Seq.fromList prefix)-            getNext rest qt qf = get source-                                 >>= maybe-                                        (putQueue qt true >> putQueue qf false >> return ())-                                        (advance rest qt qf)-            advance [] _ _ _ = error "Can't advance on an empty list!"-            advance (head:tail) qt qf x = let qf' = qf |> x-                                              qqh :< qqt = Seq.viewl (qt >< qf')-                                          in if x == head-                                             then if null tail-                                                  then put edge ()-                                                       >> put true qqh-                                                       >> fallback qqt Seq.empty-                                                  else getNext tail qt qf'-                                             else fallback qt qf'-            fallback qt qf = case Seq.viewl (qt >< qf)-                             of EmptyL -> findFirst-                                view@(head :< tail) -> case stripPrefix (Foldable.toList view) list-                                                       of Just rest -> getNext rest qt qf-                                                          Nothing -> if Seq.null qt-                                                                     then put false head-                                                                          >> fallback Seq.empty tail-                                                                     else put true head-                                                                          >> fallback (Seq.drop 1 qt) qf+        let findFirst = pourWhile (/= first) source false+                        >> test+            test = getTicked (string list) source+                   >>= \s-> case s+                            of [] -> get source >>= maybe (return ()) (\x-> put false x >> findFirst)+                               _ -> put edge ()+                                    >> putList prefix true+                                    >> if null shared then findFirst else testOverlap+            testOverlap = getTicked (string postfix) source+                          >>= \s-> case s+                                   of [] -> putList shared true >> findFirst+                                      _ -> put edge ()+                                           >> putList prefix true +                                           >> testOverlap+            (prefix, shared, postfix) = overlap list list         in findFirst++overlap :: Eq x => [x] -> [x] -> ([x], [x], [x])+overlap [] s = ([], [], s)+overlap (head:tail) s2 = case stripPrefix tail s2+                         of Just rest -> ([head], tail, rest)+                            Nothing -> let (o1, o2, o3) = overlap tail s2+                                       in (head:o1, o2, o3)  -- | A utility function wrapping if-then-else, useful for handling monadic truth values cond :: a -> a -> Bool -> a

@@ -1,5 +1,5 @@ {- -    Copyright 2010 Mario Blazevic+    Copyright 2010-2011 Mario Blazevic      This file is part of the Streaming Component Combinators (SCC) project. @@ -58,10 +58,10 @@     liftSink, liftSource,     -- ** Bulk operations     -- *** Fetching and moving data-    pour, tee, teeSink, teeSource,+    pour, tee, teeSink,     getList, putList, putQueue,     getTicked, getWhile, getUntil, -    pourTicked, pourWhile, pourUntil,+    pourTicked, pourParsed, pourWhile, pourUntil,     -- *** Stream transformations     mapSink, mapStream,     mapMaybeStream, concatMapStream,@@ -72,22 +72,26 @@     zipWithMStream, parZipWithMStream,    ) where++import Prelude hiding (takeWhile)    import qualified Control.Monad- import Control.Monad (liftM, when, unless, foldM) import Data.Foldable (toList)+import Data.Monoid (Monoid, mempty, First(First, getFirst))+import Data.Monoid.Null (MonoidNull) import Data.Maybe (mapMaybe) import Data.List (mapAccumL) import Data.Sequence (Seq, viewl)+import Text.ParserCombinators.Incremental -import Control.Cofunctor.Ticker import Control.Monad.Parallel (MonadParallel(..)) import Control.Monad.Coroutine-import Control.Monad.Coroutine.SuspensionFunctors (EitherFunctor(..), Request, request, liftedLazyTickerRequestResolver)+import Control.Monad.Coroutine.SuspensionFunctors (EitherFunctor(..), Request, request, ParseRequest, requestParse,+                                                   nestedLazyParserRequestResolver) import Control.Monad.Coroutine.Nested (AncestorFunctor(..), liftAncestor, seesawNested) -type SourceFunctor a x = EitherFunctor a (Request (Ticker x) ([x], Either x (Ticker x)))+type SourceFunctor a x = EitherFunctor a (ParseRequest x) type SinkFunctor a x = EitherFunctor a (Request [x] [x])  -- | A 'Sink' can be used to yield values from any nested `Coroutine` computation whose functor provably descends from@@ -111,7 +115,8 @@    -- keep being called until it returns @False@ or the current chunk gets completely consumed. If the current chunk is    -- empty on call, a new one is obtained from the source. The intervening 'Coroutine' computations suspend all the way    -- to the 'pipe' function invocation that created the source.-   foldChunk :: forall d. AncestorFunctor a d => Ticker x -> Coroutine d m ([x], Either x (Ticker x))+   foldChunk :: forall d y. (AncestorFunctor a d, MonoidNull y) => +                Parser [x] y -> Coroutine d m (y, Maybe (Parser [x] y))    }  -- | A disconnected sink that ignores all values 'put' into it.@@ -120,7 +125,7 @@  -- | An empty source whose 'get' always returns Nothing. nullSource :: forall m a x. Monad m => Source m a x-nullSource = Source{foldChunk= \t-> return ([], Right t)}+nullSource = Source{foldChunk= \p-> return (mempty, Just p)}  -- | Converts a 'Sink' on the ancestor functor /a/ into a sink on the descendant functor /d/. liftSink :: forall m a d x. (Monad m, AncestorFunctor a d) => Sink m a x -> Sink m d x@@ -128,7 +133,9 @@  -- | Converts a 'Source' on the ancestor functor /a/ into a source on the descendant functor /d/. liftSource :: forall m a d x. (Monad m, AncestorFunctor a d) => Source m a x -> Source m d x-liftSource s = Source {foldChunk= liftAncestor . (foldChunk s :: Ticker x -> Coroutine d m ([x], Either x (Ticker x)))}+liftSource s = Source {foldChunk= liftAncestor . (foldChunk s +                                                  :: forall y. MonoidNull y => +                                                     Parser [x] y -> Coroutine d m (y, Maybe (Parser [x] y)))}  -- | 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@@ -138,7 +145,8 @@ pipe = pipeG sequentialBinder  -- | The 'pipeP' function is equivalent to 'pipe', except it runs the /producer/ and the /consumer/ in parallel.-pipeP :: forall m a a1 a2 x r1 r2. (MonadParallel m, Functor a, a1 ~ SinkFunctor a x, a2 ~ SourceFunctor a x) =>+pipeP :: forall m a a1 a2 x r1 r2. +         (MonadParallel m, Functor a, a1 ~ SinkFunctor a x, a2 ~ SourceFunctor a x) =>          (Sink m a1 x -> Coroutine a1 m r1) -> (Source m a2 x -> Coroutine a2 m r2) -> Coroutine a m (r1, r2) pipeP = pipeG bindM2 @@ -148,42 +156,47 @@       -> Coroutine a m (r1, r2) pipeG run2 producer consumer =    liftM (uncurry (flip (,))) $ -   seesawNested run2 (liftedLazyTickerRequestResolver RightF) (consumer source) (producer sink)-   where sink = Sink {putChunk= \xs-> if null xs then return [] +   seesawNested run2 (nestedLazyParserRequestResolver) (consumer source) (producer sink)+   where sink = Sink {putChunk= \xs-> if null xs then return []                                       else (liftAncestor (mapSuspension RightF (request xs) :: Coroutine a1 m [x]))}-         source = Source {foldChunk= \t-> liftAncestor (mapSuspension RightF (request t) -                                                        :: Coroutine a2 m ([x], Either x (Ticker x)))}+         source = Source {foldChunk= fc}+         fc :: forall d y. (AncestorFunctor a2 d, MonoidNull y) => +               Parser [x] y -> Coroutine d m (y, Maybe (Parser [x] y))+         fc t = liftAncestor (mapSuspension RightF (requestParse t) :: Coroutine a2 m (y, Maybe (Parser [x] y)))  -- | Function 'get' tries to get a value from the given 'Source' argument. The intervening 'Coroutine' computations -- suspend all the way to the 'pipe' function invocation that created the source. The function returns 'Nothing' if -- the argument source is empty. get :: forall m a d x. (Monad m, AncestorFunctor a d) => Source m a x -> Coroutine d m (Maybe x)-get source = foldChunk source tickOne-             >>= return . nullOrElse Nothing (Just . head) . fst+get source = foldChunk source anyToken+             >>= \(r, _) -> return $ case r of [] -> Nothing+                                               ~[x] -> Just x  -- | Function 'peek' acts the same way as 'get', but doesn't actually consume the value from the source; sequential -- calls to 'peek' will always return the same value. peek :: forall m a d x. (Monad m, AncestorFunctor a d) => Source m a x -> Coroutine d m (Maybe x)-peek source = foldChunk source tickNone >>= return . either Just (const Nothing) . snd+peek source = foldChunk source (lookAhead anyToken)+             >>= \(r, _) -> return $ case r of [] -> Nothing+                                               ~[x] -> Just x  -- | 'getList' returns the list of all values generated by the source. getList :: forall m a d x. (Monad m, AncestorFunctor a d) => Source m a x -> Coroutine d m [x]-getList = getTicked tickAll+getList = getTicked acceptAll  -- | Invokes its first argument with the value it gets from the source, if there is any to get. getWith :: forall m a d x. (Monad m, AncestorFunctor a d) => (x -> Coroutine d m ()) -> Source m a x -> Coroutine d m () getWith consumer source = get source >>= maybe (return ()) consumer --- | Consumes values from the /source/ as long as the /ticker/ accepts them.-getTicked :: forall m a d x. (Monad m, AncestorFunctor a d) => Ticker x -> Source m a x -> Coroutine d m [x]-getTicked ticker source = loop return ticker-   where loop cont t = foldChunk source t-                       >>= \(chunk, result)-> if null chunk then cont chunk-                                              else either (const $ cont chunk) (loop (cont . (chunk ++))) result+-- | Consumes values from the /source/ as long as the /parser/ accepts them.+getTicked :: forall m a d x. (Monad m, AncestorFunctor a d) => Parser [x] [x] -> Source m a x -> Coroutine d m [x]+getTicked parser source = loop return parser+   where loop cont p = foldChunk source p >>= proceed cont+         proceed cont (chunk, Nothing) = cont chunk+         proceed cont (chunk, Just p') = loop (cont . (chunk ++)) p'  -- | Consumes values from the /source/ as long as each satisfies the predicate, then returns their list. getWhile :: forall m a d x. (Monad m, AncestorFunctor a d) => (x -> Bool) -> Source m a x -> Coroutine d m [x]-getWhile predicate = getTicked (tickWhile predicate)+getWhile predicate = getTicked (takeWhile (predicate . head))  -- | Consumes values from the /source/ until one of them satisfies the predicate or the source is emptied, then returns -- the pair of the list of preceding values and maybe the one value that satisfied the predicate. The latter is not@@ -191,10 +204,12 @@ getUntil :: forall m a d x. (Monad m, AncestorFunctor a d) =>              (x -> Bool) -> Source m a x -> Coroutine d m ([x], Maybe x) getUntil f source = loop id-   where loop cont = foldChunk source (tickUntil f)-                     >>= \(chunk, result)->-                         if null chunk then return (cont chunk, either Just (const Nothing) result)-                         else either (\x-> return (cont chunk, Just x)) (const $ loop (cont . (chunk ++))) result+   where loop cont = foldChunk source (takeWhile (not . f . head) +                                       `andThen` lookAhead (fmap (First . Just . head) anyToken +                                                            <<|> return (First Nothing)))+                     >>= extract cont+         extract cont ((chunk, First mx), Nothing) = return (cont chunk, mx)+         extract cont ((chunk, First Nothing), Just{}) = loop (cont . (chunk ++))  -- | Copies all data from the /source/ argument into the /sink/ argument. pour :: forall m a1 a2 d x . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)@@ -204,24 +219,34 @@  -- | Like 'pour', copies data from the /source/ to the /sink/, but only as long as it satisfies the predicate. pourTicked :: forall m a1 a2 d x . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)-              => Ticker x -> Source m a1 x -> Sink m a2 x -> Coroutine d m ()-pourTicked ticker source sink = loop ticker-   where loop t = foldChunk source t-                  >>= \(chunk, next)-> unless (null chunk) (putChunk sink chunk >> either (const $ return ()) loop next)+              => Parser [x] [x] -> Source m a1 x -> Sink m a2 x -> Coroutine d m ()+pourTicked parser source sink = loop parser+   where loop p = foldChunk source p+                  >>= \(chunk, p')-> unless (null chunk) (putChunk sink chunk >> maybe (return ()) loop p') +-- | Parses the input data using the given parser and copies the results to output.+pourParsed :: forall m a1 a2 d x y. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)+              => Parser [x] [y] -> Source m a1 x -> Sink m a2 y -> Coroutine d m ()+pourParsed parser source sink = loop parser+   where loop p = foldChunk source p+                  >>= \(chunk, p')-> unless (null chunk) (putChunk sink chunk >> maybe (return ()) loop p')+ -- | Like 'pour', copies data from the /source/ to the /sink/, but only as long as it satisfies the predicate. pourWhile :: forall m a1 a2 d x . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)              => (x -> Bool) -> Source m a1 x -> Sink m a2 x -> Coroutine d m ()-pourWhile f = pourTicked (tickWhile f)+pourWhile f = pourTicked (takeWhile (f . head))  -- | Like 'pour', copies data from the /source/ to the /sink/, but only until one value satisfies the predicate. That -- value is returned rather than copied. pourUntil :: forall m a1 a2 d x . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)              => (x -> Bool) -> Source m a1 x -> Sink m a2 x -> Coroutine d m (Maybe x) pourUntil f source sink = loop-   where loop = foldChunk source (tickUntil f)-                >>= \(chunk, next)-> if null chunk then return (either Just (const Nothing) next)-                                     else putChunk sink chunk >> either (return . Just) (const loop) next+   where loop = foldChunk source (takeWhile (not . f . head)+                                  `andThen` lookAhead (fmap (First . Just . head) anyToken +                                                       <<|> return (First Nothing)))+                >>= extract+         extract ((chunk, First mx), Nothing) = putList chunk sink >> return mx+         extract ((chunk, First Nothing), Just{}) = putChunk sink chunk >> loop  -- | 'mapStream' is like 'pour' that applies the function /f/ to each argument before passing it into the /sink/. mapStream :: forall m a1 a2 d x y . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)@@ -402,20 +427,6 @@          s2' :: Sink m a3 x          s2' = liftSink s2 --- | The 'Source' returned by 'teeSource' writes every value read from its argument source into the argument sink before--- providing it back.-teeSource :: forall m a1 a2 a3 x . (Monad m, AncestorFunctor a1 a3, AncestorFunctor a2 a3)-             => Sink m a1 x -> Source m a2 x -> Source m a3 x-teeSource sink source = Source{foldChunk= teeChunk}-   where teeChunk :: forall d. AncestorFunctor a3 d => Ticker x -> Coroutine d m ([x], Either x (Ticker x))-         teeChunk t = do p@(chunk, _) <- foldChunk source' t-                         _ <- if null chunk then return [] else putChunk sink' chunk-                         return p-         sink' :: Sink m a3 x-         sink' = liftSink sink-         source' :: Source m a3 x-         source' = liftSource source- -- | This function puts a value into the given `Sink`. The intervening 'Coroutine' computations suspend up -- to the 'pipe' invocation that has created the argument sink. put :: forall m a d x. (Monad m, AncestorFunctor a d) => Sink m a x -> x -> Coroutine d m ()@@ -431,7 +442,7 @@ putList l sink = if null l then return [] else putChunk sink l  getChunk :: forall m a d x. (Monad m, AncestorFunctor a d) => Source m a x -> Coroutine d m [x]-getChunk source = liftM fst $ foldChunk source tickAll+getChunk source = liftM fst $ foldChunk source acceptAll  -- | Like 'putList', except it puts the contents of the given 'Data.Sequence.Seq' into the sink. putQueue :: forall m a d x. (Monad m, AncestorFunctor a d) => Seq x -> Sink m a x -> Coroutine d m [x]

@@ -1,5 +1,5 @@-{- -    Copyright 2009-2010 Mario Blazevic+{-+    Copyright 2009-2011 Mario Blazevic      This file is part of the Streaming Component Combinators (SCC) project. @@ -23,33 +23,40 @@    -- * Parsing XML    xmlTokens, parseXMLTokens, expandXMLEntity, XMLToken(..),    -- * XML splitters-   xmlElement, xmlElementContent, xmlElementName, xmlAttribute, xmlAttributeName, xmlAttributeValue, +   xmlElement, xmlElementContent, xmlElementName, xmlAttribute, xmlAttributeName, xmlAttributeValue,    xmlElementHavingTagWith    ) where +import Prelude hiding (takeWhile)++import Control.Applicative (Alternative ((<|>)))+import Control.Arrow ((>>>)) import Control.Monad (when) import Data.Char import Data.Maybe (mapMaybe)+import Data.Monoid (Monoid(..)) import Data.List (find)-import Data.Text (Text)+import Data.Text (Text, pack, unpack, singleton) import qualified Data.Text as Text import Numeric (readDec, readHex) -import Control.Cofunctor.Ticker (andThen, tickOne, tickWhile)+import Data.Functor.Contravariant.Ticker (andThen, tickOne, tickWhile)+import Text.ParserCombinators.Incremental (Parser, anyToken, satisfy, many0, takeWhile, takeWhile1, string,+                                           option, skip, lookAhead, notFollowedBy, mapIncremental, (><), (<<|>)) import Control.Monad.Coroutine (Coroutine, sequentialBinder)  import Control.Concurrent.SCC.Streams-import Control.Concurrent.SCC.Types+import Control.Concurrent.SCC.Types hiding (Parser) import Control.Concurrent.SCC.Coercions (coerce)-import Control.Concurrent.SCC.Combinators (parseEachNestedRegion, findsTrueIn)+import Control.Concurrent.SCC.Combinators (parserToSplitter, findsTrueIn)  data XMLToken = StartTag | EndTag | EmptyTag               | ElementName | AttributeName | AttributeValue-              | EntityReferenceToken | EntityName+              | EntityReference | EntityName               | ProcessingInstruction | ProcessingInstructionText               | Comment | CommentText-              | StartMarkedSectionCDATA | EndMarkedSection+              | StartMarkedSectionCDATA | EndMarkedSection | DoctypeDeclaration               | ErrorToken String                 deriving (Eq, Show) @@ -64,173 +71,146 @@ expandXMLEntity ('#' : codePoint) = [chr (fst $ head $ readDec codePoint)] expandXMLEntity e = error ("String \"" ++ e ++ "\" is not a built-in entity name.") --- | This splitter splits XML markup from data content. It is used by 'parseXMLTokens'.-xmlTokens :: Monad m => Splitter m Char (Boundary XMLToken)-xmlTokens = Splitter $-            \source true false edge->-            let getContent = pourWhile (\x-> x /= '<' && x /= '&') source false-                             >> getWith contentEnd source-                contentEnd '<' = get source-                                 >>= maybe-                                        (put edge (Point errorUnescapedContentLT) >> put false '<')-                                        (\x-> tag x >> getContent)-                contentEnd '&' = entity >> getContent-                contentEnd _ = error "pourUntil returned early!"-                tag '?' = put edge (Start ProcessingInstruction)-                          >> putList "<?" true-                          >> put edge (Start ProcessingInstructionText)-                          >> processingInstruction-                tag '!' = dispatchOnString source-                             (\other-> put edge (Point (errorBadDeclarationType other)))-                             [("--",-                               const (put edge (Start Comment)-                                      >> putList "<!--" true-                                      >> put edge (Start CommentText)-                                      >> comment)),-                              ("[CDATA[",-                               const (put edge (Start StartMarkedSectionCDATA)-                                      >> putList "<![CDATA[" true-                                      >> put edge (End StartMarkedSectionCDATA)-                                      >> markedSection))]-                tag '/' = {-# SCC "EndTag" #-}-                          do put edge (Start EndTag)-                             _ <- putList "</" true-                             elementName <- getWhile isNameChar source-                             if null elementName-                                then put edge (Point errorNamelessEndTag)-                                else put edge (Start ElementName)-                                     >> putList elementName true-                                     >> put edge (End ElementName)-                             pourUntil (not . isSpace) source true-                                >>= maybe -                                       (put edge (Point errorInputEndInEndTag))-                                       (\x-> if x == '>'-                                             then getWith (put true) source-                                             else put edge (Point (errorBadEndTag x)))-                             put edge (End EndTag)-                tag x | isNameStart x = {-# SCC "StartTag" #-}-                                        put edge (Start StartTag)-                                        >> put true '<'-                                        >> name ElementName x-                                        >> attributes-                                        >> put edge (End StartTag)-                tag x = put edge (Point errorUnescapedContentLT)-                        >> put false '<'-                        >> put false x-                startTagEnd '/' = get source-                                  >> put edge (Point EmptyTag)-                                  >> next errorInputEndInStartTag-                                        (\x-> when (x /= '>' ) (put edge (Point (errorBadStartTag x)))-                                              >> putList ['/', x] true-                                              >> return ())-                startTagEnd '>' = getWith (put true) source-                startTagEnd x = put edge (Point (errorBadStartTag x))-                attributes= pourUntil (not . isSpace) source true-                            >>= maybe-                                   (put edge (Point errorInputEndInStartTag))-                                   (\x-> if isNameStart x then attribute >> attributes else startTagEnd x)-                attribute= do put edge (Start AttributeName)-                              pourWhile isNameChar source true-                              put edge (End AttributeName)-                              next errorInputEndInStartTag-                                 (\y-> do when (y /= '=') (put edge (Point (errorBadAttribute y)))-                                          q <- if y == '"' || y == '\''-                                               then return y-                                               else put true y-                                                    >> get source-                                                    >>= maybe-                                                           (put edge (Point errorInputEndInAttributeValue)-                                                            >> return '"')-                                                           return-                                          when (q /= '"' && q /= '\'') (put edge (Point (errorBadQuoteCharacter q)))-                                          put true q-                                          put edge (Start AttributeValue)-                                          attributeValue q-                                          put edge (End AttributeValue)-                                          put true q)-                attributeValue q = pourWhile (\x-> (x /= q && x/= '<' && x /= '&')) source true-                                   >> next errorInputEndInAttributeValue-                                         (\x-> case x-                                               of '<' -> do put edge (Start errorUnescapedAttributeLT)-                                                            put true '<'-                                                            put edge (End errorUnescapedAttributeLT)-                                                            attributeValue q-                                                  '&' -> entity >> attributeValue q-                                                  _ -> return ())-                processingInstruction = {-# SCC "PI" #-}-                                        pourWhile (/= '?') source true-                                        >> dispatchOnString source-                                              (\other-> if null other-                                                        then put edge (Point errorInputEndInProcessingInstruction)-                                                        else putList other true >> processingInstruction)-                                              [("?>",-                                                \match-> put edge (End ProcessingInstructionText)-                                                         >> putList match true-                                                         >> put edge (End ProcessingInstruction)-                                                         >> getContent)]-                comment = {-# SCC "comment" #-}-                          pourWhile (/= '-') source true-                          >> dispatchOnString source-                                (\other-> if null other-                                          then put edge (Point errorInputEndInComment)-                                          else putList other true >> comment)-                                [("-->",-                                  \match-> put edge (End CommentText)-                                           >> putList match true-                                           >> put edge (End Comment)-                                           >> getContent)]-                markedSection = {-# SCC "<![CDATA[" #-}-                                pourWhile (/= ']') source true-                                >> dispatchOnString source-                                      (\other-> if null other-                                                then put edge (Point errorInputEndInMarkedSection)-                                                else putList other true >> markedSection)-                                      [("]]>",-                                        \match-> put edge (Start EndMarkedSection)-                                                 >> putList match true-                                                 >> put edge (End EndMarkedSection)-                                                 >> getContent)]-                entity = put edge (Start EntityReferenceToken)-                         >> put true '&'-                         >> next errorInputEndInEntityReference-                               (\x-> name EntityName x-                                     >> next errorInputEndInEntityReference-                                           (\y-> do when (y /= ';') (put edge (Point (errorBadEntityReference y)))-                                                    put true y))-                         >> put edge (End EntityReferenceToken)-                name token x = {-# SCC "name" #-}-                               put edge (Start token)-                               >> nameTail x-                               >> put edge (End token)-                nameTail x = getWhile isNameChar source-                             >>= \rest-> putList (x:rest) true-                next errorToken f = get source-                                    >>= maybe (put edge (Point errorToken)) f-            in getContent-   where errorInputEndInComment = ErrorToken "Unterminated comment"-         errorInputEndInMarkedSection = ErrorToken "Unterminated marked section"-         errorInputEndInStartTag = ErrorToken "Missing '>' at the end of start tag."-         errorInputEndInEndTag = ErrorToken "End of input in end tag"-         errorInputEndInAttributeValue = ErrorToken "Truncated input after attribute name"-         errorInputEndInEntityReference = ErrorToken "End of input in entity reference"-         errorInputEndInProcessingInstruction = ErrorToken "Unterminated processing instruction"-         errorBadQuoteCharacter q = ErrorToken ("Invalid quote character " ++ show q)-         errorBadStartTag x = ErrorToken ("Invalid character " ++ show x ++ " in start tag")-         errorBadEndTag x = ErrorToken ("Invalid character " ++ show x ++ " in end tag")-         errorBadAttribute x = ErrorToken ("Invalid character " ++ show x ++ " following attribute name")-         errorBadEntityReference x = ErrorToken ("Invalid character " ++ show x ++ " ends entity name.")-         errorBadDeclarationType other = ErrorToken ("Expecting <![CDATA[ or <!--, received " ++ show ("<![" ++ other))-         errorNamelessEndTag = ErrorToken "Missing element name in end tag"-         errorUnescapedContentLT = ErrorToken "Unescaped character '<' in content"-         errorUnescapedAttributeLT = ErrorToken "Invalid character '<' in attribute value."-         isNameStart x = isLetter x || x == '_'-         isNameChar x = isAlphaNum x || x == '_' || x == '-' || x == ':'+newtype XMLStream = XMLStream {chunk :: [Markup XMLToken Text]} deriving (Show) +instance Monoid XMLStream where+   mempty = XMLStream []+   l `mappend` XMLStream [] = l+   XMLStream [] `mappend` r = r+   XMLStream l `mappend` XMLStream r@((Content rc):rt) =+      case last l+      of Content lc -> XMLStream (init l ++ Content (mappend lc rc) : rt)+         _ -> XMLStream (l ++ r)+   XMLStream l `mappend` XMLStream r = XMLStream (l ++ r) +xmlParser :: Parser String XMLStream+xmlParser = many0 (xmlContent <|> xmlMarkup)+   where xmlContent = mapContent $ takeWhile1 (\x-> x /= "<" && x /= "&")+         xmlMarkup = (string "<" >> ((startTag <|> endTag <|> processingInstruction <|> declaration)+                                     <<|> return (XMLStream [Markup $ Point errorUnescapedContentLT,+                                                             Content (singleton '<')])))+                     <|>+                     entityReference "&"+         startTag = return (XMLStream [Markup (Start StartTag), Content (singleton '<'), Markup (Start ElementName)])+                    >< name+                    >< return (XMLStream [Markup (End ElementName)])+                    >< whiteSpace+                    >< attributes+                    >< option (string "/" >> return (XMLStream [Markup (Point EmptyTag), Content (singleton '/')]))+                    >< whiteSpace+                    >< (string ">" >> return (XMLStream [Content (singleton '>'), Markup (End StartTag)])+                        <<|> return (XMLStream [Markup $ Point unterminatedStartTag, Markup $ End StartTag]))+         entityReference s = string s+                             >> (return (XMLStream [Markup (Start EntityReference), Content (pack s),+                                                    Markup (Start EntityName)])+                                 >< name+                                 >< (string ";" >> return (XMLStream [Markup (End EntityName), Content (singleton ';'),+                                                                      Markup (End EntityReference)]))+                                 <<|> return (XMLStream [Markup $ Point $ errorBadEntityReference, Content (pack s)]))+         attributes = many0 (attribute >< whiteSpace)+         attribute = return (XMLStream [Markup (Start AttributeName)])+                     >< name+                     >< return (XMLStream [Markup (End AttributeName)])+                     >< (mapContent (string "=")+                         <<|> (fmap (\x-> XMLStream [Markup $ Point $ errorBadAttribute x]) anyToken+                               >< whiteSpace >< option (mapContent $ string "=")))+                     >< ((string "\"" <|> string "\'")+                         >>= \quote-> return (XMLStream [Content $ pack quote, Markup (Start AttributeValue)])+                                      >< mapContent (takeWhile (/= quote))+                                      >< return (XMLStream [Markup (End AttributeValue), Content $ pack quote])+                                      >< skip (string quote)+                         <<|> (anyToken >>= \q-> return (XMLStream [Markup $ Point $ errorBadQuoteCharacter q,+                                                                    Content $ pack quote])))+         endTag = (string "/" >> return (XMLStream [Markup (Start EndTag), Content (pack "</"),+                                                    Markup (Start ElementName)]))+                  >< name+                  >< return (XMLStream [Markup (End ElementName)])+                  >< whiteSpace+                  >< (string ">" >> return (XMLStream [Content (singleton '>'), Markup (End EndTag)])+                      <<|> return (XMLStream [Markup $ Point unterminatedEndTag, Markup (End EndTag)]))+         processingInstruction = (string "?"+                                  >> return (XMLStream [Markup (Start ProcessingInstruction), Content (pack "<?"),+                                                        Markup (Start ProcessingInstructionText)]))+                                 >< upto "?>"+                                 >< (string "?>"+                                     >> return (XMLStream [Markup (End ProcessingInstructionText), Content (pack "?>"),+                                                           Markup (End ProcessingInstruction)])+                                     <<|> return (XMLStream [Markup $ Point unterminatedProcessingInstruction]))+         declaration = string "!" +                       >> ((comment <|> cdataMarkedSection <|> doctypeDeclaration)+                           <<|> return (XMLStream [Markup $ Point $ errorBadDeclarationType, Content (pack "<")]))+         comment = (string "--" >> return (XMLStream [Markup (Start Comment), Content (pack "<!--"),+                                                       Markup (Start CommentText)]))+                   >< upto "-->"+                   >< (string "-->" >> return (XMLStream [Markup (End CommentText), Content (pack "-->"),+                                                          Markup (End Comment)])+                       <<|> return (XMLStream [Markup $ Point unterminatedComment]))+         cdataMarkedSection = (string "[CDATA["+                               >> return (XMLStream [Markup (Start StartMarkedSectionCDATA), Content (pack "<![CDATA["),+                                                     Markup (End StartMarkedSectionCDATA)]))+                              >< upto "]]>"+                              >< (string "]]>"+                                  >> return (XMLStream [Markup (Start EndMarkedSection), Content (pack "]]>"),+                                                        Markup (End EndMarkedSection)])+                                  <<|> return (XMLStream [Markup $ Point unterminatedMarkedSection]))+         doctypeDeclaration = (string "DOCTYPE" >> return (XMLStream [Markup (Start DoctypeDeclaration),+                                                                       Content (pack "<!DOCTYPE")]))+                              >< whiteSpace+                              >< (name+                                  >< whiteSpace+                                  >< option ((mapContent (string "SYSTEM")+                                              <|> mapContent (string "PUBLIC") >< whiteSpace >< literal)+                                             >< whiteSpace >< literal >< whiteSpace)+                                  >< option (mapContent (string "[") >< whiteSpace+                                             >< many0 ((markupDeclaration <|> comment <|> processingInstruction+                                                        <|> entityReference "%")+                                                       >< whiteSpace)+                                             >< mapContent (string "]") >< whiteSpace)+                                  >< mapContent (string ">")+                                  <<|> return (XMLStream [Markup (Point errorMalformedDoctypeDeclaration)]))+                              >< return (XMLStream [Markup (End DoctypeDeclaration)])+         literal = (string "\"" <|> string "\'")+                   >>= \quote-> return (XMLStream [Content $ pack quote])+                                >< mapContent (takeWhile (/= quote))+                                >< return (XMLStream [Content $ pack quote])+                                >< skip (string quote)+         markupDeclaration= mapContent (string "<!")+                            >< (many0 (mapContent (takeWhile1 (\x-> x /= ">" && x /= "\"" && x /= "\'")) <|> literal)+                                >< mapContent (string ">")+                                <<|> return (XMLStream [Markup $ Point unterminatedMarkupDeclaration]))+         name = mapContent (takeWhile1 (isNameChar . head))+         mapContent = mapIncremental (XMLStream . (:[]) . Content . pack)+         whiteSpace = mapContent (takeWhile (isSpace . head))+         upto end@(lead:_) = mapContent (many0 (takeWhile1 (/= [lead]) <<|> notFollowedBy (string end) >< anyToken))++errorBadQuoteCharacter q = ErrorToken ("Invalid quote character " ++ show q)+errorBadAttribute x = ErrorToken ("Invalid character " ++ show x ++ " following attribute name")+errorBadEntityReference = ErrorToken "Invalid entity reference."+errorBadDeclarationType = ErrorToken "The \"<!\" sequence must be followed by \"[CDATA[\" or \"--\"."+errorMalformedDoctypeDeclaration = ErrorToken "Malformed DOCTYPE declaration."+errorUnescapedContentLT = ErrorToken "Unescaped character '<' in content"+unterminatedComment = ErrorToken "Unterminated comment."+unterminatedMarkedSection = ErrorToken "Unterminated marked section."+unterminatedMarkupDeclaration = ErrorToken "Unterminated markup declaration."+unterminatedStartTag = ErrorToken "Missing '>' at the end of start tag."+unterminatedEndTag = ErrorToken "Missing '>' at the end of end tag."+unterminatedProcessingInstruction = ErrorToken "Unterminated processing instruction."++isNameStart x = isLetter x || x == '_'++isNameChar x = isAlphaNum x || x == '_' || x == '-' || x == ':'++-- | XML markup splitter wrapping 'parseXMLTokens'.+xmlTokens :: Monad m => Splitter m Char (Boundary XMLToken)+xmlTokens = parserToSplitter (parseXMLTokens >>> statelessTransducer unpackContent)+   where unpackContent :: Markup XMLToken Text -> [Markup XMLToken Char]+         unpackContent (Markup b) = [Markup b]+         unpackContent (Content c) = map Content (unpack c)+ -- | The XML token parser. This parser converts plain text to parsed text, which is a precondition for using the -- remaining XML components. parseXMLTokens :: Monad m => Transducer m Char (Markup XMLToken Text)-parseXMLTokens = parseEachNestedRegion sequentialBinder xmlTokens coerce+parseXMLTokens = Transducer (pourParsed (mapIncremental chunk xmlParser))  dispatchOnString :: forall m a d r. (Monad m, AncestorFunctor a d) =>                     Source m a Char -> (String -> Coroutine d m r) -> [(String, String -> Coroutine d m r)]@@ -293,7 +273,7 @@                               end <- get source                               case end of Nothing -> return (rest, False)                                           Just e@(Markup (End StartTag)) -> return (rest ++ [e], True)-                                          Just e@(Markup (Point EmptyTag)) -> +                                          Just e@(Markup (Point EmptyTag)) ->                                              getRestOfStartTag source                                              >>= \(rest', _)-> return (rest ++ (e: rest'), False)                                           _ -> error "getWhile returned early!"@@ -312,8 +292,8 @@               -> Text               -> Coroutine d m () findEndTag source sink endSink name = findTag where-   findTag = pourWhile noTagStart source sink -             >> get source +   findTag = pourWhile noTagStart source sink+             >> get source              >>= maybe (return ()) consumeOne    noTagStart (Markup (Start StartTag)) = False    noTagStart (Markup (Start EndTag)) = False@@ -336,7 +316,7 @@                                                                when hasContent (findEndTag source sink sink name')                                                                findTag)                                                   mn-   consumeOne _ = error "pourUntil returned early!"+   consumeOne _ = error "pourWhile returned early!"  findStartTag :: forall m a1 a2 d. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d) =>                 Source m a1 (Markup XMLToken Text) -> Sink m a2 (Markup XMLToken Text)@@ -414,7 +394,7 @@                \source true false edge->                let split0 = getWith                                (\x-> case x-                                     of Markup (Start AttributeName) -> +                                     of Markup (Start AttributeName) ->                                            do put edge ()                                               put true x                                               pourRestOfRegion AttributeName source true true

@@ -1,5 +1,9 @@-Executables=test test-prof test-coroutine test-enumerator test-iteratee test-enumerator-scc test-parallel shsh shsh-prof-CoroutineLibraryFiles=Control/Cofunctor/Ticker.hs \+Executables=${TestExecutables} shsh shsh-prof+TestExecutables=$(addprefix test/, scc parallel benchmark-coroutine incremental-parser \+                                   enumerator iteratee enumerator-scc)+IterativeParserFiles=Text/ParserCombinators/Incremental.hs \+                     $(addprefix Data/Monoid/, Cancellative.hs Factorial.hs Null.hs)+CoroutineLibraryFiles=$(IterativeParserFiles) Data/Functor/Contravariant/Ticker.hs \                       $(addprefix Control/Monad/, \                                   Parallel.hs Coroutine.hs Coroutine/SuspensionFunctors.hs Coroutine/Nested.hs) SCCCommonFiles=$(CoroutineLibraryFiles) \@@ -20,27 +24,27 @@  docs: doc/index.html -test: Test.hs $(AllLibraryFiles) | obj+test/scc: Test/TestSCC.hs $(AllLibraryFiles) | obj 	ghc --make $< -o $@ $(OptimizingOptions) -test-prof: Test.hs $(AllLibraryFiles) | prof-	ghc --make $< -o $@ $(ProfilingOptions)+test/benchmark-coroutine: Test/BenchmarkCoroutine.hs $(CoroutineLibraryFiles) | obj+	ghc --make $< -o $@ $(OptimizingOptions) -eventlog -test-coroutine: TestCoroutine.hs $(CoroutineLibraryFiles) | obj+test/incremental-parser: Test/TestIncrementalParser.hs Text/ParserCombinators/Incremental.hs | obj 	ghc --make $< -o $@ $(OptimizingOptions) -eventlog -test-enumerator: TestEnumerator.hs $(CoroutineLibraryFiles) Control/Monad/Coroutine/Enumerator.hs | obj+test/enumerator: Test/TestEnumerator.hs $(CoroutineLibraryFiles) Control/Monad/Coroutine/Enumerator.hs | obj 	ghc --make $< -o $@ $(OptimizingOptions) -eventlog -test-iteratee: TestIteratee.hs $(CoroutineLibraryFiles) Control/Monad/Coroutine/Iteratee.hs | obj+test/iteratee: Test/TestIteratee.hs $(CoroutineLibraryFiles) Control/Monad/Coroutine/Iteratee.hs | obj 	ghc --make $< -o $@ $(OptimizingOptions) -eventlog -test-enumerator-scc: TestEnumeratorSCC.hs $(SCCCommonFiles) \+test/enumerator-scc: Test/TestEnumeratorSCC.hs $(SCCCommonFiles) \ 	                  Control/Monad/Coroutine/Enumerator.hs \                      Control/Concurrent/SCC/Combinators/Sequential.hs Control/Concurrent/SCC/Sequential.hs | obj 	ghc --make $< -o $@ $(OptimizingOptions) -eventlog -test-parallel: TestParallel.hs Control/Monad/Parallel.hs | obj+test/parallel: Test/TestParallel.hs Control/Monad/Parallel.hs | obj 	ghc --make $< -o $@ $(OptimizingOptions) -eventlog  shsh: Shell.hs $(AllLibraryFiles) | obj

@@ -863,8 +863,9 @@                                     "last", "letters", "line", "marked", "nested", "nothing", "prefix", "prepend",                                     "select", "show", "stdin", "substitute", "substring", "suffix", "suppress",                                     "then", "unparse", "uppercase", "while", "whitespace",-                                    "XML.parse-tags", "XML.serialize-tags",-                                    "XML.element", "XML.element-content", "XML.element-having-tag", "XML.element-name"]}+                                    "XML.parse", "XML.attribute", "XML.attribute-name", "XML.attribute-value",+                                    "XML.element", "XML.element-content", "XML.element-having-tag-with", +                                    "XML.element-name"]}  reservedTokens = reservedOpNames language ++ reservedNames language 

@@ -1,628 +0,0 @@-{- -    Copyright 2008-2010 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 FlexibleInstances, ScopedTypeVariables #-}--module Main where--import Control.Concurrent.Configuration-import Control.Monad.Coroutine-import Control.Concurrent.SCC.Streams-import Control.Concurrent.SCC.Types-import qualified Control.Concurrent.SCC.Combinators as Combinator-import Control.Concurrent.SCC.Configurable hiding ((&&), (||))-import qualified Control.Concurrent.SCC.XML as XML-import qualified Control.Concurrent.SCC.Configurable as C--import Control.Monad (liftM, when)-import Data.Char (ord, isLetter, isSpace, toUpper)-import Data.Either (rights)-import Data.Functor.Identity (Identity (Identity, runIdentity))-import Data.List (find, findIndices, groupBy, intersect, union,-                  intercalate, isInfixOf, isPrefixOf, isSuffixOf, nub, sort, tails)-import Data.Maybe (fromJust, isJust, mapMaybe)-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, id, last)-import qualified Prelude-import Test.QuickCheck (Arbitrary, Gen, Property, CoArbitrary,-                        Positive(Positive), NonNegative(NonNegative), NonEmptyList(NonEmpty),-                        arbitrary, coarbitrary, label, classify, choose, mapSize, oneof, resize, sized,-                        quickCheck, variant, (==>))---sublists [] _ = []-sublists _ [] = []-sublists sublist input = map-                           (input !!)-                           (nub $ sort $ concatMap-                                            (\n-> [n .. n + length sublist - 1])-                                            (findIndices (isPrefixOf sublist) (tails input)))--contentIn :: [Markup y x] -> [x]-contentIn = mapMaybe (\x-> case x of {Content y -> Just y; _ -> Nothing})--both f (x, y) = (f x, f y)--main = mapM_ quickCheck tests--tests = [label "pipe" $ \(input :: [Int])-> runCoroutine (pipe (putList input) getList) == Just ([], input),-         label "pour" prop_pour,-         label "id" prop_id,-         label "suppress" prop_suppress,-         label "substitute" prop_substitute,-         label "prepend" prop_prepend,-         label "append" prop_append,-         label "everything" prop_allTrue,-         label "nothing" prop_allFalse,-         label "substring" prop_substring,-         label "group" prop_group,-         label "concatenate" prop_concatenate,-         label "concatSeparate" prop_concatSeparate,-         label "uppercase ->>" $ \s-> runCoroutine (pipe-                                                        (putList s)-                                                        (consume $ with $-                                                         uppercase >-> atomic "getList" 1 (Consumer getList)))-                  == Just ([], map toUpper s),-         label "uppercase <<-" $ \s-> runCoroutine (pipe-                                                        (produce $ with $-                                                         atomic "putList" 1 (Producer (putList s)) >-> uppercase)-                                                        getList)-                  == Just ([], map toUpper s),-         label "uppercase `join` id" $ \s-> transducerOutput (uppercase `join` id) s == map toUpper s ++ s,-         label "prepend >-> append" (\(s :: String) prefix suffix->-                                     transducerOutput (prepend (fromList prefix) >-> append (fromList suffix)) s-                                     == prefix ++ s ++ suffix),-         label "prepend == (`join` id) . substitute" $-               \(s :: String) prefix-> transducerOutput (prepend (fromList prefix)) s-                                       == transducerOutput (substitute (fromList prefix) `join` id) s,-         label "append == (id `join`) . substitute" $-               \(s :: String) suffix-> transducerOutput (append (fromList suffix)) s-                                       == transducerOutput (id `join` substitute (fromList suffix)) s,-         label "whitespace" $ \s-> splitterOutputs whitespace s == (filter isSpace s, filter (not . isSpace) s),-         label "ifs everything id id" $ \(s :: [TestEnum])-> transducerOutput (ifs everything id id) s == s,-         label "substring" $ \s (c :: TestEnum)-> splitterOutputs (substring [c]) s == (filter (==c) s, filter (/=c) s),-         label "ifs (substring X) uppercase id" $-               \s (LowercaseLetter c)-> transducerOutput (ifs (substring [c]) uppercase id) s-                                        == map (\x-> if x == c then toUpper x else x) s,-         label "parseSubstring" $ \s (c :: TestEnum)-> transducerOutput-                                                          (parseSubstring [c] >-> select markedContent >-> unparse)-                                                          s-                                                       == filter (==c) s,-         label "uppercase `wherever` parseSubstring" $-               \s (LowercaseLetter c)-> transducerOutput-                                           (parseSubstring [c]-                                            >-> (uppercaseContent `wherever` markedContent)-                                            >-> unparse)-                                           s-                                        == map (\x-> if x == c then toUpper x else x) s,-         label "parseRegions substring == parseSubstring" prop_substringVsParse,-         label "count >-> toString >-> concatenate" $-               \(s :: [TestEnum])-> transducerOutput (count >-> toString >-> concatenate) s == show (length s),-         label "foreach whitespace id (prepend \"[\" >-> append \"]\")" $-               \s-> transducerOutput (foreach whitespace id (prepend (fromList "[") >-> append (fromList "]"))) s-                    == mapWords (("[" ++) . (++ "]")) s,-         label "foreach whitespace id (count >-> toString >-> concatenate)" $-               \s-> transducerOutput (foreach whitespace id (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 ==> classify (not (s1 `isInfixOf` s2)) "trivial" $-                  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) id)"-                  (transducerOutput (foreach letters (count >-> toString >-> concatenate) id) "Hola, Mundo!" == "4, 5!"),-         label "(foreach (letters `having` prefix (substring \"H\")) uppercase id)"-                  (transducerOutput (foreach-                                        (letters `having` prefix (substring "H"))-                                        uppercase-                                        id)-                      "Hello, World! Hola, Mundo!"-                   == "HELLO, World! HOLA, Mundo!"),-         label "(foreach (letters `having` suffix (substring \"o\")) uppercase id)"-                  (transducerOutput (foreach-                                        (letters `having` suffix (substring "o"))-                                        uppercase-                                        id)-                      "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 "followedBy startOf everything" $ \trace n-> prop_followedBy2 (splitterFromTrace trace) n,-         label "substring followedBy substring 1" prop_followedBy3,-         label "substring followedBy substring 2" prop_followedBy4,-         label "substring followedBy substring 3" prop_followedBy5,-         label "endOf followedBy U followedBy startOf"-                  $ \trace1 trace2 n-> prop_followedBy6 (splitterFromTrace trace1) (splitterFromTrace trace2) n,-         label "... followedBy ..." prop_followedByBetween,-         label "start ... end"  $ \trace n-> prop_between1 (simpleSplitterFromTrace trace) n,-         label "start everything ... end"  $ \trace n-> prop_between2 (simpleSplitterFromTrace trace) n,--         label "XML.tokens" prop_XMLtokens1,-         label "XML.tokens with attributes" prop_XMLtokens2,-         label "XML.parseTokens >-> select elementContent >-> unparse" prop_XMLtokens3,-         label "XML.parseTokens >-> unparse" prop_XMLtokens4,-         label "nestedIn XML.elementContent" $ mapSize (min 40) prop_nestedInXMLcontent,-         label "select XML.elementContent while XML.element" $ mapSize (min 50) prop_whileXMLelement]---prop_pour :: [Int] -> Bool-prop_pour input = runCoroutine (pipe (putList input) (\source-> pipe (\sink-> pour source sink) getList))-                  == Just ([], ((), input))--prop_id :: [Int] -> Bool-prop_id input = transducerOutput id input == input--prop_suppress :: [Int] -> Bool-prop_suppress input = null (transducerOutput (consumeBy suppress :: TransducerComponent Identity Int ()) input)--prop_substitute :: [Int] -> [Maybe Int] -> Bool-prop_substitute input replacement = transducerOutput (substitute $ fromList replacement) input == replacement--prop_prepend :: [Int] -> [Int] -> Int -> Property-prop_prepend input prefix threads = threads > 0 ==>-                                    transducerOutput (usingThreads (prepend $ fromList prefix) threads) input-                                    == prefix ++ input--prop_append :: [Int] -> [Int] -> Int -> Property-prop_append input suffix threads = threads > 0 ==>-                                   transducerOutput (usingThreads (append $ fromList suffix) threads) input-                                   == input ++ suffix--prop_allTrue :: [Int] -> Bool-prop_allTrue input = splitterOutputs everything input == (input, [])--prop_allFalse :: [Int] -> Bool-prop_allFalse input = splitterOutputs nothing input == ([], input)--prop_substring :: [TestEnum] -> [TestEnum] -> Property-prop_substring input sublist = classify (not (isInfixOf sublist input)) "trivial"-                                  (transducerOutput (select (substring sublist)) input == sublists sublist input)--prop_substringVsParse :: [TestEnum] -> [TestEnum] -> Property-prop_substringVsParse input sublist = not (null sublist) && length sublist < length input-                                      && not (sublist `isInfixOf` (tail sublist ++ init sublist))-                                      ==> classify (not (sublist `isInfixOf` input)) "trivial"-                                             (transducerOutput (parseRegions (substring sublist)) input-                                              == map unitFromOccurrence (transducerOutput (parseSubstring sublist) input))-   where unitFromOccurrence (Content x) = Content x-         unitFromOccurrence (Markup b) = Markup (fmap (const ()) b)--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 :: SplitterComponent Identity Int () -> [Int] -> Bool-prop_snot splitter input = splitterOutputs (snot splitter) input == swap (splitterOutputs splitter input)--prop_andAssoc :: SplitterTrace -> SplitterTrace -> SplitterTrace -> [Int] -> Int -> Int -> Property-prop_andAssoc st1 st2 st3 input t1 t2-   = t1 > 0 && t2 > 0-     ==> splitterOutputs (usingThreads (s1 C.&& (s2 C.&& s3)) t1) input-      == splitterOutputs (usingThreads ((s1 C.&& s2) C.&& s3) t2) input-   where s1 = splitterFromTrace st1-         s2 = splitterFromTrace st2-         s3 = splitterFromTrace st3--prop_orAssoc :: SplitterTrace -> SplitterTrace -> SplitterTrace -> [Int] -> Int -> Int -> Property-prop_orAssoc st1 st2 st3 input t1 t2-   = t1 > 0 && t2 > 0-     ==> splitterOutputs (usingThreads (s1 C.|| (s2 C.|| s3)) t1) input-      == splitterOutputs (usingThreads ((s1 C.|| s2) C.|| s3) t2) input-   where s1 = splitterFromTrace st1-         s2 = splitterFromTrace st2-         s3 = splitterFromTrace st3--prop_DeMorgan1 :: SplitterComponent Identity Int () -> SplitterComponent Identity Int () -> [Int]-               -> Positive Int -> Positive Int -> Bool-prop_DeMorgan1 s1 s2 input (Positive t1) (Positive t2)-   = splitterOutputs (usingThreads (snot (s1 C.&& s2)) (t1 `mod` 50)) input-      == splitterOutputs (usingThreads (snot s1 C.|| snot s2) (t2 `mod` 50)) input--prop_DeMorgan2 :: SplitterComponent Identity Int () -> SplitterComponent Identity Int () -> [Int]-               -> Positive Int -> Positive Int -> Bool-prop_DeMorgan2 s1 s2 input (Positive t1) (Positive t2)-   = splitterOutputs (usingThreads (snot (s1 C.|| s2)) (t1 `mod` 50)) input-     == splitterOutputs (usingThreads (snot s1 C.&& snot s2) (t2 `mod` 50)) input--prop_and :: SplitterComponent Identity Int () -> SplitterComponent Identity Int () -> Positive Int -> Bool-prop_and s1 s2 (Positive n) = fst (splitterOutputs (s1 C.&& s2) l)-                              == fst (splitterOutputs s1 l) `intersect` fst (splitterOutputs s2 l)-   where l = [1 .. n `mod` 1000]--prop_or :: SplitterComponent Identity Int () -> SplitterComponent Identity Int () -> Positive Int -> Bool-prop_or s1 s2 (Positive n) = fst (splitterOutputs (s1 C.|| s2) l)-                             == sort (fst (splitterOutputs s1 l) `union` fst (splitterOutputs s2 l))-   where l = [1 .. n `mod` 1000]--prop_even :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool-prop_even splitter input = let splitOddEven [] = ([], [])-                               splitOddEven (head:tail) = let (evens, odds) = splitOddEven tail in (head:odds, evens)-                           in fst (splitterOutputs (even splitter) input)-                              == concat (snd $ splitOddEven $-                                         transducerOutput (foreach splitter group (consumeBy suppress)) input)--prop_prefix_1 :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool-prop_prefix_1 splitter input = let (pfx, rest) = splitterOutputs (prefix splitter) input-                                   (true, false) = splitterOutputs splitter input-                               in pfx ++ rest == input && pfx `isPrefixOf` true--prop_prefix_2 :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool-prop_prefix_2 splitter input = let (prefix1, rest1) = splitterOutputs (prefix splitter) input-                               in case splitterOutputChunks splitter input-                                  of (prefix2, True):rest2 -> prefix1 == prefix2 && rest1 == concat (map fst rest2)-                                     (prefix2, False):rest2 -> prefix1 == [] && rest1 == prefix2 ++ concat (map fst rest2)-                                     [] -> prefix1 ++ rest1 == []--prop_suffix_1 :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool-prop_suffix_1 splitter input = let (sfx, rest) = splitterOutputs (suffix splitter) input-                                   (true, false) = splitterOutputs splitter input-                               in rest ++ sfx == input && sfx `isSuffixOf` true--prop_suffix_2 :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool-prop_suffix_2 splitter input = let (suffix1, rest1) = splitterOutputs (suffix splitter) input-                               in case reverse (splitterOutputChunks splitter input)-                                  of (suffix2, True):rest2 -> suffix1 == suffix2-                                                              && rest1 == concat (map fst (reverse rest2))-                                     (suffix2, False):rest2 -> suffix1 == []-                                                               && rest1 == concat (map fst (reverse rest2)) ++ suffix2-                                     [] -> rest1 ++ suffix1 == []--prop_first :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool-prop_first splitter input = let (first1, rest1) = splitterOutputs (first splitter) input-                            in case splitterOutputChunks splitter input-                               of (first2, True):rest2 -> first1 == first2 && rest1 == concat (map fst rest2)-                                  (prefix, False):(first2, True):rest2 -> first1 == first2-                                                                          && rest1 == prefix ++ concat (map fst rest2)-                                  (prefix, False):[] -> first1 == [] && rest1 == prefix-                                  [] -> first1 ++ rest1 == []--prop_last :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool-prop_last splitter input = let (last1, rest1) = splitterOutputs (last splitter) input-                           in -- trace (show (last1, rest1)) $ trace (show (splitterOutputChunks splitter input)) $-                              case reverse (splitterOutputChunks splitter input)-                              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 :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool-prop_uptoFirst splitter input = let (first1, rest1) = splitterOutputs (uptoFirst splitter) input-                                in case splitterOutputChunks splitter input-                                   of (first2, True):rest2 -> first1 == first2 && rest1 == concat (map fst rest2)-                                      (prefix, False):(first2, True):rest2 -> first1 == prefix ++ first2-                                                                              && rest1 == concat (map fst rest2)-                                      (prefix, False):[] -> first1 == [] && rest1 == prefix-                                      [] -> first1 ++ rest1 == []--prop_lastAndAfter :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool-prop_lastAndAfter splitter input = let (last1, rest1) = splitterOutputs (lastAndAfter splitter) input-                                   in case reverse (splitterOutputChunks splitter input)-                                      of (last2, True):rest2 -> last1 == last2 && rest1 == concat (map fst (reverse rest2))-                                         (suffix, False):(last2, True):rest2 -> last1 == last2 ++ suffix-                                                                                && rest1 == concat (map fst (reverse rest2))-                                         (suffix, False):[] -> last1 == [] && rest1 == suffix-                                         [] -> last1 ++ rest1 == []--prop_followedBy1 :: SplitterComponent Identity Int () -> SplitterComponent Identity Int () -> Positive Int -> Bool-prop_followedBy1 s1 s2 (Positive n) = splitterOutputs (s1 `followedBy` s2) l-                                      == splitterOutputs (s1 `followedBy` prefix s2) l-   where l = [1 .. n `mod` 300]--prop_followedBy2 :: SplitterComponent Identity Int () -> Int -> Bool-prop_followedBy2 s n = splitterOutputs (s `followedBy` startOf everything) l == splitterOutputs s l-   where l = [1 .. n `mod` 300]--prop_followedBy3 :: [TestEnum] -> [TestEnum] -> [TestEnum] -> Property-prop_followedBy3 l1 l2 l3 = classify (not (isInfixOf l1 l3)) "trivial" $-                            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-                            ==> classify (not (isInfixOf (l1 ++ l2) l3)) "trivial" $-                                fst (splitterOutputs (substring l1 `followedBy` substring l2) l3) == sublists (l1 ++ l2) l3--prop_followedBy5 :: Positive Int -> NonNegative Int -> Positive Int -> NonNegative Int -> Bool-prop_followedBy5 (Positive i1) (NonNegative i2) (Positive i3) (NonNegative i4) =-   let n1 = i1 `mod` 1000-       n2 = n1 + i2 `mod` 100-       n3 = n2 + i3 `mod` 100-       n4 = n3 + i4 `mod` 100-   in splitterOutputs (substring [n1 .. n2] `followedBy` substring [n2 + 1 .. n3]) [0 .. n4]-         == ([n1 .. n3], [0 .. n1 - 1] ++ [n3 + 1 .. n4])--prop_followedBy6 :: SplitterComponent Identity Int () -> SplitterComponent Identity Int () -> Positive Int -> Bool-prop_followedBy6 s1 s2 (Positive n) = sort (fst (splitterOutputs (endOf s1 `followedBy` s2) l)-                                            `union` fst (splitterOutputs (s1 `followedBy` startOf s2) l))-                                      == fst (splitterOutputs (s1 `followedBy` s2) l)-   where l = [1 .. n `mod` 500]--prop_followedByBetween :: Positive Int -> NonNegative Int -> Positive Int -> NonNegative Int -> Bool-prop_followedByBetween (Positive i1) (NonNegative i2) (Positive i3) (NonNegative i4) =-   let n1 = i1 `mod` 500-       n2 = n1 + i2 `mod` 500-       n3 = n2 + i3 `mod` 500 + 1-       n4 = n3 + i4 `mod` 500-   in splitterOutputs-         ((substring [n1] ... substring [n2]) `followedBy` (substring [n2 + 1] ... substring [n3]))-         [0 .. n4]-      == ([n1 .. n3], [0 .. n1 - 1] ++ [n3 + 1 .. n4])--prop_between1 :: SplitterComponent Identity Int () -> Positive Int -> Bool-prop_between1 splitter (Positive n) =-   splitterOutputs (startOf splitter ... endOf splitter) input == splitterOutputs splitter input-   && splitterOutputs (endOf splitter ... startOf splitter) input == ([], input)-   where input = [1 .. n `mod` 500]--prop_between2 :: SplitterComponent Identity Int () -> Positive Int -> Bool-prop_between2 splitter (Positive n) = splitterOutputs (startOf everything ... endOf splitter) input-                                      == splitterOutputs (uptoFirst splitter) input-                                      || null (fst $ splitterOutputs splitter input)-   where input = [1 .. n `mod` 500]--prop_XMLtokens1 :: [LowercaseLetter] -> String -> Property-prop_XMLtokens1 name content = name /= [] && intersect content "<&" == []-                               ==> splitterOutputs xmlTokens (start ++ content ++ end) == (start ++ end, content)-   where name' = map letterChar name-         start = "<" ++ name' ++ ">"-         end = "</" ++ name' ++ ">"--prop_XMLtokens2 :: [LowercaseLetter] -> [(Identifier, String)] -> String -> Property-prop_XMLtokens2 name attrs content = name /= [] && all validAttribute attrs && intersect content "<&" == []-                                     ==> splitterOutputs xmlTokens (start ++ content ++ end)-                                            == (start ++ end, content)-   where name' = map letterChar name-         start = "<" ++ name' ++ concatMap attribute attrs ++ ">"-         end = "</" ++ name' ++ ">"--prop_XMLtokens3 :: [LowercaseLetter] -> Bool -> [(Identifier, String)] -> String -> Property-prop_XMLtokens3 name ws attrs content = name /= [] && all validAttribute attrs && intersect content "<&" == []-                                        ==> transducerOutput-                                               (xmlParseTokens >-> select xmlElementContent >-> unparse >-> coerce)-                                               (start ++ content ++ end)-                                               == content-   where name' = map letterChar name ++ spaces-         spaces = if ws then "\n\t  " else ""-         start = "<" ++ name' ++ List.intercalate spaces (map attribute attrs) ++ ">"-         end = "</" ++ name' ++ ">"--prop_XMLtokens4 :: NonEmptyList LowercaseLetter -> [(Identifier, String)] -> String -> Bool-prop_XMLtokens4 (NonEmpty name) attrs content =-   transducerOutput (xmlParseTokens >-> unparse >-> coerce) input == input-   where name' = map letterChar name-         start = "<" ++ name' ++ concatMap attribute attrs ++ ">"-         end = "</" ++ name' ++ ">"-         content' = concatMap escapeContentCharacter content-         input = start ++ content' ++ end--prop_nestedInXMLcontent :: [Either (Identifier, [(Identifier, String)]) String] -> Bool-prop_nestedInXMLcontent startTagsAndContent = transducerOutput-                                                 (xmlParseTokens-                                                  >-> select (snot xmlElement `nestedIn` xmlElementContent)-                                                  >-> unparse >-> coerce)-                                                 (nestXMLelements startTagsAndContent)-                                              == concatMap escapeContentCharacter (concat (rights startTagsAndContent))--prop_whileXMLelement :: [Either (Identifier, [(Identifier, String)]) String] -> Bool-prop_whileXMLelement startTagsAndContent = transducerOutput-                                              (xmlParseTokens-                                               >-> (select xmlElementContent `while` xmlElement)-                                               >-> unparse >-> coerce)-                                              (nestXMLelements startTagsAndContent)-                                           == concatMap escapeContentCharacter (concat (rights startTagsAndContent))--nestXMLelements [] = []-nestXMLelements (Left (Identifier (NonEmpty name), attrs) : rest) = "<" ++ name' ++ concatMap attribute attrs ++ ">"-                                                                    ++ nestXMLelements rest ++ "</" ++ name' ++ ">"-   where name' = map letterChar name-nestXMLelements (Right content : rest) = concatMap escapeContentCharacter content ++ nestXMLelements rest--attribute (Identifier (NonEmpty name), value) =-   " " ++ map letterChar name ++ "=\"" ++ concatMap escapeAttributeCharacter value ++ "\""-validAttribute (Identifier (NonEmpty name), value) = name /= [] && intersect value "<&\"" == []---- | Escapes a character for inclusion into an XML attribute value.-escapeAttributeCharacter :: Char -> String-escapeAttributeCharacter '"' = "&quot;"-escapeAttributeCharacter '\t' = "&#9;"-escapeAttributeCharacter '\n' = "&#10;"-escapeAttributeCharacter '\r' = "&#13;"-escapeAttributeCharacter x = escapeContentCharacter x---- | Escapes a character for inclusion into the XML data content.-escapeContentCharacter :: Char -> String-escapeContentCharacter '<' = "&lt;"-escapeContentCharacter '&' = "&amp;"-escapeContentCharacter x = [x]--uppercaseContent :: (Functor f, Monad m) => TransducerComponent m (f Char) (f Char)-uppercaseContent = atomic "uppercase" 1 (oneToOneTransducer $ fmap toUpper)--transducerOutput :: TransducerComponent Identity x y -> [x] -> [y]-transducerOutput t = transducerOutput' (with t)--transducerOutput' :: Transducer Identity x y -> [x] -> [y]-transducerOutput' t input = case runCoroutine (pipe-                                                   (putList input)-                                                   (\source-> pipe-                                                                 (\sink-> transduce t source sink)-                                                                 getList))-                           of Identity (_, (_, output)) -> output--splitterOutputs :: SplitterComponent Identity x b -> [x] -> ([x], [x])-splitterOutputs s input = -   case runCoroutine (pipe-                         (putList input)-                         (\source-> -                           pipe -                              (\true-> -                                pipe-                                   (\false-> -                                     pipe-                                        (\edge-> split (with s) source true false edge)-                                        (mapMStream_ (const $ return ())))-                                   getList)-                              getList))-   of Identity (_, ((_, false), true)) -> (true, false)--splitterUnifiedOutput :: forall x b. SplitterComponent Identity x b -> [x] -> [Either (x, Bool) b]-splitterUnifiedOutput s input =-   snd $ runIdentity $-   runCoroutine (pipe-                     (\sink-> pipe-                                 (putList input)-                                 (mapSplit s sink))-                     getList)-   where mapSplit :: forall a d. AncestorFunctor a d =>-                     SplitterComponent Identity x b -> Sink Identity a (Either (x, Bool) b) -> Source Identity d x-                  -> Coroutine d Identity ()-         mapSplit s sink source = let sink' = liftSink sink :: Sink Identity d (Either (x, Bool) b)-                                  in split (with s) source-                                        (mapSink (Left . (\x-> (x, True))) sink')-                                        (mapSink (Left . (\x-> (x, False))) sink')-                                        (mapSink Right sink')--splitterOutputChunks :: SplitterComponent Identity x b -> [x] -> [([x], Bool)]-splitterOutputChunks s input = transducerOutput (foreach s-                                                 (group >-> atomic "true" 1 (oneToOneTransducer (\chunk-> (chunk, True))))-                                                 (group >-> atomic "true" 1 (oneToOneTransducer (\chunk-> (chunk, False)))))-                               input--simpleSplitterFromTrace :: SimpleSplitterTrace -> SplitterComponent Identity x ()-simpleSplitterFromTrace (init, last) = splitterFromTrace (fmap Just init, last)--splitterFromTrace :: SplitterTrace -> SplitterComponent Identity x ()-splitterFromTrace trace = atomic "splitterFromTrace" 1 (splitterFromTrace' trace)--splitterFromTrace' :: SplitterTrace -> Splitter Identity x ()-splitterFromTrace' trace1-   = Splitter $-     \source true false edge->-     let follow previous trace2@(head:tail) q = get source >>= maybe fail succeed-            where succeed x = let q' = q |> x-                              in case head-                                 of Nothing -> follow previous tail q'-                                    Just Nothing -> when (not previous) (put edge ())-                                                    >> follow False tail q'-                                    Just (Just True) -> when (not previous) (put edge ())-                                                        >> putList (Foldable.toList (Seq.viewl q')) true-                                                        >> follow True tail Seq.empty-                                    Just (Just False) -> putList (Foldable.toList (Seq.viewl q')) false-                                                         >> follow False tail Seq.empty-                  fail = if find (maybe False isJust) trace2 == Just (Just (Just True))-                         then do when (not previous) (put edge ())-                                 putList (Foldable.toList (Seq.viewl q)) true-                         else putList (Foldable.toList (Seq.viewl q)) false-     in follow False (cycle (fst trace1 ++ [Just (Just $ snd trace1)])) Seq.empty -        >> return ()--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 (Maybe Bool)], Bool)--data TestEnum = One | Two | Three | Four | Five deriving (Enum, Eq, Show)--newtype Identifier = Identifier (NonEmptyList LowercaseLetter) deriving (Eq, Show)--newtype LowercaseLetter = LowercaseLetter{letterChar:: Char} deriving (Eq, Show)--instance Arbitrary TestEnum where-   arbitrary = oneof (map return [One, Two, Three, Four, Five])-instance CoArbitrary TestEnum where-   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 Identifier where-    arbitrary     = sized (\size-> fmap Identifier $ resize (size `mod` 50) arbitrary)--instance Arbitrary LowercaseLetter where-    arbitrary     = fmap LowercaseLetter (choose ('a', 'z'))-instance CoArbitrary LowercaseLetter where-    coarbitrary (LowercaseLetter c) = variant ((ord c - 65) `rem` 26)--instance Arbitrary c => Arbitrary (Component c) where-   arbitrary = fmap (atomic "Arbitrary" 1) arbitrary-instance CoArbitrary c => CoArbitrary (Component c) where-   coarbitrary c = coarbitrary (with c)--instance Arbitrary (Splitter Identity Int ()) where-   arbitrary = fmap splitterFromTrace' arbitrary-instance CoArbitrary (Splitter Identity Int ()) where-   coarbitrary s gen = sized (\n-> coarbitrary (transducerOutput' (Combinator.ifs sequentialBinder s-                                                                   (oneToOneTransducer $ const True)-                                                                   (oneToOneTransducer $ const False))-                                                [1..n]) gen)

@@ -0,0 +1,631 @@+{- +    Copyright 2008-2010 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 FlexibleInstances, ScopedTypeVariables #-}++module Main where++import Control.Concurrent.Configuration+import Control.Monad.Coroutine+import Control.Concurrent.SCC.Streams+import Control.Concurrent.SCC.Types+import qualified Control.Concurrent.SCC.Combinators as Combinator+import Control.Concurrent.SCC.Configurable hiding ((&&), (||))+import qualified Control.Concurrent.SCC.XML as XML+import qualified Control.Concurrent.SCC.Configurable as C++import Control.Monad (liftM, when)+import Data.Char (ord, isLetter, isSpace, toUpper)+import Data.Either (rights)+import Data.Functor.Identity (Identity (Identity, runIdentity))+import Data.List (find, findIndices, groupBy, intersect, union,+                  intercalate, isInfixOf, isPrefixOf, isSuffixOf, nub, sort, tails)+import Data.Maybe (fromJust, isJust, mapMaybe)+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, id, last)+import qualified Prelude+import Test.QuickCheck (Arbitrary, Gen, Property, CoArbitrary,+                        Positive(Positive), NonNegative(NonNegative), NonEmptyList(NonEmpty),+                        arbitrary, coarbitrary, label, classify, choose, mapSize, oneof, resize, sized,+                        quickCheck, variant, (==>))+++sublists [] _ = []+sublists _ [] = []+sublists sublist input = map+                           (input !!)+                           (nub $ sort $ concatMap+                                            (\n-> [n .. n + length sublist - 1])+                                            (findIndices (isPrefixOf sublist) (tails input)))++contentIn :: [Markup y x] -> [x]+contentIn = mapMaybe (\x-> case x of {Content y -> Just y; _ -> Nothing})++both f (x, y) = (f x, f y)++main = mapM_ quickCheck tests++tests = [label "pipe" $ \(input :: [Int])-> runCoroutine (pipe (putList input) getList) == Just ([], input),+         label "pour" prop_pour,+         label "id" prop_id,+         label "suppress" prop_suppress,+         label "substitute" prop_substitute,+         label "prepend" prop_prepend,+         label "append" prop_append,+         label "everything" prop_allTrue,+         label "nothing" prop_allFalse,+         label "substring" prop_substring,+         label "group" prop_group,+         label "concatenate" prop_concatenate,+         label "concatSeparate" prop_concatSeparate,+         label "uppercase ->>" $ \s-> runCoroutine (pipe+                                                        (putList s)+                                                        (consume $ with $+                                                         uppercase >-> atomic "getList" 1 (Consumer getList)))+                  == Just ([], map toUpper s),+         label "uppercase <<-" $ \s-> runCoroutine (pipe+                                                        (produce $ with $+                                                         atomic "putList" 1 (Producer (putList s)) >-> uppercase)+                                                        getList)+                  == Just ([], map toUpper s),+         label "uppercase `join` id" $ \s-> transducerOutput (uppercase `join` id) s == map toUpper s ++ s,+         label "prepend >-> append" (\(s :: String) prefix suffix->+                                     transducerOutput (prepend (fromList prefix) >-> append (fromList suffix)) s+                                     == prefix ++ s ++ suffix),+         label "prepend == (`join` id) . substitute" $+               \(s :: String) prefix-> transducerOutput (prepend (fromList prefix)) s+                                       == transducerOutput (substitute (fromList prefix) `join` id) s,+         label "append == (id `join`) . substitute" $+               \(s :: String) suffix-> transducerOutput (append (fromList suffix)) s+                                       == transducerOutput (id `join` substitute (fromList suffix)) s,+         label "whitespace" $ \s-> splitterOutputs whitespace s == (filter isSpace s, filter (not . isSpace) s),+         label "ifs everything id id" $ \(s :: [TestEnum])-> transducerOutput (ifs everything id id) s == s,+         label "substring" $ \s (c :: TestEnum)-> splitterOutputs (substring [c]) s == (filter (==c) s, filter (/=c) s),+         label "line" $ \words-> let words' = map (map letterChar) words+                                 in splitterOutputs line (unlines words') +                                    == (concat words', replicate (length words) '\n'),+         label "ifs (substring X) uppercase id" $+               \s (LowercaseLetter c)-> transducerOutput (ifs (substring [c]) uppercase id) s+                                        == map (\x-> if x == c then toUpper x else x) s,+         label "parseSubstring" $ \s (c :: TestEnum)-> transducerOutput+                                                          (parseSubstring [c] >-> select markedContent >-> unparse)+                                                          s+                                                       == filter (==c) s,+         label "uppercase `wherever` parseSubstring" $+               \s (LowercaseLetter c)-> transducerOutput+                                           (parseSubstring [c]+                                            >-> (uppercaseContent `wherever` markedContent)+                                            >-> unparse)+                                           s+                                        == map (\x-> if x == c then toUpper x else x) s,+         label "parseRegions substring == parseSubstring" prop_substringVsParse,+         label "count >-> toString >-> concatenate" $+               \(s :: [TestEnum])-> transducerOutput (count >-> toString >-> concatenate) s == show (length s),+         label "foreach whitespace id (prepend \"[\" >-> append \"]\")" $+               \s-> transducerOutput (foreach whitespace id (prepend (fromList "[") >-> append (fromList "]"))) s+                    == mapWords (("[" ++) . (++ "]")) s,+         label "foreach whitespace id (count >-> toString >-> concatenate)" $+               \s-> transducerOutput (foreach whitespace id (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 ==> classify (not (s1 `isInfixOf` s2)) "trivial" $+                  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) id)"+                  (transducerOutput (foreach letters (count >-> toString >-> concatenate) id) "Hola, Mundo!" == "4, 5!"),+         label "(foreach (letters `having` prefix (substring \"H\")) uppercase id)"+                  (transducerOutput (foreach+                                        (letters `having` prefix (substring "H"))+                                        uppercase+                                        id)+                      "Hello, World! Hola, Mundo!"+                   == "HELLO, World! HOLA, Mundo!"),+         label "(foreach (letters `having` suffix (substring \"o\")) uppercase id)"+                  (transducerOutput (foreach+                                        (letters `having` suffix (substring "o"))+                                        uppercase+                                        id)+                      "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 "followedBy startOf everything" $ \trace n-> prop_followedBy2 (splitterFromTrace trace) n,+         label "substring followedBy substring 1" prop_followedBy3,+         label "substring followedBy substring 2" prop_followedBy4,+         label "substring followedBy substring 3" prop_followedBy5,+         label "endOf followedBy U followedBy startOf"+                  $ \trace1 trace2 n-> prop_followedBy6 (splitterFromTrace trace1) (splitterFromTrace trace2) n,+         label "... followedBy ..." prop_followedByBetween,+         label "start ... end"  $ \trace n-> prop_between1 (simpleSplitterFromTrace trace) n,+         label "start everything ... end"  $ \trace n-> prop_between2 (simpleSplitterFromTrace trace) n,++         label "XML.tokens" prop_XMLtokens1,+         label "XML.tokens with attributes" prop_XMLtokens2,+         label "XML.parseTokens >-> select elementContent >-> unparse" prop_XMLtokens3,+         label "XML.parseTokens >-> unparse" prop_XMLtokens4,+         label "nestedIn XML.elementContent" $ mapSize (min 40) prop_nestedInXMLcontent,+         label "select XML.elementContent while XML.element" $ mapSize (min 50) prop_whileXMLelement]+++prop_pour :: [Int] -> Bool+prop_pour input = runCoroutine (pipe (putList input) (\source-> pipe (\sink-> pour source sink) getList))+                  == Just ([], ((), input))++prop_id :: [Int] -> Bool+prop_id input = transducerOutput id input == input++prop_suppress :: [Int] -> Bool+prop_suppress input = null (transducerOutput (consumeBy suppress :: TransducerComponent Identity Int ()) input)++prop_substitute :: [Int] -> [Maybe Int] -> Bool+prop_substitute input replacement = transducerOutput (substitute $ fromList replacement) input == replacement++prop_prepend :: [Int] -> [Int] -> Int -> Property+prop_prepend input prefix threads = threads > 0 ==>+                                    transducerOutput (usingThreads (prepend $ fromList prefix) threads) input+                                    == prefix ++ input++prop_append :: [Int] -> [Int] -> Int -> Property+prop_append input suffix threads = threads > 0 ==>+                                   transducerOutput (usingThreads (append $ fromList suffix) threads) input+                                   == input ++ suffix++prop_allTrue :: [Int] -> Bool+prop_allTrue input = splitterOutputs everything input == (input, [])++prop_allFalse :: [Int] -> Bool+prop_allFalse input = splitterOutputs nothing input == ([], input)++prop_substring :: [TestEnum] -> [TestEnum] -> Property+prop_substring input sublist = classify (not (isInfixOf sublist input)) "trivial"+                                  (transducerOutput (select (substring sublist)) input == sublists sublist input)++prop_substringVsParse :: [TestEnum] -> [TestEnum] -> Property+prop_substringVsParse input sublist = not (null sublist) && length sublist < length input+                                      && not (sublist `isInfixOf` (tail sublist ++ init sublist))+                                      ==> classify (not (sublist `isInfixOf` input)) "trivial"+                                             (transducerOutput (parseRegions (substring sublist)) input+                                              == map unitFromOccurrence (transducerOutput (parseSubstring sublist) input))+   where unitFromOccurrence (Content x) = Content x+         unitFromOccurrence (Markup b) = Markup (fmap (const ()) b)++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 :: SplitterComponent Identity Int () -> [Int] -> Bool+prop_snot splitter input = splitterOutputs (snot splitter) input == swap (splitterOutputs splitter input)++prop_andAssoc :: SplitterTrace -> SplitterTrace -> SplitterTrace -> [Int] -> Int -> Int -> Property+prop_andAssoc st1 st2 st3 input t1 t2+   = t1 > 0 && t2 > 0+     ==> splitterOutputs (usingThreads (s1 C.&& (s2 C.&& s3)) t1) input+      == splitterOutputs (usingThreads ((s1 C.&& s2) C.&& s3) t2) input+   where s1 = splitterFromTrace st1+         s2 = splitterFromTrace st2+         s3 = splitterFromTrace st3++prop_orAssoc :: SplitterTrace -> SplitterTrace -> SplitterTrace -> [Int] -> Int -> Int -> Property+prop_orAssoc st1 st2 st3 input t1 t2+   = t1 > 0 && t2 > 0+     ==> splitterOutputs (usingThreads (s1 C.|| (s2 C.|| s3)) t1) input+      == splitterOutputs (usingThreads ((s1 C.|| s2) C.|| s3) t2) input+   where s1 = splitterFromTrace st1+         s2 = splitterFromTrace st2+         s3 = splitterFromTrace st3++prop_DeMorgan1 :: SplitterComponent Identity Int () -> SplitterComponent Identity Int () -> [Int]+               -> Positive Int -> Positive Int -> Bool+prop_DeMorgan1 s1 s2 input (Positive t1) (Positive t2)+   = splitterOutputs (usingThreads (snot (s1 C.&& s2)) (t1 `mod` 50)) input+      == splitterOutputs (usingThreads (snot s1 C.|| snot s2) (t2 `mod` 50)) input++prop_DeMorgan2 :: SplitterComponent Identity Int () -> SplitterComponent Identity Int () -> [Int]+               -> Positive Int -> Positive Int -> Bool+prop_DeMorgan2 s1 s2 input (Positive t1) (Positive t2)+   = splitterOutputs (usingThreads (snot (s1 C.|| s2)) (t1 `mod` 50)) input+     == splitterOutputs (usingThreads (snot s1 C.&& snot s2) (t2 `mod` 50)) input++prop_and :: SplitterComponent Identity Int () -> SplitterComponent Identity Int () -> Positive Int -> Bool+prop_and s1 s2 (Positive n) = fst (splitterOutputs (s1 C.&& s2) l)+                              == fst (splitterOutputs s1 l) `intersect` fst (splitterOutputs s2 l)+   where l = [1 .. n `mod` 1000]++prop_or :: SplitterComponent Identity Int () -> SplitterComponent Identity Int () -> Positive Int -> Bool+prop_or s1 s2 (Positive n) = fst (splitterOutputs (s1 C.|| s2) l)+                             == sort (fst (splitterOutputs s1 l) `union` fst (splitterOutputs s2 l))+   where l = [1 .. n `mod` 1000]++prop_even :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool+prop_even splitter input = let splitOddEven [] = ([], [])+                               splitOddEven (head:tail) = let (evens, odds) = splitOddEven tail in (head:odds, evens)+                           in fst (splitterOutputs (even splitter) input)+                              == concat (snd $ splitOddEven $+                                         transducerOutput (foreach splitter group (consumeBy suppress)) input)++prop_prefix_1 :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool+prop_prefix_1 splitter input = let (pfx, rest) = splitterOutputs (prefix splitter) input+                                   (true, false) = splitterOutputs splitter input+                               in pfx ++ rest == input && pfx `isPrefixOf` true++prop_prefix_2 :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool+prop_prefix_2 splitter input = let (prefix1, rest1) = splitterOutputs (prefix splitter) input+                               in case splitterOutputChunks splitter input+                                  of (prefix2, True):rest2 -> prefix1 == prefix2 && rest1 == concat (map fst rest2)+                                     (prefix2, False):rest2 -> prefix1 == [] && rest1 == prefix2 ++ concat (map fst rest2)+                                     [] -> prefix1 ++ rest1 == []++prop_suffix_1 :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool+prop_suffix_1 splitter input = let (sfx, rest) = splitterOutputs (suffix splitter) input+                                   (true, false) = splitterOutputs splitter input+                               in rest ++ sfx == input && sfx `isSuffixOf` true++prop_suffix_2 :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool+prop_suffix_2 splitter input = let (suffix1, rest1) = splitterOutputs (suffix splitter) input+                               in case reverse (splitterOutputChunks splitter input)+                                  of (suffix2, True):rest2 -> suffix1 == suffix2+                                                              && rest1 == concat (map fst (reverse rest2))+                                     (suffix2, False):rest2 -> suffix1 == []+                                                               && rest1 == concat (map fst (reverse rest2)) ++ suffix2+                                     [] -> rest1 ++ suffix1 == []++prop_first :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool+prop_first splitter input = let (first1, rest1) = splitterOutputs (first splitter) input+                            in case splitterOutputChunks splitter input+                               of (first2, True):rest2 -> first1 == first2 && rest1 == concat (map fst rest2)+                                  (prefix, False):(first2, True):rest2 -> first1 == first2+                                                                          && rest1 == prefix ++ concat (map fst rest2)+                                  (prefix, False):[] -> first1 == [] && rest1 == prefix+                                  [] -> first1 ++ rest1 == []++prop_last :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool+prop_last splitter input = let (last1, rest1) = splitterOutputs (last splitter) input+                           in -- trace (show (last1, rest1)) $ trace (show (splitterOutputChunks splitter input)) $+                              case reverse (splitterOutputChunks splitter input)+                              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 :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool+prop_uptoFirst splitter input = let (first1, rest1) = splitterOutputs (uptoFirst splitter) input+                                in case splitterOutputChunks splitter input+                                   of (first2, True):rest2 -> first1 == first2 && rest1 == concat (map fst rest2)+                                      (prefix, False):(first2, True):rest2 -> first1 == prefix ++ first2+                                                                              && rest1 == concat (map fst rest2)+                                      (prefix, False):[] -> first1 == [] && rest1 == prefix+                                      [] -> first1 ++ rest1 == []++prop_lastAndAfter :: SplitterComponent Identity TestEnum () -> [TestEnum] -> Bool+prop_lastAndAfter splitter input = let (last1, rest1) = splitterOutputs (lastAndAfter splitter) input+                                   in case reverse (splitterOutputChunks splitter input)+                                      of (last2, True):rest2 -> last1 == last2 && rest1 == concat (map fst (reverse rest2))+                                         (suffix, False):(last2, True):rest2 -> last1 == last2 ++ suffix+                                                                                && rest1 == concat (map fst (reverse rest2))+                                         (suffix, False):[] -> last1 == [] && rest1 == suffix+                                         [] -> last1 ++ rest1 == []++prop_followedBy1 :: SplitterComponent Identity Int () -> SplitterComponent Identity Int () -> Positive Int -> Bool+prop_followedBy1 s1 s2 (Positive n) = splitterOutputs (s1 `followedBy` s2) l+                                      == splitterOutputs (s1 `followedBy` prefix s2) l+   where l = [1 .. n `mod` 300]++prop_followedBy2 :: SplitterComponent Identity Int () -> Int -> Bool+prop_followedBy2 s n = splitterOutputs (s `followedBy` startOf everything) l == splitterOutputs s l+   where l = [1 .. n `mod` 300]++prop_followedBy3 :: [TestEnum] -> [TestEnum] -> [TestEnum] -> Property+prop_followedBy3 l1 l2 l3 = classify (not (isInfixOf l1 l3)) "trivial" $+                            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+                            ==> classify (not (isInfixOf (l1 ++ l2) l3)) "trivial" $+                                fst (splitterOutputs (substring l1 `followedBy` substring l2) l3) == sublists (l1 ++ l2) l3++prop_followedBy5 :: Positive Int -> NonNegative Int -> Positive Int -> NonNegative Int -> Bool+prop_followedBy5 (Positive i1) (NonNegative i2) (Positive i3) (NonNegative i4) =+   let n1 = i1 `mod` 1000+       n2 = n1 + i2 `mod` 100+       n3 = n2 + i3 `mod` 100+       n4 = n3 + i4 `mod` 100+   in splitterOutputs (substring [n1 .. n2] `followedBy` substring [n2 + 1 .. n3]) [0 .. n4]+         == ([n1 .. n3], [0 .. n1 - 1] ++ [n3 + 1 .. n4])++prop_followedBy6 :: SplitterComponent Identity Int () -> SplitterComponent Identity Int () -> Positive Int -> Bool+prop_followedBy6 s1 s2 (Positive n) = sort (fst (splitterOutputs (endOf s1 `followedBy` s2) l)+                                            `union` fst (splitterOutputs (s1 `followedBy` startOf s2) l))+                                      == fst (splitterOutputs (s1 `followedBy` s2) l)+   where l = [1 .. n `mod` 500]++prop_followedByBetween :: Positive Int -> NonNegative Int -> Positive Int -> NonNegative Int -> Bool+prop_followedByBetween (Positive i1) (NonNegative i2) (Positive i3) (NonNegative i4) =+   let n1 = i1 `mod` 500+       n2 = n1 + i2 `mod` 500+       n3 = n2 + i3 `mod` 500 + 1+       n4 = n3 + i4 `mod` 500+   in splitterOutputs+         ((substring [n1] ... substring [n2]) `followedBy` (substring [n2 + 1] ... substring [n3]))+         [0 .. n4]+      == ([n1 .. n3], [0 .. n1 - 1] ++ [n3 + 1 .. n4])++prop_between1 :: SplitterComponent Identity Int () -> Positive Int -> Bool+prop_between1 splitter (Positive n) =+   splitterOutputs (startOf splitter ... endOf splitter) input == splitterOutputs splitter input+   && splitterOutputs (endOf splitter ... startOf splitter) input == ([], input)+   where input = [1 .. n `mod` 500]++prop_between2 :: SplitterComponent Identity Int () -> Positive Int -> Bool+prop_between2 splitter (Positive n) = splitterOutputs (startOf everything ... endOf splitter) input+                                      == splitterOutputs (uptoFirst splitter) input+                                      || null (fst $ splitterOutputs splitter input)+   where input = [1 .. n `mod` 500]++prop_XMLtokens1 :: [LowercaseLetter] -> String -> Property+prop_XMLtokens1 name content = name /= [] && intersect content "<&" == []+                               ==> splitterOutputs xmlTokens (start ++ content ++ end) == (start ++ end, content)+   where name' = map letterChar name+         start = "<" ++ name' ++ ">"+         end = "</" ++ name' ++ ">"++prop_XMLtokens2 :: [LowercaseLetter] -> [(Identifier, String)] -> String -> Property+prop_XMLtokens2 name attrs content = name /= [] && all validAttribute attrs && intersect content "<&" == []+                                     ==> splitterOutputs xmlTokens (start ++ content ++ end)+                                            == (start ++ end, content)+   where name' = map letterChar name+         start = "<" ++ name' ++ concatMap attribute attrs ++ ">"+         end = "</" ++ name' ++ ">"++prop_XMLtokens3 :: [LowercaseLetter] -> Bool -> [(Identifier, String)] -> String -> Property+prop_XMLtokens3 name ws attrs content = name /= [] && all validAttribute attrs && intersect content "<&" == []+                                        ==> transducerOutput+                                               (xmlParseTokens >-> select xmlElementContent >-> unparse >-> coerce)+                                               (start ++ content ++ end)+                                               == content+   where name' = map letterChar name ++ spaces+         spaces = if ws then "\n\t  " else ""+         start = "<" ++ name' ++ List.intercalate spaces (map attribute attrs) ++ ">"+         end = "</" ++ name' ++ ">"++prop_XMLtokens4 :: NonEmptyList LowercaseLetter -> [(Identifier, String)] -> String -> Bool+prop_XMLtokens4 (NonEmpty name) attrs content =+   transducerOutput (xmlParseTokens >-> unparse >-> coerce) input == input+   where name' = map letterChar name+         start = "<" ++ name' ++ concatMap attribute attrs ++ ">"+         end = "</" ++ name' ++ ">"+         content' = concatMap escapeContentCharacter content+         input = start ++ content' ++ end++prop_nestedInXMLcontent :: [Either (Identifier, [(Identifier, String)]) String] -> Bool+prop_nestedInXMLcontent startTagsAndContent = transducerOutput+                                                 (xmlParseTokens+                                                  >-> select (snot xmlElement `nestedIn` xmlElementContent)+                                                  >-> unparse >-> coerce)+                                                 (nestXMLelements startTagsAndContent)+                                              == concatMap escapeContentCharacter (concat (rights startTagsAndContent))++prop_whileXMLelement :: [Either (Identifier, [(Identifier, String)]) String] -> Bool+prop_whileXMLelement startTagsAndContent = transducerOutput+                                              (xmlParseTokens+                                               >-> (select xmlElementContent `while` xmlElement)+                                               >-> unparse >-> coerce)+                                              (nestXMLelements startTagsAndContent)+                                           == concatMap escapeContentCharacter (concat (rights startTagsAndContent))++nestXMLelements [] = []+nestXMLelements (Left (Identifier (NonEmpty name), attrs) : rest) = "<" ++ name' ++ concatMap attribute attrs ++ ">"+                                                                    ++ nestXMLelements rest ++ "</" ++ name' ++ ">"+   where name' = map letterChar name+nestXMLelements (Right content : rest) = concatMap escapeContentCharacter content ++ nestXMLelements rest++attribute (Identifier (NonEmpty name), value) =+   " " ++ map letterChar name ++ "=\"" ++ concatMap escapeAttributeCharacter value ++ "\""+validAttribute (Identifier (NonEmpty name), value) = name /= [] && intersect value "<&\"" == []++-- | Escapes a character for inclusion into an XML attribute value.+escapeAttributeCharacter :: Char -> String+escapeAttributeCharacter '"' = "&quot;"+escapeAttributeCharacter '\t' = "&#9;"+escapeAttributeCharacter '\n' = "&#10;"+escapeAttributeCharacter '\r' = "&#13;"+escapeAttributeCharacter x = escapeContentCharacter x++-- | Escapes a character for inclusion into the XML data content.+escapeContentCharacter :: Char -> String+escapeContentCharacter '<' = "&lt;"+escapeContentCharacter '&' = "&amp;"+escapeContentCharacter x = [x]++uppercaseContent :: (Functor f, Monad m) => TransducerComponent m (f Char) (f Char)+uppercaseContent = atomic "uppercase" 1 (oneToOneTransducer $ fmap toUpper)++transducerOutput :: TransducerComponent Identity x y -> [x] -> [y]+transducerOutput t = transducerOutput' (with t)++transducerOutput' :: Transducer Identity x y -> [x] -> [y]+transducerOutput' t input = case runCoroutine (pipe+                                                   (putList input)+                                                   (\source-> pipe+                                                                 (\sink-> transduce t source sink)+                                                                 getList))+                           of Identity (_, (_, output)) -> output++splitterOutputs :: SplitterComponent Identity x b -> [x] -> ([x], [x])+splitterOutputs s input = +   case runCoroutine (pipe+                         (putList input)+                         (\source-> +                           pipe +                              (\true-> +                                pipe+                                   (\false-> +                                     pipe+                                        (\edge-> split (with s) source true false edge)+                                        (mapMStream_ (const $ return ())))+                                   getList)+                              getList))+   of Identity (_, ((_, false), true)) -> (true, false)++splitterUnifiedOutput :: forall x b. SplitterComponent Identity x b -> [x] -> [Either (x, Bool) b]+splitterUnifiedOutput s input =+   snd $ runIdentity $+   runCoroutine (pipe+                     (\sink-> pipe+                                 (putList input)+                                 (mapSplit s sink))+                     getList)+   where mapSplit :: forall a d. AncestorFunctor a d =>+                     SplitterComponent Identity x b -> Sink Identity a (Either (x, Bool) b) -> Source Identity d x+                  -> Coroutine d Identity ()+         mapSplit s sink source = let sink' = liftSink sink :: Sink Identity d (Either (x, Bool) b)+                                  in split (with s) source+                                        (mapSink (Left . (\x-> (x, True))) sink')+                                        (mapSink (Left . (\x-> (x, False))) sink')+                                        (mapSink Right sink')++splitterOutputChunks :: SplitterComponent Identity x b -> [x] -> [([x], Bool)]+splitterOutputChunks s input = transducerOutput (foreach s+                                                 (group >-> atomic "true" 1 (oneToOneTransducer (\chunk-> (chunk, True))))+                                                 (group >-> atomic "true" 1 (oneToOneTransducer (\chunk-> (chunk, False)))))+                               input++simpleSplitterFromTrace :: SimpleSplitterTrace -> SplitterComponent Identity x ()+simpleSplitterFromTrace (init, last) = splitterFromTrace (fmap Just init, last)++splitterFromTrace :: SplitterTrace -> SplitterComponent Identity x ()+splitterFromTrace trace = atomic "splitterFromTrace" 1 (splitterFromTrace' trace)++splitterFromTrace' :: SplitterTrace -> Splitter Identity x ()+splitterFromTrace' trace1+   = Splitter $+     \source true false edge->+     let follow previous trace2@(head:tail) q = get source >>= maybe fail succeed+            where succeed x = let q' = q |> x+                              in case head+                                 of Nothing -> follow previous tail q'+                                    Just Nothing -> when (not previous) (put edge ())+                                                    >> follow False tail q'+                                    Just (Just True) -> when (not previous) (put edge ())+                                                        >> putList (Foldable.toList (Seq.viewl q')) true+                                                        >> follow True tail Seq.empty+                                    Just (Just False) -> putList (Foldable.toList (Seq.viewl q')) false+                                                         >> follow False tail Seq.empty+                  fail = if find (maybe False isJust) trace2 == Just (Just (Just True))+                         then do when (not previous) (put edge ())+                                 putList (Foldable.toList (Seq.viewl q)) true+                         else putList (Foldable.toList (Seq.viewl q)) false+     in follow False (cycle (fst trace1 ++ [Just (Just $ snd trace1)])) Seq.empty +        >> return ()++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 (Maybe Bool)], Bool)++data TestEnum = One | Two | Three | Four | Five deriving (Enum, Eq, Show)++newtype Identifier = Identifier (NonEmptyList LowercaseLetter) deriving (Eq, Show)++newtype LowercaseLetter = LowercaseLetter{letterChar:: Char} deriving (Eq, Show)++instance Arbitrary TestEnum where+   arbitrary = oneof (map return [One, Two, Three, Four, Five])+instance CoArbitrary TestEnum where+   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 Identifier where+    arbitrary     = sized (\size-> fmap Identifier $ resize (size `mod` 50) arbitrary)++instance Arbitrary LowercaseLetter where+    arbitrary     = fmap LowercaseLetter (choose ('a', 'z'))+instance CoArbitrary LowercaseLetter where+    coarbitrary (LowercaseLetter c) = variant ((ord c - 65) `rem` 26)++instance Arbitrary c => Arbitrary (Component c) where+   arbitrary = fmap (atomic "Arbitrary" 1) arbitrary+instance CoArbitrary c => CoArbitrary (Component c) where+   coarbitrary c = coarbitrary (with c)++instance Arbitrary (Splitter Identity Int ()) where+   arbitrary = fmap splitterFromTrace' arbitrary+instance CoArbitrary (Splitter Identity Int ()) where+   coarbitrary s gen = sized (\n-> coarbitrary (transducerOutput' (Combinator.ifs sequentialBinder s+                                                                   (oneToOneTransducer $ const True)+                                                                   (oneToOneTransducer $ const False))+                                                [1..n]) gen)

@@ -68,5 +68,6 @@    | "XML.attribute-value"    | "XML.element-content"    | "XML.element-name"+   | "XML.element-having-tag-with"    | "{" [String {"," String}] "}"    | NativeCommand.

@@ -1,5 +1,5 @@ Name:                scc-Version:             0.6.1+Version:             0.7 Cabal-Version:       >= 1.2 Build-Type:          Simple Synopsis:            Streaming component combinators@@ -14,28 +14,44 @@   The original library design is based on paper <http://conferences.idealliance.org/extreme/html/2006/Blazevic01/EML2006Blazevic01.html>   .   Mario Bla&#382;evi&#263;, Streaming component combinators, Extreme Markup Languages, 2006.-  + License:             GPL License-file:        LICENSE.txt-Copyright:           (c) 2008-2010 Mario Blazevic+Copyright:           (c) 2008-2011 Mario Blazevic Author:              Mario Blazevic Maintainer:          blamario@yahoo.com Homepage:            http://trac.haskell.org/SCC/-Extra-source-files:  grammar.bnf Makefile LICENSE.txt Test.hs+Extra-source-files:  grammar.bnf Makefile -- Source-repository head --   type:              darcs --   location:          http://code.haskell.org/SCC/+Flag Test+  Description: Install QuickCheck test suite+  Default:     False  Executable shsh   Main-is:           Shell.hs   Other-Modules:     Control.Concurrent.SCC.Streams, Control.Concurrent.SCC.Types, Control.Concurrent.SCC.Coercions,                      Control.Concurrent.SCC.Combinators, Control.Concurrent.SCC.Primitives, Control.Concurrent.SCC.XML,                      Control.Concurrent.Configuration, Control.Concurrent.SCC.Configurable-  Build-Depends:     base < 5, containers, transformers >= 0.2 && < 0.3, monad-parallel,-                     monad-coroutine >= 0.6 && < 0.7, bytestring < 1.0, text < 1.0,+  Build-Depends:     base < 5, containers, transformers >= 0.2 && < 0.3, incremental-parser >= 0.1 && < 0.2,+                     monad-parallel, monad-coroutine >= 0.7 && < 0.8, bytestring < 1.0, text < 1.0,                      process, readline, parsec >= 3.0 && < 4.0   GHC-options:       -threaded +Executable test-scc+  Main-is:           Test/TestSCC.hs+  Other-Modules:     Control.Concurrent.SCC.Streams, Control.Concurrent.SCC.Types, Control.Concurrent.SCC.Coercions,+                     Control.Concurrent.SCC.Combinators, Control.Concurrent.SCC.Primitives,+                     Control.Concurrent.SCC.XML,+                     Control.Concurrent.Configuration, Control.Concurrent.SCC.Configurable+  Build-Depends:     base < 5, containers, transformers >= 0.2 && < 0.3, incremental-parser < 0.2,+                     monad-parallel, monad-coroutine >= 0.7 && < 0.8, bytestring < 1.0, text < 1.0,+                     QuickCheck >= 2 && < 3+  GHC-options:       -threaded+  if !flag(test)+    buildable:       False+ Library   Exposed-Modules:   Control.Concurrent.Configuration, Control.Concurrent.SCC.Configurable,                      Control.Concurrent.SCC.Parallel, Control.Concurrent.SCC.Sequential@@ -43,6 +59,6 @@                      Control.Concurrent.SCC.Combinators.Parallel, Control.Concurrent.SCC.Combinators.Sequential,                      Control.Concurrent.SCC.Combinators, Control.Concurrent.SCC.Primitives, Control.Concurrent.SCC.XML                      -  Build-Depends:     base < 5, containers, transformers >= 0.2 && < 0.3, monad-parallel,-                     monad-coroutine >= 0.6 && < 0.7, bytestring < 1.0, text < 1.0+  Build-Depends:     base < 5, containers, transformers >= 0.2 && < 0.3, incremental-parser >= 0.1 && < 0.2,+                     monad-parallel, monad-coroutine >= 0.7 && < 0.8, bytestring < 1.0, text < 1.0   GHC-prof-options:  -auto-all