{-# LANGUAGE OverloadedStrings #-}
module Web.Mangrove.Parse.Tree.Foreign
( treeForeign
) where
import qualified Control.Monad.Trans.State as N.S
import qualified Data.HashMap.Strict as M
import qualified Data.Maybe as Y
import qualified Data.Text as T
import Web.Willow.DOM
import Web.Mangrove.Parse.Common.Error
import Web.Mangrove.Parse.Tokenize.Common
import Web.Mangrove.Parse.Tree.Common
import Web.Mangrove.Parse.Tree.InBody
import Web.Mangrove.Parse.Tree.Patch
import Web.Willow.Common.Encoding.Character
import Web.Willow.Common.Parser
import Web.Willow.Common.Parser.Switch
import {-# SOURCE #-} Web.Mangrove.Parse.Tree.Dispatcher
treeForeign :: TreeBuilder TreeOutput
treeForeign :: TreeBuilder TreeOutput
treeForeign = StateT TreeParserState (Parser [TreeInput]) TreeInput
forall (m :: * -> *) stream token.
MonadParser m stream token =>
m token
next StateT TreeParserState (Parser [TreeInput]) TreeInput
-> (TreeInput -> TreeBuilder TreeOutput) -> TreeBuilder TreeOutput
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [SwitchCase
TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput]
-> TreeInput -> TreeBuilder TreeOutput
forall (m :: * -> *) test out.
Alternative m =>
[SwitchCase test m out] -> test -> m out
switch
[ (TreeInput -> Bool)
-> (TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall test (m :: * -> *) out.
(test -> Bool) -> (test -> m out) -> SwitchCase test m out
If TreeInput -> Bool
isNull ((TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput)
-> (TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall a b. (a -> b) -> a -> b
$ \TreeInput
t' ->
ParseError -> TreeOutput -> TreeOutput
consTreeError ParseError
UnexpectedNullCharacter (TreeOutput -> TreeOutput)
-> TreeBuilder TreeOutput -> TreeBuilder TreeOutput
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TreeInput -> TreeBuilder TreeOutput
insertCharacter ((Token -> Token) -> TreeInput -> TreeInput
mapTokenOut (Token -> Token -> Token
forall a b. a -> b -> a
const (Token -> Token -> Token) -> Token -> Token -> Token
forall a b. (a -> b) -> a -> b
$ Char -> Token
Character Char
replacementChar) TreeInput
t')
, (TreeInput -> Bool)
-> (TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall test (m :: * -> *) out.
(test -> Bool) -> (test -> m out) -> SwitchCase test m out
If TreeInput -> Bool
isWhitespace TreeInput -> TreeBuilder TreeOutput
insertCharacter
, (TreeInput -> Bool)
-> (TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall test (m :: * -> *) out.
(test -> Bool) -> (test -> m out) -> SwitchCase test m out
If TreeInput -> Bool
isCharacter ((TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput)
-> (TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall a b. (a -> b) -> a -> b
$ \TreeInput
t' -> TreeBuilder ()
setFramesetNotOk TreeBuilder () -> TreeBuilder TreeOutput -> TreeBuilder TreeOutput
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> TreeInput -> TreeBuilder TreeOutput
insertCharacter TreeInput
t'
, (TreeInput -> Bool)
-> (TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall test (m :: * -> *) out.
(test -> Bool) -> (test -> m out) -> SwitchCase test m out
If TreeInput -> Bool
isComment TreeInput -> TreeBuilder TreeOutput
insertComment
, (TreeInput -> Bool)
-> (TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall test (m :: * -> *) out.
(test -> Bool) -> (test -> m out) -> SwitchCase test m out
If TreeInput -> Bool
isDoctype ((TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput)
-> (TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall a b. (a -> b) -> a -> b
$ \TreeInput
t' ->
[ParseError] -> TreeInput -> TreeBuilder TreeOutput
packTreeErrors [DocumentTypeParams -> ParseError
UnexpectedDoctype (DocumentTypeParams -> ParseError)
-> DocumentTypeParams -> ParseError
forall a b. (a -> b) -> a -> b
$ TreeInput -> DocumentTypeParams
tokenDocumentType TreeInput
t'] TreeInput
t'
, (TreeInput -> Bool)
-> (TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall test (m :: * -> *) out.
(test -> Bool) -> (test -> m out) -> SwitchCase test m out
If TreeInput -> Bool
isEOF ((TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput)
-> (TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall a b. (a -> b) -> a -> b
$ \TreeInput
t' -> TreeInput -> TreeBuilder ()
forall (m :: * -> *) stream token.
MonadParser m stream token =>
token -> m ()
push TreeInput
t' TreeBuilder () -> TreeBuilder TreeOutput -> TreeBuilder TreeOutput
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> TreeBuilder TreeOutput
treeInBody
, (TreeInput -> Bool)
-> (TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall test (m :: * -> *) out.
(test -> Bool) -> (test -> m out) -> SwitchCase test m out
If ([String] -> TreeInput -> Bool
isStartTag
[ String
"b"
, String
"big"
, String
"blockquote"
, String
"body"
, String
"br"
, String
"center"
, String
"code"
, String
"dd"
, String
"div"
, String
"dl"
, String
"dt"
, String
"em"
, String
"embed"
, String
"h1"
, String
"h2"
, String
"h3"
, String
"h4"
, String
"h5"
, String
"h6"
, String
"head"
, String
"hr"
, String
"i"
, String
"img"
, String
"li"
, String
"listing"
, String
"menu"
, String
"meta"
, String
"nobr"
, String
"ol"
, String
"p"
, String
"pre"
, String
"ruby"
, String
"s"
, String
"small"
, String
"span"
, String
"strong"
, String
"strike"
, String
"sub"
, String
"sup"
, String
"table"
, String
"tt"
, String
"u"
, String
"ul"
, String
"var"
]) TreeInput -> TreeBuilder TreeOutput
htmlStartTag
, (TreeInput -> Bool)
-> (TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall test (m :: * -> *) out.
(test -> Bool) -> (test -> m out) -> SwitchCase test m out
If ([String] -> TreeInput -> Bool
isStartTag [String
"font"]) ((TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput)
-> (TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall a b. (a -> b) -> a -> b
$ \TreeInput
t' ->
if (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"color", Text
"face", Text
"size"]) (((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> Text
forall a b. (a, b) -> a
fst ([(Text, Text)] -> [Text])
-> (Token -> [(Text, Text)]) -> Token -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Text Text -> [(Text, Text)]
forall k v. HashMap k v -> [(k, v)]
M.toList (HashMap Text Text -> [(Text, Text)])
-> (Token -> HashMap Text Text) -> Token -> [(Text, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> HashMap Text Text
tokenAttributes (Token -> [Text]) -> Token -> [Text]
forall a b. (a -> b) -> a -> b
$ TreeInput -> Token
tokenOut TreeInput
t')
then TreeInput -> TreeBuilder TreeOutput
htmlStartTag TreeInput
t'
else TreeInput -> TreeBuilder TreeOutput
anyOtherStartTag TreeInput
t'
, (TreeInput -> Bool)
-> (TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall test (m :: * -> *) out.
(test -> Bool) -> (test -> m out) -> SwitchCase test m out
If TreeInput -> Bool
isAnyStartTag TreeInput -> TreeBuilder TreeOutput
anyOtherStartTag
, (TreeInput -> Bool)
-> (TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall test (m :: * -> *) out.
(test -> Bool) -> (test -> m out) -> SwitchCase test m out
If ([String] -> TreeInput -> Bool
isEndTag [String
"script"]) ((TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput)
-> (TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall a b. (a -> b) -> a -> b
$ \TreeInput
t' -> do
Maybe ElementParams
current <- TreeBuilder (Maybe ElementParams)
currentNode
TreeParserState
state <- StateT TreeParserState (Parser [TreeInput]) TreeParserState
forall (m :: * -> *) s. Monad m => StateT s m s
N.S.get
if (Maybe ElementParams
current Maybe ElementParams -> (ElementParams -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ElementParams -> Maybe Text
elementNamespace) Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
mathMLNamespace
then TreeInput -> TreeBuilder TreeOutput
closeCurrentNode TreeInput
t' TreeBuilder TreeOutput
-> StateT TreeParserState (Parser [TreeInput]) Any
-> TreeBuilder TreeOutput
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* StateT TreeParserState (Parser [TreeInput]) Any
forall a. a
closeSvgScript
else [(NodeIndex, ElementParams)] -> TreeInput -> TreeBuilder TreeOutput
forall a.
[(a, ElementParams)] -> TreeInput -> TreeBuilder TreeOutput
anyOtherEndTag (TreeParserState -> [(NodeIndex, ElementParams)]
openElements TreeParserState
state) TreeInput
t'
, (TreeInput -> Bool)
-> (TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall test (m :: * -> *) out.
(test -> Bool) -> (test -> m out) -> SwitchCase test m out
If TreeInput -> Bool
isAnyEndTag ((TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput)
-> (TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall a b. (a -> b) -> a -> b
$ \TreeInput
t' -> do
TreeParserState
state <- StateT TreeParserState (Parser [TreeInput]) TreeParserState
forall (m :: * -> *) s. Monad m => StateT s m s
N.S.get
[(NodeIndex, ElementParams)] -> TreeInput -> TreeBuilder TreeOutput
forall a.
[(a, ElementParams)] -> TreeInput -> TreeBuilder TreeOutput
anyOtherEndTag (TreeParserState -> [(NodeIndex, ElementParams)]
openElements TreeParserState
state) TreeInput
t'
]
where anyOtherStartTag :: TreeInput -> TreeBuilder TreeOutput
anyOtherStartTag TreeInput
t' = case TreeInput -> Token
tokenOut TreeInput
t' of
StartTag TagParams
d -> do
Maybe ElementParams
current <- TreeBuilder (Maybe ElementParams)
adjustedCurrentNode
let ns :: Text
ns = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
Y.fromMaybe Text
htmlNamespace (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Maybe ElementParams
current Maybe ElementParams -> (ElementParams -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ElementParams -> Maybe Text
elementNamespace
d' :: TagParams
d' = case Text
ns of
Text
ns' | Text
mathMLNamespace Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
ns' -> TagParams -> TagParams
adjustMathMLAttributes TagParams
d
Text
ns' | Text
svgNamespace Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
ns' -> TagParams -> TagParams
adjustSvgAttributes (TagParams -> TagParams) -> TagParams -> TagParams
forall a b. (a -> b) -> a -> b
$ case TagParams -> Text
tagName TagParams
d of
Text
"altglyph" -> TagParams
d { tagName :: Text
tagName = Text
"altGlyph" }
Text
"altglyphdef" -> TagParams
d { tagName :: Text
tagName = Text
"altGlyphDef" }
Text
"altglyphitem" -> TagParams
d { tagName :: Text
tagName = Text
"altGlyphItem" }
Text
"animatecolor" -> TagParams
d { tagName :: Text
tagName = Text
"animateColor" }
Text
"animatemotion" -> TagParams
d { tagName :: Text
tagName = Text
"animateMotion" }
Text
"animatetransform" -> TagParams
d { tagName :: Text
tagName = Text
"animateTransform" }
Text
"clippath" -> TagParams
d { tagName :: Text
tagName = Text
"clipPath" }
Text
"feblend" -> TagParams
d { tagName :: Text
tagName = Text
"feBlend" }
Text
"fecolormatrix" -> TagParams
d { tagName :: Text
tagName = Text
"feColorMatrix" }
Text
"fecomponenttransfer" -> TagParams
d { tagName :: Text
tagName = Text
"feComponentTransfer" }
Text
"fecomposite" -> TagParams
d { tagName :: Text
tagName = Text
"feComposite" }
Text
"feconvolvematrix" -> TagParams
d { tagName :: Text
tagName = Text
"feConvolveMatrix" }
Text
"fediffuselighting" -> TagParams
d { tagName :: Text
tagName = Text
"feDiffuseLighting" }
Text
"fedisplacementmap" -> TagParams
d { tagName :: Text
tagName = Text
"feDisplacementMap" }
Text
"fedistantlight" -> TagParams
d { tagName :: Text
tagName = Text
"feDistantLight" }
Text
"fedropshadow" -> TagParams
d { tagName :: Text
tagName = Text
"feDropShadow" }
Text
"feflood" -> TagParams
d { tagName :: Text
tagName = Text
"feFlood" }
Text
"fefunca" -> TagParams
d { tagName :: Text
tagName = Text
"feFuncA" }
Text
"fefuncb" -> TagParams
d { tagName :: Text
tagName = Text
"feFuncB" }
Text
"fefuncg" -> TagParams
d { tagName :: Text
tagName = Text
"feFuncG" }
Text
"fefuncr" -> TagParams
d { tagName :: Text
tagName = Text
"feFuncR" }
Text
"fegaussianblur" -> TagParams
d { tagName :: Text
tagName = Text
"feGaussianBlur" }
Text
"feimage" -> TagParams
d { tagName :: Text
tagName = Text
"feImage" }
Text
"femerge" -> TagParams
d { tagName :: Text
tagName = Text
"feMerge" }
Text
"femergenode" -> TagParams
d { tagName :: Text
tagName = Text
"feMergeNode" }
Text
"femorphology" -> TagParams
d { tagName :: Text
tagName = Text
"feMorphology" }
Text
"feoffset" -> TagParams
d { tagName :: Text
tagName = Text
"feOffset" }
Text
"fepointlight" -> TagParams
d { tagName :: Text
tagName = Text
"fePointLight" }
Text
"fespecularlighting" -> TagParams
d { tagName :: Text
tagName = Text
"feSpecularLighting" }
Text
"fespotlight" -> TagParams
d { tagName :: Text
tagName = Text
"feSpotLight" }
Text
"fetile" -> TagParams
d { tagName :: Text
tagName = Text
"feTile" }
Text
"feturbulence" -> TagParams
d { tagName :: Text
tagName = Text
"feTurbulence" }
Text
"foreignobject" -> TagParams
d { tagName :: Text
tagName = Text
"foreignObject" }
Text
"glyphref" -> TagParams
d { tagName :: Text
tagName = Text
"glyphRef" }
Text
"lineargradient" -> TagParams
d { tagName :: Text
tagName = Text
"linearGradient" }
Text
"radialgradient" -> TagParams
d { tagName :: Text
tagName = Text
"radialGradient" }
Text
"textpath" -> TagParams
d { tagName :: Text
tagName = Text
"textPath" }
Text
_ -> TagParams
d
Text
_ -> TagParams
d
t'' :: TreeInput
t'' = (Token -> Token) -> TreeInput -> TreeInput
mapTokenOut (Token -> Token -> Token
forall a b. a -> b -> a
const (Token -> Token -> Token) -> Token -> Token -> Token
forall a b. (a -> b) -> a -> b
$ TagParams -> Token
StartTag TagParams
d') TreeInput
t'
if TagParams -> Bool
tagIsSelfClosing TagParams
d'
then if TagParams -> Text
tagName TagParams
d' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"script" Bool -> Bool -> Bool
&& Text
ns Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
svgNamespace
then Text -> TreeInput -> TreeBuilder TreeOutput
insertForeignNullElement Text
ns TreeInput
t'' TreeBuilder TreeOutput
-> StateT TreeParserState (Parser [TreeInput]) Any
-> TreeBuilder TreeOutput
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* StateT TreeParserState (Parser [TreeInput]) Any
forall a. a
closeSvgScript
else Text -> TreeInput -> TreeBuilder TreeOutput
insertForeignNullElement Text
ns TreeInput
t''
else Text -> TreeInput -> TreeBuilder TreeOutput
insertForeignElement Text
ns TreeInput
t''
Token
_ -> [ParseError] -> TreeInput -> TreeBuilder TreeOutput
packTreeErrors [] TreeInput
t'
anyOtherEndTag :: [(a, ElementParams)] -> TreeInput -> TreeBuilder TreeOutput
anyOtherEndTag [] TreeInput
t' = [ParseError] -> TreeInput -> TreeBuilder TreeOutput
packTreeErrors [] TreeInput
t'
anyOtherEndTag es :: [(a, ElementParams)]
es@((a, ElementParams)
e:[(a, ElementParams)]
_) TreeInput
t' = case TreeInput -> Token
tokenOut TreeInput
t' of
EndTag TagParams
d -> if (Char -> Char) -> Text -> Text
T.map Char -> Char
toAsciiLower (ElementParams -> Text
elementName (ElementParams -> Text) -> ElementParams -> Text
forall a b. (a -> b) -> a -> b
$ (a, ElementParams) -> ElementParams
forall a b. (a, b) -> b
snd (a, ElementParams)
e) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== TagParams -> Text
tagName TagParams
d
then TagParams
-> [(a, ElementParams)] -> TreeInput -> TreeBuilder TreeOutput
forall a.
TagParams
-> [(a, ElementParams)] -> TreeInput -> TreeBuilder TreeOutput
loopEndTag TagParams
d [(a, ElementParams)]
es TreeInput
t'
else ParseError -> TreeOutput -> TreeOutput
consTreeError ParseError
UnexpectedElementWithImpliedEndTag (TreeOutput -> TreeOutput)
-> TreeBuilder TreeOutput -> TreeBuilder TreeOutput
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TagParams
-> [(a, ElementParams)] -> TreeInput -> TreeBuilder TreeOutput
forall a.
TagParams
-> [(a, ElementParams)] -> TreeInput -> TreeBuilder TreeOutput
loopEndTag TagParams
d [(a, ElementParams)]
es TreeInput
t'
Token
_ -> [ParseError] -> TreeInput -> TreeBuilder TreeOutput
packTreeErrors [] TreeInput
t'
loopEndTag :: TagParams
-> [(a, ElementParams)] -> TreeInput -> TreeBuilder TreeOutput
loopEndTag TagParams
d [(a, ElementParams)]
es TreeInput
t' = (TreeOutput -> TreeOutput)
-> (TreeOutput -> TreeOutput)
-> Either TreeOutput TreeOutput
-> TreeOutput
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either TreeOutput -> TreeOutput
forall a. a -> a
id TreeOutput -> TreeOutput
forall a. a -> a
id (Either TreeOutput TreeOutput -> TreeOutput)
-> StateT
TreeParserState (Parser [TreeInput]) (Either TreeOutput TreeOutput)
-> TreeBuilder TreeOutput
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TagParams
-> [(a, ElementParams)]
-> TreeInput
-> StateT
TreeParserState (Parser [TreeInput]) (Either TreeOutput TreeOutput)
forall a.
TagParams
-> [(a, ElementParams)]
-> TreeInput
-> StateT
TreeParserState (Parser [TreeInput]) (Either TreeOutput TreeOutput)
loopEndTag' TagParams
d [(a, ElementParams)]
es TreeInput
t'
loopEndTag' :: TagParams
-> [(a, ElementParams)]
-> TreeInput
-> StateT
TreeParserState (Parser [TreeInput]) (Either TreeOutput TreeOutput)
loopEndTag' TagParams
_ [] TreeInput
t' = TreeOutput -> Either TreeOutput TreeOutput
forall a b. a -> Either a b
Left (TreeOutput -> Either TreeOutput TreeOutput)
-> TreeBuilder TreeOutput
-> StateT
TreeParserState (Parser [TreeInput]) (Either TreeOutput TreeOutput)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ParseError] -> TreeInput -> TreeBuilder TreeOutput
packTreeErrors [] TreeInput
t'
loopEndTag' TagParams
_ [(a, ElementParams)
_] TreeInput
t' = TreeOutput -> Either TreeOutput TreeOutput
forall a b. a -> Either a b
Left (TreeOutput -> Either TreeOutput TreeOutput)
-> TreeBuilder TreeOutput
-> StateT
TreeParserState (Parser [TreeInput]) (Either TreeOutput TreeOutput)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ParseError] -> TreeInput -> TreeBuilder TreeOutput
packTreeErrors [] TreeInput
t'
loopEndTag' TagParams
d ((a, ElementParams)
e:[(a, ElementParams)]
es) TreeInput
t'
| (Char -> Char) -> Text -> Text
T.map Char -> Char
toAsciiLower (ElementParams -> Text
elementName (ElementParams -> Text) -> ElementParams -> Text
forall a b. (a -> b) -> a -> b
$ (a, ElementParams) -> ElementParams
forall a b. (a, b) -> b
snd (a, ElementParams)
e) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== TagParams -> Text
tagName TagParams
d =
TreeOutput -> Either TreeOutput TreeOutput
forall a b. b -> Either a b
Right (TreeOutput -> Either TreeOutput TreeOutput)
-> TreeBuilder TreeOutput
-> StateT
TreeParserState (Parser [TreeInput]) (Either TreeOutput TreeOutput)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TreeInput -> TreeBuilder TreeOutput
closeCurrentNode TreeInput
t'
| Bool
otherwise = case [(a, ElementParams)]
es of
((a, ElementParams)
e':[(a, ElementParams)]
_) | ElementParams -> Maybe Text
elementNamespace ((a, ElementParams) -> ElementParams
forall a b. (a, b) -> b
snd (a, ElementParams)
e') Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
htmlNamespace -> TreeInput -> TreeBuilder ()
forall (m :: * -> *) stream token.
MonadParser m stream token =>
token -> m ()
push TreeInput
t' TreeBuilder ()
-> StateT
TreeParserState (Parser [TreeInput]) (Either TreeOutput TreeOutput)
-> StateT
TreeParserState (Parser [TreeInput]) (Either TreeOutput TreeOutput)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (TreeOutput -> Either TreeOutput TreeOutput)
-> TreeBuilder TreeOutput
-> StateT
TreeParserState (Parser [TreeInput]) (Either TreeOutput TreeOutput)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TreeOutput -> Either TreeOutput TreeOutput
forall a b. a -> Either a b
Left TreeBuilder TreeOutput
dispatchHtml
[(a, ElementParams)]
_ -> do
Either TreeOutput TreeOutput
recurse <- TagParams
-> [(a, ElementParams)]
-> TreeInput
-> StateT
TreeParserState (Parser [TreeInput]) (Either TreeOutput TreeOutput)
loopEndTag' TagParams
d [(a, ElementParams)]
es TreeInput
t'
case Either TreeOutput TreeOutput
recurse of
l :: Either TreeOutput TreeOutput
l@(Left TreeOutput
_) -> Either TreeOutput TreeOutput
-> StateT
TreeParserState (Parser [TreeInput]) (Either TreeOutput TreeOutput)
forall (m :: * -> *) a. Monad m => a -> m a
return Either TreeOutput TreeOutput
l
Right TreeOutput
clear -> do
[Patch]
close <- TreeBuilder [Patch]
closeCurrentNode_
Either TreeOutput TreeOutput
-> StateT
TreeParserState (Parser [TreeInput]) (Either TreeOutput TreeOutput)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either TreeOutput TreeOutput
-> StateT
TreeParserState
(Parser [TreeInput])
(Either TreeOutput TreeOutput))
-> (TreeOutput -> Either TreeOutput TreeOutput)
-> TreeOutput
-> StateT
TreeParserState (Parser [TreeInput]) (Either TreeOutput TreeOutput)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TreeOutput -> Either TreeOutput TreeOutput
forall a b. b -> Either a b
Right (TreeOutput
-> StateT
TreeParserState
(Parser [TreeInput])
(Either TreeOutput TreeOutput))
-> TreeOutput
-> StateT
TreeParserState (Parser [TreeInput]) (Either TreeOutput TreeOutput)
forall a b. (a -> b) -> a -> b
$ [Patch]
close [Patch] -> TreeOutput -> TreeOutput
++| TreeOutput
clear
tokenAttributes :: Token -> HashMap Text Text
tokenAttributes (StartTag TagParams
d) = TagParams -> HashMap Text Text
tagAttributes TagParams
d
tokenAttributes (EndTag TagParams
d) = TagParams -> HashMap Text Text
tagAttributes TagParams
d
tokenAttributes Token
_ = HashMap Text Text
forall k v. HashMap k v
M.empty
htmlStartTag :: TreeInput -> TreeBuilder TreeOutput
htmlStartTag TreeInput
t' = do
Bool
isFragment <- TreeBuilder Bool
inFragment
ParseError -> TreeOutput -> TreeOutput
consTreeError ParseError
UnexpectedHtmlElementInForeignContent (TreeOutput -> TreeOutput)
-> TreeBuilder TreeOutput -> TreeBuilder TreeOutput
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if Bool
isFragment
then TreeInput -> TreeBuilder TreeOutput
anyOtherStartTag TreeInput
t'
else do
TreeInput -> TreeBuilder ()
forall (m :: * -> *) stream token.
MonadParser m stream token =>
token -> m ()
push TreeInput
t'
[Patch]
close <- TreeBuilder [Patch]
closeCurrentNode_
[Patch]
clear <- TreeBuilder [Patch]
clearToIntegration
[Patch] -> TreeBuilder TreeOutput
packTree_ ([Patch] -> TreeBuilder TreeOutput)
-> [Patch] -> TreeBuilder TreeOutput
forall a b. (a -> b) -> a -> b
$ [Patch]
close [Patch] -> [Patch] -> [Patch]
forall a. [a] -> [a] -> [a]
++ [Patch]
clear
clearToIntegration :: TreeBuilder [Patch]
clearToIntegration = do
Maybe ElementParams
current <- TreeBuilder (Maybe ElementParams)
currentNode
let mathML :: Bool
mathML = Bool -> (ElementParams -> Bool) -> Maybe ElementParams -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ElementParams -> Bool
atMathMLIntegration Maybe ElementParams
current
html :: Bool
html = Bool -> (ElementParams -> Bool) -> Maybe ElementParams -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ElementParams -> Bool
atHtmlIntegration Maybe ElementParams
current
ns :: Text
ns = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
Y.fromMaybe Text
htmlNamespace (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Maybe ElementParams
current Maybe ElementParams -> (ElementParams -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ElementParams -> Maybe Text
elementNamespace
if Bool
mathML Bool -> Bool -> Bool
|| Bool
html Bool -> Bool -> Bool
|| Text
ns Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
htmlNamespace
then [Patch] -> TreeBuilder [Patch]
forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
[Patch]
close <- TreeBuilder [Patch]
closeCurrentNode_
[Patch]
clear <- TreeBuilder [Patch]
clearToIntegration
[Patch] -> TreeBuilder [Patch]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Patch] -> TreeBuilder [Patch]) -> [Patch] -> TreeBuilder [Patch]
forall a b. (a -> b) -> a -> b
$ [Patch]
close [Patch] -> [Patch] -> [Patch]
forall a. [a] -> [a] -> [a]
++ [Patch]
clear
closeSvgScript :: a
closeSvgScript = a
forall a. HasCallStack => a
undefined