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 @@ -807,18 +807,20 @@ (transduce t source) (\source-> let true' = mapSink fromContent true false' = mapSink fromContent false - topLevel = pourUntil isMarkup source false' + topLevel = pourWhile isContent source false' + >> get source >>= 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' + handleRegion = pourWhile isContent source true' + >> get source >>= maybe (return ()) (\x -> handleMarkup x >>= flip when handleRegion) in topLevel) >> return () - where isMarkup Markup{} = True - isMarkup Content{} = False + where isContent Markup{} = False + isContent Content{} = True fromContent (Content x) = x splittersToPairMarker :: forall m x b1 b2. Monad m => PairBinder m -> Splitter m x b1 -> Splitter m x b2 -> 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 @@ -115,8 +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 y. (AncestorFunctor a d, MonoidNull y) => - Parser [x] y -> Coroutine d m (y, Maybe (Parser [x] y)) + foldChunk :: forall d p y. (AncestorFunctor a d, MonoidNull y) => + Parser p [x] y -> Coroutine d m (y, Maybe (Parser p [x] y)) } -- | A disconnected sink that ignores all values 'put' into it. @@ -134,8 +134,8 @@ -- | 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 - :: forall y. MonoidNull y => - Parser [x] y -> Coroutine d m (y, Maybe (Parser [x] y)))} + :: forall p y. MonoidNull y => + Parser p [x] y -> Coroutine d m (y, Maybe (Parser p [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 @@ -160,9 +160,9 @@ where sink = Sink {putChunk= \xs-> if null xs then return [] else (liftAncestor (mapSuspension RightF (request xs) :: Coroutine a1 m [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))) + fc :: forall d p y. (AncestorFunctor a2 d, MonoidNull y) => + Parser p [x] y -> Coroutine d m (y, Maybe (Parser p [x] y)) + fc t = liftAncestor (mapSuspension RightF (requestParse t) :: Coroutine a2 m (y, Maybe (Parser p [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 @@ -188,7 +188,7 @@ getWith consumer source = get source >>= maybe (return ()) consumer -- | 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 :: forall m p a d x. (Monad m, AncestorFunctor a d) => Parser p [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 @@ -204,7 +204,7 @@ 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 (takeWhile (not . f . head) + where loop cont = foldChunk source (takeWhile (not . f . head) `andThen` lookAhead (fmap (First . Just . head) anyToken <<|> return (First Nothing))) >>= extract cont @@ -218,15 +218,15 @@ where loop = getChunk source >>= nullOrElse (return ()) ((>> loop) . putChunk sink) -- | 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) - => Parser [x] [x] -> Source m a1 x -> Sink m a2 x -> Coroutine d m () +pourTicked :: forall m p a1 a2 d x . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d) + => Parser p [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 :: forall m p a1 a2 d x y. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d) + => Parser p [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') 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 @@ -4,7 +4,7 @@ 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 + License as published by the Free Software Foundation, either version 3 of the License, or (at your moptional) any later version. SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty @@ -42,8 +42,10 @@ import Numeric (readDec, readHex) 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 Text.ParserCombinators.Incremental (Parser, more, feed, anyToken, satisfy, concatMany, takeWhile, takeWhile1, string, + moptional, skip, lookAhead, notFollowedBy, mapIncremental, (><)) +import qualified Text.ParserCombinators.Incremental.LeftBiasedLocal as LeftBiasedLocal (Parser) +import Text.ParserCombinators.Incremental.LeftBiasedLocal (leftmost) import Control.Monad.Coroutine (Coroutine, sequentialBinder) import Control.Concurrent.SCC.Streams @@ -83,11 +85,11 @@ _ -> XMLStream (l ++ r) XMLStream l `mappend` XMLStream r = XMLStream (l ++ r) -xmlParser :: Parser String XMLStream -xmlParser = many0 (xmlContent <|> xmlMarkup) +xmlParser :: LeftBiasedLocal.Parser String XMLStream +xmlParser = concatMany (xmlContent <|> xmlMarkup) where xmlContent = mapContent $ takeWhile1 (\x-> x /= "<" && x /= "&") xmlMarkup = (string "<" >> ((startTag <|> endTag <|> processingInstruction <|> declaration) - <<|> return (XMLStream [Markup $ Point errorUnescapedContentLT, + <|> return (XMLStream [Markup $ Point errorUnescapedContentLT, Content (singleton '<')]))) <|> entityReference "&" @@ -96,30 +98,30 @@ >< return (XMLStream [Markup (End ElementName)]) >< whiteSpace >< attributes - >< option (string "/" >> return (XMLStream [Markup (Point EmptyTag), Content (singleton '/')])) + >< moptional (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])) + <|> 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) + <|> return (XMLStream [Markup $ Point $ errorBadEntityReference, Content (pack s)])) + attributes = concatMany (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 "="))) + <|> (fmap (\x-> XMLStream [Markup $ Point $ errorBadAttribute x]) anyToken + >< whiteSpace >< moptional (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, + <|> (anyToken >>= \q-> return (XMLStream [Markup $ Point $ errorBadQuoteCharacter q, Content $ pack quote]))) endTag = (string "/" >> return (XMLStream [Markup (Start EndTag), Content (pack "< return (XMLStream [Markup (End ElementName)]) >< whiteSpace >< (string ">" >> return (XMLStream [Content (singleton '>'), Markup (End EndTag)]) - <<|> return (XMLStream [Markup $ Point unterminatedEndTag, Markup (End EndTag)])) + <|> return (XMLStream [Markup $ Point unterminatedEndTag, Markup (End EndTag)])) processingInstruction = (string "?" >> return (XMLStream [Markup (Start ProcessingInstruction), Content (pack "< (string "?>" >> return (XMLStream [Markup (End ProcessingInstructionText), Content (pack "?>"), Markup (End ProcessingInstruction)]) - <<|> return (XMLStream [Markup $ Point unterminatedProcessingInstruction])) + <|> return (XMLStream [Markup $ Point unterminatedProcessingInstruction])) declaration = string "!" >> ((comment <|> cdataMarkedSection <|> doctypeDeclaration) - <<|> return (XMLStream [Markup $ Point $ errorBadDeclarationType, Content (pack "<")])) + <|> 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])) + <|> return (XMLStream [Markup $ Point unterminatedComment])) cdataMarkedSection = (string "[CDATA[" >> return (XMLStream [Markup (Start StartMarkedSectionCDATA), Content (pack "< (string "]]>" >> return (XMLStream [Markup (Start EndMarkedSection), Content (pack "]]>"), Markup (End EndMarkedSection)]) - <<|> return (XMLStream [Markup $ Point unterminatedMarkedSection])) + <|> return (XMLStream [Markup $ Point unterminatedMarkedSection])) doctypeDeclaration = (string "DOCTYPE" >> return (XMLStream [Markup (Start DoctypeDeclaration), Content (pack "< whiteSpace >< (name >< whiteSpace - >< option ((mapContent (string "SYSTEM") + >< moptional ((mapContent (string "SYSTEM") <|> mapContent (string "PUBLIC") >< whiteSpace >< literal) >< whiteSpace >< literal >< whiteSpace) - >< option (mapContent (string "[") >< whiteSpace - >< many0 ((markupDeclaration <|> comment <|> processingInstruction + >< moptional (mapContent (string "[") >< whiteSpace + >< concatMany ((markupDeclaration <|> comment <|> processingInstruction <|> entityReference "%") >< whiteSpace) >< mapContent (string "]") >< whiteSpace) >< mapContent (string ">") - <<|> return (XMLStream [Markup (Point errorMalformedDoctypeDeclaration)])) + <|> return (XMLStream [Markup (Point errorMalformedDoctypeDeclaration)])) >< return (XMLStream [Markup (End DoctypeDeclaration)]) literal = (string "\"" <|> string "\'") >>= \quote-> return (XMLStream [Content $ pack quote]) @@ -175,13 +177,13 @@ >< return (XMLStream [Content $ pack quote]) >< skip (string quote) markupDeclaration= mapContent (string "< (many0 (mapContent (takeWhile1 (\x-> x /= ">" && x /= "\"" && x /= "\'")) <|> literal) + >< (concatMany (mapContent (takeWhile1 (\x-> x /= ">" && x /= "\"" && x /= "\'")) <|> literal) >< mapContent (string ">") - <<|> return (XMLStream [Markup $ Point unterminatedMarkupDeclaration])) + <|> 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)) + upto end@(lead:_) = mapContent (concatMany (takeWhile1 (/= [lead]) <|> notFollowedBy (string end) >< anyToken)) errorBadQuoteCharacter q = ErrorToken ("Invalid quote character " ++ show q) errorBadAttribute x = ErrorToken ("Invalid character " ++ show x ++ " following attribute name") diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -2,6 +2,7 @@ TestExecutables=$(addprefix test/, scc parallel benchmark-coroutine incremental-parser \ enumerator iteratee enumerator-scc) IterativeParserFiles=Text/ParserCombinators/Incremental.hs \ + Control/Applicative/Monoid.hs \ $(addprefix Data/Monoid/, Cancellative.hs Factorial.hs Null.hs) CoroutineLibraryFiles=$(IterativeParserFiles) Data/Functor/Contravariant/Ticker.hs \ $(addprefix Control/Monad/, \ @@ -17,34 +18,34 @@ DocumentationFiles=$(SCCCommonFiles) Control/Monad/Coroutine/Enumerator.hs Control/Monad/Coroutine/Iteratee.hs \ Control/Concurrent/SCC/Combinators/Parallel.hs Control/Concurrent/SCC/Combinators/Sequential.hs \ Control/Concurrent/SCC/Parallel.hs Control/Concurrent/SCC/Sequential.hs -OptimizingOptions=-O -threaded -hidir obj -odir obj -ProfilingOptions=-prof -auto-all -hidir prof -odir prof +OptimizingOptions=-O -threaded -fcontext-stack=30 -rtsopts -hidir obj -odir obj +ProfilingOptions=-prof -auto-all -rtsopts -hidir prof -odir prof all: $(Executables) doc/index.html docs: doc/index.html -test/scc: Test/TestSCC.hs $(AllLibraryFiles) | obj +test/scc: Test/TestSCC.hs $(AllLibraryFiles) | obj test ghc --make $< -o $@ $(OptimizingOptions) -test/benchmark-coroutine: Test/BenchmarkCoroutine.hs $(CoroutineLibraryFiles) | obj +test/benchmark-coroutine: Test/BenchmarkCoroutine.hs $(CoroutineLibraryFiles) | obj test ghc --make $< -o $@ $(OptimizingOptions) -eventlog -test/incremental-parser: Test/TestIncrementalParser.hs Text/ParserCombinators/Incremental.hs | obj +test/incremental-parser: Test/TestIncrementalParser.hs Text/ParserCombinators/Incremental.hs | obj test ghc --make $< -o $@ $(OptimizingOptions) -eventlog -test/enumerator: Test/TestEnumerator.hs $(CoroutineLibraryFiles) Control/Monad/Coroutine/Enumerator.hs | obj +test/enumerator: Test/TestEnumerator.hs $(CoroutineLibraryFiles) Control/Monad/Coroutine/Enumerator.hs | obj test ghc --make $< -o $@ $(OptimizingOptions) -eventlog -test/iteratee: Test/TestIteratee.hs $(CoroutineLibraryFiles) Control/Monad/Coroutine/Iteratee.hs | obj +test/iteratee: Test/TestIteratee.hs $(CoroutineLibraryFiles) Control/Monad/Coroutine/Iteratee.hs | obj test ghc --make $< -o $@ $(OptimizingOptions) -eventlog test/enumerator-scc: Test/TestEnumeratorSCC.hs $(SCCCommonFiles) \ Control/Monad/Coroutine/Enumerator.hs \ - Control/Concurrent/SCC/Combinators/Sequential.hs Control/Concurrent/SCC/Sequential.hs | obj + Control/Concurrent/SCC/Combinators/Sequential.hs Control/Concurrent/SCC/Sequential.hs | obj test ghc --make $< -o $@ $(OptimizingOptions) -eventlog -test/parallel: Test/TestParallel.hs Control/Monad/Parallel.hs | obj +test/parallel: Test/TestParallel.hs Control/Monad/Parallel.hs | obj test ghc --make $< -o $@ $(OptimizingOptions) -eventlog shsh: Shell.hs $(AllLibraryFiles) | obj @@ -53,7 +54,7 @@ shsh-prof: Shell.hs $(AllLibraryFiles) | prof ghc --make $< -o $@ $(ProfilingOptions) -doc/index.html: $(DocumentationFiles) +doc/index.html: $(DocumentationFiles) | doc haddock -hU -o doc \ -i http://www.haskell.org/ghc/docs/latest/html/libraries/base,base.haddock \ -i $(lastword $(wildcard ~/.cabal/share/doc/enumerator-*/html/)),$(lastword $(wildcard ~/.cabal/share/doc/enumerator-*/html/enumerator.haddock)) \ @@ -62,7 +63,7 @@ -i $(lastword $(wildcard ~/.cabal/share/doc/text-*/html/)),$(lastword $(wildcard ~/.cabal/share/doc/text-*/html/text.haddock)) \ $^ -obj prof: +obj prof test doc: mkdir -p $@ clean: diff --git a/scc.cabal b/scc.cabal --- a/scc.cabal +++ b/scc.cabal @@ -1,5 +1,5 @@ Name: scc -Version: 0.7 +Version: 0.7.1 Cabal-Version: >= 1.2 Build-Type: Simple Synopsis: Streaming component combinators @@ -34,7 +34,7 @@ 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.1 && < 0.2, + Build-Depends: base < 5, containers, transformers >= 0.2 && < 0.3, incremental-parser >= 0.2 && < 0.3, monad-parallel, monad-coroutine >= 0.7 && < 0.8, bytestring < 1.0, text < 1.0, process, readline, parsec >= 3.0 && < 4.0 GHC-options: -threaded @@ -45,10 +45,10 @@ 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, + Build-Depends: base < 5, containers, transformers >= 0.2 && < 0.3, incremental-parser >= 0.2 && < 0.3, monad-parallel, monad-coroutine >= 0.7 && < 0.8, bytestring < 1.0, text < 1.0, QuickCheck >= 2 && < 3 - GHC-options: -threaded + GHC-options: -threaded -fcontext-stack=30 if !flag(test) buildable: False @@ -59,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, incremental-parser >= 0.1 && < 0.2, + Build-Depends: base < 5, containers, transformers >= 0.2 && < 0.3, incremental-parser >= 0.2 && < 0.3, monad-parallel, monad-coroutine >= 0.7 && < 0.8, bytestring < 1.0, text < 1.0 GHC-prof-options: -auto-all