module Control.Concurrent.SCC.XML (
Token (..),
tokens, parseTokens, expandEntity,
escapeAttributeCharacter, escapeContentCharacter,
element, elementContent, elementName, attribute, attributeName, attributeValue,
elementHavingTag, havingText, havingOnlyText
)
where
import Prelude hiding (mapM)
import Control.Exception (assert)
import Control.Monad (join, liftM, when)
import Data.Char
import qualified Data.Map as Map
import Data.Maybe (fromJust, isJust, mapMaybe)
import Data.List (find, stripPrefix)
import qualified Data.Sequence as Seq
import Data.Sequence ((|>))
import Data.Traversable (Traversable, mapM)
import Numeric (readDec, readHex)
import Debug.Trace (trace)
import Control.Monad.Coroutine
import Control.Monad.Parallel (MonadParallel(..))
import Control.Concurrent.SCC.Streams
import Control.Concurrent.SCC.Types
import Control.Concurrent.SCC.Combinators (groupMarks, splitterToMarker, parseNestedRegions,
findsTrueIn, findsFalseIn, teeConsumers)
data Token = StartTag | EndTag | EmptyTag
| ElementName | AttributeName | AttributeValue
| EntityReferenceToken | EntityName
| ProcessingInstruction | ProcessingInstructionText
| Comment | CommentText
| StartMarkedSectionCDATA | EndMarkedSection
| ErrorToken String
deriving (Eq, Show)
escapeAttributeCharacter :: Char -> String
escapeAttributeCharacter '"' = """
escapeAttributeCharacter '\t' = "	"
escapeAttributeCharacter '\n' = " "
escapeAttributeCharacter '\r' = " "
escapeAttributeCharacter x = escapeContentCharacter x
escapeContentCharacter :: Char -> String
escapeContentCharacter '<' = "<"
escapeContentCharacter '&' = "&"
escapeContentCharacter x = [x]
expandEntity :: String -> String
expandEntity "lt" = "<"
expandEntity "gt" = ">"
expandEntity "quot" = "\""
expandEntity "apos" = "'"
expandEntity "amp" = "&"
expandEntity ('#' : 'x' : codePoint) = [chr (fst $ head $ readHex codePoint)]
expandEntity ('#' : codePoint) = [chr (fst $ head $ readDec codePoint)]
isNameStart x = isLetter x || x == '_'
isNameChar x = isAlphaNum x || x == '_' || x == '-'
tokens :: Monad m => Splitter m Char (Boundary Token)
tokens = Splitter $
\source true false edge->
let getContent = getWith content source
content '<' = getWith (\x-> tag x >> getWith content source) source
content '&' = entity >> getWith content source
content x = put false x
>> getContent
tag '?' = do put edge (Start ProcessingInstruction)
putList "<?" true
put edge (Start ProcessingInstructionText)
processingInstruction
tag '!' = dispatchOnString source
(\other-> put edge (Point (errorBadDeclarationType other)))
[("--",
\match-> do put edge (Start Comment)
putList match true
put edge (Start CommentText)
comment),
("[CDATA[",
\match-> do put edge (Start StartMarkedSectionCDATA)
putList match true
put edge (End StartMarkedSectionCDATA)
markedSection)]
tag '/' =
do put edge (Start EndTag)
put true '<'
put true '/'
next errorInputEndInEndTag
(\x-> name ElementName x
>>= maybe
(put edge (Point errorInputEndInEndTag))
(\x-> do put true x
when (x /= '>') (put edge (Point (errorBadEndTag x)))))
put edge (End EndTag)
tag x | isNameStart x =
put edge (Start StartTag)
>> put true '<'
>> name ElementName x
>>= maybe
(put edge (Point errorInputEndInStartTag))
(\y-> attributes y
>>= maybe
(put edge (Point errorInputEndInStartTag))
startTagEnd)
>> put edge (End StartTag)
tag x = put edge (Point errorUnescapedContentLT)
>> put false '<'
>> put false x
startTagEnd '/' = put true '/'
>> put edge (Point EmptyTag)
>> next errorInputEndInStartTag
(\x-> put true x >> when (x /= '>') (put edge (Point (errorBadStartTag x))))
startTagEnd '>' = put true '>'
startTagEnd x = put true x
>> put edge (Point (errorBadStartTag x))
attributes x | isSpace x = put true x >> get source >>= mapJoinM attributes
attributes x | isNameStart x
= name AttributeName x
>>= mapJoinM
(\y-> do when (y /= '=') (put edge (Point (errorBadAttribute y)))
q <- if y == '"' || y == '\''
then return y
else put true y >> get source
>>= maybe
(put edge (Point errorInputEndInAttributeValue)
>> return '"')
return
when (q /= '"' && q /= '\'') (put edge (Point (errorBadQuoteCharacter q)))
put true q
put edge (Start AttributeValue)
get source
>>= maybe
(put edge (Point errorInputEndInAttributeValue)
>> put edge (End AttributeValue))
(attributeValue q)
get source >>= mapJoinM attributes)
attributes x = return (Just x)
attributeValue q x | q == x = do put edge (End AttributeValue)
put true x
attributeValue q '<' = do put edge (Start errorUnescapedAttributeLT)
put true '<'
put edge (End errorUnescapedAttributeLT)
next errorInputEndInAttributeValue (attributeValue q)
attributeValue q '&' = entity >> next errorInputEndInAttributeValue (attributeValue q)
attributeValue q x = put true x >> next errorInputEndInAttributeValue (attributeValue q)
processingInstruction =
dispatchOnString source
(\other-> if null other
then put edge (Point errorInputEndInProcessingInstruction)
else putList other true >> processingInstruction)
[("?>",
\match-> do put edge (End ProcessingInstructionText)
putList match true
put edge (End ProcessingInstruction)
getContent)]
comment =
dispatchOnString source
(\other-> if null other
then put edge (Point errorInputEndInComment)
else putList other true >> comment)
[("-->",
\match-> do put edge (End CommentText)
putList match true
put edge (End Comment)
getContent)]
markedSection =
dispatchOnString source
(\other-> if null other
then put edge (Point errorInputEndInMarkedSection)
else putList other true >> markedSection)
[("]]>",
\match-> do 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
>>= maybe
(put edge (Point errorInputEndInEntityReference))
(\x-> do when (x /= ';') (put edge (Point (errorBadEntityReference x)))
put true x))
>> put edge (End EntityReferenceToken)
name token x | isNameStart x =
put edge (Start token)
>> put true x
>> get source
>>= maybe
(put edge (End token) >> return Nothing)
(nameTail token)
name _ x = return (Just x)
nameTail token x = if isNameChar x || x == ':'
then put true x
>> get source
>>= maybe
(put edge (End token) >> return Nothing)
(nameTail token)
else put edge (End token) >> return (Just x)
next error f = get source
>>= maybe (put edge (Point error)) f
in getContent
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")
errorBadAttributeValue x = ErrorToken ("Invalid character " ++ show x ++ " in attribute value.")
errorBadEntityReference x = ErrorToken ("Invalid character " ++ show x ++ " ends entity name.")
errorBadDeclarationType other = ErrorToken ("Expecting <![CDATA[ or <!--, received " ++ show ("<![" ++ other))
errorUnescapedContentLT = ErrorToken "Unescaped character '<' in content"
errorUnescapedAttributeLT = ErrorToken "Invalid character '<' in attribute value."
parseTokens :: Monad m => Parser m Char Token
parseTokens = parseNestedRegions tokens
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)]
-> Coroutine d m r
dispatchOnString source failure fullCases = dispatch fullCases id
where dispatch cases consumed
= case find (null . fst) cases
of Just ("", rhs) -> rhs (consumed "")
Nothing -> get source
>>= maybe
(failure (consumed ""))
(\x-> case mapMaybe (startingWith x) cases
of [] -> failure (consumed [x])
subcases -> dispatch (subcases ++ fullCases) (consumed . (x :)))
startingWith x (y:rest, rhs) | x == y = Just (rest, rhs)
| otherwise = Nothing
getElementName :: forall m a d. (Monad m, AncestorFunctor a d) =>
Source m a (Markup Token Char) -> ([Markup Token Char] -> [Markup Token Char])
-> Coroutine d m ([Markup Token Char], Maybe String)
getElementName source f = get source
>>= maybe
(return (f [], Nothing))
(\x-> case x
of Markup (Start ElementName) -> getRestOfRegion ElementName source (f . (x:)) id
Markup (Point ErrorToken{}) -> getElementName source (f . (x:))
Content{} -> getElementName source (f . (x:))
_ -> error ("Expected an ElementName, received " ++ show x))
getRestOfRegion :: forall m a d. (Monad m, AncestorFunctor a d) =>
Token -> Source m a (Markup Token Char)
-> ([Markup Token Char] -> [Markup Token Char]) -> (String -> String)
-> Coroutine d m ([Markup Token Char], Maybe String)
getRestOfRegion token source f g = get source
>>= maybe
(return (f [], Nothing))
(\x-> case x
of Markup (End token) -> return (f [x], Just (g ""))
Content y -> getRestOfRegion token source (f . (x:)) (g . (y:))
_ -> error ("Expected rest of " ++ show token
++ ", received " ++ show x))
pourRestOfRegion :: forall m a1 a2 a3 d. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d) =>
Token -> Source m a1 (Markup Token Char)
-> Sink m a2 (Markup Token Char) -> Sink m a3 (Markup Token Char)
-> Coroutine d m Bool
pourRestOfRegion token source sink endSink
= get source
>>= maybe
(return False)
(\x-> case x
of Markup (End token') | token == token' -> put endSink x
>> return True
Content y -> put sink x
>> pourRestOfRegion token source sink endSink
_ -> error ("Expected rest of " ++ show token ++ ", received " ++ show x))
pourRestOfTag :: forall m a1 a2 d. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d) =>
Source m a1 (Markup Token Char) -> Sink m a2 (Markup Token Char) -> Coroutine d m Bool
pourRestOfTag source sink = get source
>>= maybe
(return True)
(\x-> put sink x
>> case x of Markup (End StartTag) -> return True
Markup (End EndTag) -> return True
Markup (Point EmptyTag) -> pourRestOfTag source sink
>> return False
_ -> pourRestOfTag source sink)
findEndTag :: forall m a1 a2 a3 d. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d) =>
Source m a1 (Markup Token Char) -> Sink m a2 (Markup Token Char) -> Sink m a3 (Markup Token Char)
-> String
-> Coroutine d m ()
findEndTag source sink endSink name = find where
find = getWith consumeOne source
consumeOne x@(Markup (Start EndTag)) = do (tokens, mn) <- getElementName source (x :)
maybe
(return ())
(\name'-> if name == name'
then do putList tokens endSink
pourRestOfTag source endSink
return ()
else do putList tokens sink
pourRestOfTag source sink
find)
mn
consumeOne x@(Markup (Start StartTag)) = do (tokens, mn) <- getElementName source (x :)
maybe
(return ())
(\name'-> putList tokens sink
>> if name == name'
then pourRestOfTag source sink
>>= flip when (findEndTag source sink sink name)
>> find
else pourRestOfTag source sink
>> find)
mn
consumeOne x = put sink x >> find
findStartTag :: forall m a1 a2 d. (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d) =>
Source m a1 (Markup Token Char) -> Sink m a2 (Markup Token Char)
-> Coroutine d m (Maybe (Markup Token Char))
findStartTag source sink = get source
>>= maybe
(return Nothing)
(\x-> case x of Markup (Start StartTag) -> return $ Just x
_ -> put sink x
>> findStartTag source sink)
element :: Monad m => Splitter m (Markup Token Char) ()
element = Splitter $
\source true false edge->
let split0 = findStartTag source false
>>= maybe (return ())
(\x-> do put edge ()
put true x
(tokens, mn) <- getElementName source id
maybe
(putList tokens true)
(\name-> putList tokens true
>> pourRestOfTag source true
>>= cond
(split1 name)
split0)
mn)
split1 name = findEndTag source true true name
>> split0
in split0
elementContent :: Monad m => Splitter m (Markup Token Char) ()
elementContent = Splitter $
\source true false edge->
let split0 = findStartTag source false
>>= maybe (return ())
(\x-> do put false x
(tokens, mn) <- getElementName source id
maybe
(putList tokens false)
(\name-> putList tokens false
>> pourRestOfTag source false
>>= cond
(put edge ()
>> split1 name)
split0)
mn)
split1 name = findEndTag source true false name
>> split0
in split0
elementHavingTag :: forall m b. MonadParallel m =>
Splitter m (Markup Token Char) b -> Splitter m (Markup Token Char) b
elementHavingTag test =
isolateSplitter $ \ source true false edge ->
let split0 = findStartTag source false
>>= maybe (return ())
(\x-> do (tokens, mn) <- getElementName source (x :)
maybe
(return ())
(\name-> do (hasContent, rest) <- pipe
(pourRestOfTag source)
getList
let tag = tokens ++ rest
((), found) <- pipe (putList tag) (findsTrueIn test)
case found of Just mb -> maybe (return ()) (put edge) mb
>> putList tag true
>> split1 hasContent true name
Nothing -> putList tag false
>> split1 hasContent false name)
mn)
split1 hasContent sink name = when hasContent (findEndTag source sink sink name)
>> split0
in split0
attribute :: Monad m => Splitter m (Markup Token Char) ()
attribute = Splitter $
\source true false edge->
let split0 = getWith
(\x-> case x
of Markup (Start AttributeName) -> do put edge ()
put true x
pourRestOfRegion AttributeName source true true
>>= flip when split1
_ -> put false x >> split0)
source
split1 = getWith
(\x-> case x
of Markup (Start AttributeValue)
-> put true x
>> pourRestOfRegion AttributeValue source true true
>>= flip when split0
_ -> put true x >> split1)
source
in split0
elementName :: Monad m => Splitter m (Markup Token Char) ()
elementName = Splitter (splitSimpleRegions ElementName)
attributeName :: Monad m => Splitter m (Markup Token Char) ()
attributeName = Splitter (splitSimpleRegions AttributeName)
attributeValue :: Monad m => Splitter m (Markup Token Char) ()
attributeValue = Splitter (splitSimpleRegions AttributeValue)
splitSimpleRegions token source true false edge = split
where split = getWith consumeOne source
consumeOne x@(Markup (Start token')) | token == token' = put false x
>> put edge ()
>> pourRestOfRegion token source true false
>>= flip when split
consumeOne x = put false x >> split
havingText :: forall m b1 b2. MonadParallel m =>
Bool -> Splitter m (Markup Token Char) b1 -> Splitter m Char b2 -> Splitter m (Markup Token Char) b1
havingText parallel chunker tester = isolateSplitter havingText' where
havingText' source true false edge =
let test Nothing chunk = pour chunk false
test (Just mb) chunk = teeConsumers False getList (findsTrueIn tester . mapMaybeSource justContent) chunk
>>= \(chunk, found)->
if isJust found
then maybe (return ()) (put edge) mb
>> putList chunk true
else putList chunk false
in liftM fst $
pipePS parallel
(transduce (splitterToMarker chunker) source)
(flip groupMarks test)
havingOnlyText :: forall m b1 b2. MonadParallel m =>
Bool -> Splitter m (Markup Token Char) b1 -> Splitter m Char b2 -> Splitter m (Markup Token Char) b1
havingOnlyText parallel chunker tester = isolateSplitter havingOnlyText' where
havingOnlyText' source true false edge =
let test Nothing chunk = pour chunk false
test (Just mb) chunk = teeConsumers False getList (findsFalseIn tester . mapMaybeSource justContent) chunk
>>= \(chunk, found)->
if found
then putList chunk false
else maybe (return ()) (put edge) mb
>> putList chunk true
in liftM fst $
pipePS parallel
(transduce (splitterToMarker chunker) source)
(flip groupMarks test)
justContent (Content x) = Just x
justContent _ = Nothing
mapJoinM :: (Monad m, Monad t, Traversable t) => (a -> m (t b)) -> t a -> m (t b)
mapJoinM f ta = mapM f ta >>= return . join