{-# LANGUAGE OverloadedStrings #-}

{-|
Description:    Token processing rules within non-HTML content.

Copyright:      (c) 2020 Sam May
License:        MPL-2.0
Maintainer:     ag.eitilt@gmail.com

Stability:      stable
Portability:    portable
-}
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


-- | __HTML:__
--      @[the rules for parsing tokens in foreign content]
--      (https://html.spec.whatwg.org/multipage/parsing.html#parsing-main-inforeign)@
-- 
-- The parsing instructions for non-HTML content, which follows a simpler
-- recovery model more in line with HTML.
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