diff --git a/Control/Concurrent/SCC/Combinators.hs b/Control/Concurrent/SCC/Combinators.hs
--- a/Control/Concurrent/SCC/Combinators.hs
+++ b/Control/Concurrent/SCC/Combinators.hs
@@ -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
diff --git a/Control/Concurrent/SCC/Primitives.hs b/Control/Concurrent/SCC/Primitives.hs
--- a/Control/Concurrent/SCC/Primitives.hs
+++ b/Control/Concurrent/SCC/Primitives.hs
@@ -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
diff --git a/Control/Concurrent/SCC/Streams.hs b/Control/Concurrent/SCC/Streams.hs
--- a/Control/Concurrent/SCC/Streams.hs
+++ b/Control/Concurrent/SCC/Streams.hs
@@ -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]
diff --git a/Control/Concurrent/SCC/XML.hs b/Control/Concurrent/SCC/XML.hs
--- a/Control/Concurrent/SCC/XML.hs
+++ b/Control/Concurrent/SCC/XML.hs
@@ -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 "> put edge (Start ProcessingInstructionText)
- >> processingInstruction
- tag '!' = dispatchOnString source
- (\other-> put edge (Point (errorBadDeclarationType other)))
- [("--",
- const (put edge (Start Comment)
- >> putList "",
- \match-> put edge (End CommentText)
- >> putList match true
- >> put edge (End Comment)
- >> getContent)]
- markedSection = {-# SCC "> 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 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 "< 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 "< 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 ""
+ >< (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 "< 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 "< 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 \"' 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
diff --git a/Makefile b/Makefile
--- a/Makefile
+++ b/Makefile
@@ -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
diff --git a/Shell.hs b/Shell.hs
--- a/Shell.hs
+++ b/Shell.hs
@@ -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
diff --git a/Test.hs b/Test.hs
deleted file mode 100644
--- a/Test.hs
+++ /dev/null
@@ -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
- .
--}
-
-{-# 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 = ""
-
-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 = ""
-
-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 = ""
-
-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 = ""
- 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 ++ ""
- 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 '"' = """
-escapeAttributeCharacter '\t' = " "
-escapeAttributeCharacter '\n' = "
"
-escapeAttributeCharacter '\r' = "
"
-escapeAttributeCharacter x = escapeContentCharacter x
-
--- | Escapes a character for inclusion into the XML data content.
-escapeContentCharacter :: Char -> String
-escapeContentCharacter '<' = "<"
-escapeContentCharacter '&' = "&"
-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)
diff --git a/Test/TestSCC.hs b/Test/TestSCC.hs
new file mode 100644
--- /dev/null
+++ b/Test/TestSCC.hs
@@ -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
+ .
+-}
+
+{-# 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 = ""
+
+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 = ""
+
+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 = ""
+
+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 = ""
+ 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 ++ ""
+ 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 '"' = """
+escapeAttributeCharacter '\t' = " "
+escapeAttributeCharacter '\n' = "
"
+escapeAttributeCharacter '\r' = "
"
+escapeAttributeCharacter x = escapeContentCharacter x
+
+-- | Escapes a character for inclusion into the XML data content.
+escapeContentCharacter :: Char -> String
+escapeContentCharacter '<' = "<"
+escapeContentCharacter '&' = "&"
+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)
diff --git a/grammar.bnf b/grammar.bnf
--- a/grammar.bnf
+++ b/grammar.bnf
@@ -68,5 +68,6 @@
| "XML.attribute-value"
| "XML.element-content"
| "XML.element-name"
+ | "XML.element-having-tag-with"
| "{" [String {"," String}] "}"
| NativeCommand.
diff --git a/scc.cabal b/scc.cabal
--- a/scc.cabal
+++ b/scc.cabal
@@ -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
.
Mario Blažević, 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