mangrove-0.1.0.0: src/Web/Mangrove/Parse/Tree/InBody.hs
{-# LANGUAGE OverloadedStrings #-}
{-|
Description: Token processing rules within the @\<body\>@ section.
Copyright: (c) 2020-2021 Sam May
License: MPL-2.0
Maintainer: ag.eitilt@gmail.com
Stability: provisional
Portability: portable
-}
module Web.Mangrove.Parse.Tree.InBody
( treeInBody
) where
import qualified Control.Monad as N
import qualified Control.Monad.Trans.State as N.S
import qualified Data.HashMap.Strict as M
import qualified Data.List as L
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.InHead
import Web.Mangrove.Parse.Tree.InTemplate
import Web.Mangrove.Parse.Tree.InText
import Web.Mangrove.Parse.Tree.Patch
import Web.Willow.Common.Parser
import Web.Willow.Common.Parser.Switch
import {-# SOURCE #-} Web.Mangrove.Parse.Tree.Dispatcher
import Control.Applicative ( (<|>) )
import Data.Functor ( ($>) )
-- | __HTML:__
-- @[the "in body" insertion mode]
-- (https://html.spec.whatwg.org/multipage/parsing.html#parsing-main-inbody)@
--
-- The parsing instructions corresponding to the 'InBody' section of the state
-- machine.
treeInBody :: TreeBuilder TreeOutput
treeInBody = next >>= switch
[ If isNull $ packTreeErrors [UnexpectedNullCharacter]
, If isWhitespace $ \t' -> do
format <- reconstructFormattingElements
insert <- insertCharacter t'
return $ format ++| insert
, If isCharacter $ \t' -> do
setFramesetNotOk
format <- reconstructFormattingElements
insert <- insertCharacter t'
return $ format ++| insert
, If isComment insertComment
, If isDoctype $ \t' ->
packTreeErrors [UnexpectedDoctype $ tokenDocumentType t'] t'
, If (isStartTag ["html"]) $ \t' -> do
errs <- packTreeErrors [NestedSingletonElement] t'
elements <- openElements <$> N.S.get
if Y.isJust $ L.find (nodeIsElement "template" . snd) elements
then return errs
else case reverse elements of
[] -> return errs
((i, _):_) -> do
add <- mapM (addAttribute InHtmlElement i) .
M.toList . tagAttributes $ tokenTag t'
return $ errs |++ concat add
, If (isStartTag
[ "base"
, "basefont"
, "bgsound"
, "link"
, "meta"
, "noframes"
, "script"
, "style"
, "template"
, "title"
]) $ \t' -> do
push t'
treeInHead
, If (isEndTag ["template"]) $ \t' -> do
push t'
treeInHead
, If (isStartTag ["body"]) $ \t' -> do
errs <- packTreeErrors [NestedSingletonElement] t'
elements <- openElements <$> N.S.get
case reverse elements of
[] -> return errs
[_] -> return errs
es | Y.isJust $ L.find (nodeIsElement "template" . snd) es -> return errs
(_:(i, e):es)
| not (nodeIsElement "body" e) -> return errs
| otherwise -> do
setFramesetNotOk
add <- mapM
(addAttribute (RelativeLocation . fromIntegral $ length es) i) .
M.toList . tagAttributes $ tokenTag t'
return $ errs |++ concat add
, If (isStartTag ["frameset"]) $ \t' -> do
state <- N.S.get
let elements = map snd $ openElements state
err = FramesetInBody $ tokenElement t'
errs <- packTreeErrors [err] t'
case reverse elements of
[] -> return errs
[_] -> return errs
(_:e:_) | not (nodeIsElement "body" e) -> return errs
_ | not (framesetOk state) -> return errs
_ -> do
clear <- N.replicateM (length elements - 1) dropCurrentNode
insert <- insertElement t'
switchMode InFrameset
return . consTreeError err $ concat clear ++| insert
, If isEOF $ \t' -> do
modes <- templateInsertionModes <$> N.S.get
if null modes
then do
hasUnexpected <- hasUnexpectedOpenElement
if hasUnexpected
then consTreeError UnexpectedElementWithImpliedEndTag <$> stopParsing t'
else stopParsing t'
else do
push t'
treeInTemplate
, If (isEndTag ["body"]) $ \t' -> do
switchMode AfterBody
hasBody <- hasInScope ["body"]
hasUnexpected <- hasUnexpectedOpenElement
if hasBody
then if hasUnexpected
then packTreeErrors [UnexpectedElementWithImpliedEndTag] t'
else packTreeErrors [] t'
else packTreeErrors [UnmatchedEndTag $ tokenElement t'] t'
, If (isEndTag ["html"]) $ \t' -> do
push t'
switchMode AfterBody
hasBody <- hasInScope ["body"]
hasUnexpected <- hasUnexpectedOpenElement
if hasBody
then if hasUnexpected
then consTreeError UnexpectedElementWithImpliedEndTag <$> dispatchHtml
else packTreeErrors_ []
else consTreeError (UnmatchedEndTag $ tokenElement t') <$> dispatchHtml
, If (isStartTag
[ "address"
, "article"
, "aside"
, "blockquote"
, "center"
, "details"
, "dialog"
, "dir"
, "div"
, "dl"
, "fieldset"
, "figcaption"
, "figure"
, "footer"
, "header"
, "hgroup"
, "main"
, "menu"
, "nav"
, "ol"
, "p"
, "section"
, "summary"
, "ul"
]) $ \t' -> do
hasP <- hasInButtonScope ["p"]
if hasP
then do
close <- closePElement
insert <- insertElement t'
return $ close ++| insert
else insertElement t'
, If (isStartTag $ map T.unpack headerNames) $ \t' -> do
current <- currentNode
hasP <- hasInButtonScope ["p"]
close <- if hasP
then closePElement
else return []
nest <- case fmap elementName current of
Just h | elem h headerNames -> consTreeError_ OverlappingHeaderElements <$> closeCurrentNode_
_ -> return []
insert <- insertElement t'
return $ close ++ nest ++| insert
, If (isStartTag ["pre", "listing"]) $ \t' -> do
lineFeed <- next
lineFeedState <- if tokenOut lineFeed == Character '\n'
then return $ tokenState lineFeed
else push lineFeed $> Nothing
setFramesetNotOk
hasP <- hasInButtonScope ["p"]
close <- if hasP
then closePElement
else return []
insert <- insertElement $ mapTokenState' t' (lineFeedState <|>)
return $ close ++| insert
, If (isStartTag ["form"]) $ \t' -> do
state <- N.S.get
let hasTemplate = any (nodeIsElement "template" . snd) $ openElements state
if hasTemplate || Y.isJust (formElementPointer state)
then packTreeErrors [] t'
else do
hasP <- hasInButtonScope ["p"]
close <- if hasP
then closePElement
else return []
N.S.modify $ \state' -> state'
{ formElementPointer = Just $ elementIndex state'
}
insert <- insertElement t'
return $ close ++| insert
, If (isStartTag ["li"]) $ \t' -> do
setFramesetNotOk
state <- N.S.get
clear <- liLoop $ openElements state
hasP <- hasInButtonScope ["p"]
close <- if hasP
then closePElement
else return []
insert <- insertElement t'
return $ clear ++ close ++| insert
, If (isStartTag ["dd", "dt"]) $ \t' -> do
setFramesetNotOk
state <- N.S.get
clear <- ddLoop $ openElements state
hasP <- hasInButtonScope ["p"]
close <- if hasP
then closePElement
else return []
insert <- insertElement t'
return $ clear ++ close ++| insert
, If (isStartTag ["plaintext"]) $ \t' -> do
hasP <- hasInButtonScope ["p"]
close <- if hasP
then closePElement
else return []
insert <- insertElement . mapTokenState t' $ \state -> state
{ currentState = PlainTextState
}
return $ close ++| insert
, If (isStartTag ["button"]) $ \t' -> do
hasButton <- hasInScope ["button"]
nested <- if hasButton
then do
generate <- generateEndTags impliedEndTags
clear <- closeElement "button"
return . consTreeError_ NestedNonRecursiveElement $ generate ++ clear
else return []
format <- reconstructFormattingElements
insert <- insertElement t'
setFramesetNotOk
return $ nested ++ format ++| insert
, If (isEndTag
[ "address"
, "article"
, "aside"
, "blockquote"
, "button"
, "center"
, "details"
, "dialog"
, "dir"
, "div"
, "dl"
, "fieldset"
, "figcaption"
, "figure"
, "footer"
, "header"
, "hgroup"
, "listing"
, "main"
, "menu"
, "nav"
, "ol"
, "pre"
, "section"
, "summary"
, "ul"
]) $ \t' -> do
let d = tokenTag t'
hasMatch <- hasInScope [tagName d]
if hasMatch
then do
generate <- generateEndTags impliedEndTags
current <- currentNode
let errF = if maybe True (nodeIsElement $ tagName d) current
then id
else consTreeError_ UnexpectedElementWithImpliedEndTag
clear <- closeElement $ tagName d
packTree t' $ generate ++ errF clear
else packTreeErrors [UnmatchedEndTag $ tokenElement t'] t'
, If (isEndTag ["form"]) $ \t' -> do
state <- N.S.get
if Y.isJust . L.find (nodeIsElement "template" . snd) $ openElements state
then do
hasTemplate <- hasInScope ["template"]
if hasTemplate
then do
generate <- generateEndTags impliedEndTags
current <- currentNode
let errF = if maybe True (nodeIsElement "form") current
then id
else consTreeError_ UnexpectedElementWithImpliedEndTag
clear <- closeElement "form"
packTree t' $ generate ++ errF clear
else packTreeErrors [] t'
else do
let formElement = formElementPointer state
N.S.put $ state
{ formElementPointer = Nothing
}
hasFormElement <- maybe (return False) hasIndexInScope formElement
if hasFormElement
then do
generate <- generateEndTags impliedEndTags
let current = maybe 0 fst . Y.listToMaybe $ openElements state
es = takeWhile ((/=) (Y.fromMaybe current formElement) . fst) $
openElements state
errF = if null es
then id
else consTreeError_ UnexpectedElementWithImpliedEndTag
close <- closeAncestorNode_ . fromIntegral $ length es
packTree t' $ generate ++ errF close
else packTreeErrors [UnmatchedEndTag $ tokenElement t'] t'
, If (isEndTag ["p"]) $ \t' -> do
hasP <- hasInButtonScope ["p"]
ps <- if hasP
then closePElement
else fmap (consTreeError_ . UnmatchedEndTag $ tokenElement t') . insertNullElement_ $ emptyTagParams
{ tagName = "p"
}
packTree t' ps
, If (isEndTag ["li"]) $ \t' -> do
hasLi <- hasInListItemScope ["li"]
if hasLi
then do
generate <- generateEndTags $ L.delete "li" impliedEndTags
current <- currentNode
let errF = if maybe True (nodeIsElement "li") current
then id
else consTreeError_ UnexpectedElementWithImpliedEndTag
clear <- closeElement "li"
packTree t' $ generate ++ errF clear
else packTreeErrors [UnmatchedEndTag $ tokenElement t'] t'
, If (isEndTag ["dd", "dt"]) $ \t' -> do
let d = tokenTag t'
hasMatch <- hasInScope [tagName d]
if hasMatch
then do
generate <- generateEndTags $ L.delete (tagName d) impliedEndTags
current <- currentNode
let errF = if maybe True (nodeIsElement $ tagName d) current
then id
else consTreeError_ UnexpectedElementWithImpliedEndTag
clear <- closeElement $ tagName d
packTree t' $ generate ++ errF clear
else packTreeErrors [UnmatchedEndTag $ tokenElement t'] t'
, If (isEndTag $ map T.unpack headerNames) $ \t' -> do
let d = tokenTag t'
hasMatch <- hasInScope headerNames
if hasMatch
then do
generate <- generateEndTags $ L.delete (tagName d) impliedEndTags
current <- currentNode
let errF = if maybe True (nodeIsElement $ tagName d) current
then id
else consTreeError_ UnexpectedElementWithImpliedEndTag
clear <- closeElements headerNames
packTree t' $ generate ++ errF clear
else packTreeErrors [UnmatchedEndTag $ tokenElement t'] t'
, If (isStartTag ["a"]) $ \t' -> do
state <- N.S.get
let formatting = activeFormattingElements state
active = Y.fromMaybe [] $ Y.listToMaybe formatting
nested <- case L.find (\f -> tagName (snd f) == "a") active of
Just (i, _) -> do
adopt <- consTreeError NestedElementForAdoptionAgency <$> runAdoptionAgency t'
open' <- openElements <$> N.S.get
close <- case break ((==) i . fst) open' of
(_, []) -> return []
(es1, _) -> do
N.S.modify $ \state' -> state'
{ activeFormattingElements = case activeFormattingElements state' of
[] -> []
(es:ess) -> filter ((/=) i . fst) es : ess
}
closeAncestorNode_ . fromIntegral $ length es1
return $ adopt |++ close
Nothing -> packTreeErrors [] t'
format <- reconstructFormattingElements
insert <- insertFormattingElement t'
return $ nested |++| format ++| insert
, If (isStartTag
[ "b"
, "big"
, "code"
, "em"
, "font"
, "i"
, "s"
, "small"
, "strike"
, "strong"
, "tt"
, "u"
]) $ \t' -> do
format <- reconstructFormattingElements
insert <- insertFormattingElement t'
return $ format ++| insert
, If (isStartTag ["nobr"]) $ \t' -> do
format <- reconstructFormattingElements
hasNobr <- hasInScope ["nobr"]
nested <- if hasNobr
then do
--BUG: Adoption agency + insertion may duplicate the errors?
adopt <- consTreeError NestedElementForAdoptionAgency <$> runAdoptionAgency t'
format' <- reconstructFormattingElements
return $ adopt |++ format'
else packTreeErrors [] t'
insert <- insertFormattingElement t'
return $ format ++| nested |++| insert
, If (isEndTag
[ "a"
, "b"
, "big"
, "code"
, "em"
, "font"
, "i"
, "nobr"
, "s"
, "small"
, "strike"
, "strong"
, "tt"
, "u"
]) runAdoptionAgency
, If (isStartTag ["applet", "marquee", "object"]) $ \t' -> do
setFramesetNotOk
format <- reconstructFormattingElements
insertFormattingMarker
insert <- insertElement t'
return $ format ++| insert
, If (isEndTag ["applet", "marquee", "object"]) $ \t' -> do
let d = tokenTag t'
hasMatch <- hasInScope [tagName d]
if hasMatch
then do
generate <- generateEndTags impliedEndTags
current <- currentNode
let errF = if maybe True (nodeIsElement $ tagName d) current
then id
else consTreeError_ UnexpectedElementWithImpliedEndTag
clear <- closeElement $ tagName d
clearFormattingElements
packTree t' $ generate ++ errF clear
else packTreeErrors [UnmatchedEndTag $ tokenElement t'] t'
, If (isStartTag ["table"]) $ \t' -> do
hasP <- hasInButtonScope ["p"]
quirks <- (== FullQuirks) . quirksMode <$> N.S.get
clear <- if hasP && not quirks
then closePElement
else return []
insert <- insertElement t'
setFramesetNotOk
switchMode InTable
return $ clear ++| insert
, If (isEndTag ["br"]) $ \t' -> do
push . mapTokenErrs (BREndTag :) . flip mapTokenOut t' $
const (StartTag $ (tokenTag t') { tagAttributes = M.empty })
treeInBody
, If (isStartTag ["area", "br", "embed", "img", "keygen", "wbr"]) $ \t' -> do
setFramesetNotOk
format <- reconstructFormattingElements
insert <- insertNullElement t'
return $ format ++| insert
, If (isStartTag ["input"]) $ \t' -> do
case fmap snd . L.find (\a -> fst a == "type") . M.toList . tagAttributes $ tokenTag t' of
Nothing -> setFramesetNotOk
Just "hidden" -> return ()
Just _ -> setFramesetNotOk
format <- reconstructFormattingElements
insert <- insertNullElement t'
return $ format ++| insert
, If (isStartTag ["param", "source", "track"]) insertNullElement
, If (isStartTag ["hr"]) $ \t' -> do
setFramesetNotOk
hasP <- hasInButtonScope ["p"]
close <- if hasP
then closePElement
else return []
insert <- insertNullElement t'
return $ close ++| insert
, If (isStartTag ["image"]) $ \t' -> do
push . mapTokenErrs (ObsoleteTagName "image" :) . flip mapTokenOut t' $
const (StartTag $ (tokenTag t') { tagName = "img" })
treeInBody
, If (isStartTag ["textarea"]) $ \t' -> do
lineFeed <- next
lineFeedState <- if tokenOut lineFeed == Character '\n'
then return $ tokenState lineFeed
else push lineFeed $> Nothing
setFramesetNotOk
genericRCDataElement $ mapTokenState' t' (lineFeedState <|>)
, If (isStartTag ["xmp"]) $ \t' -> do
setFramesetNotOk
hasP <- hasInButtonScope ["p"]
close <- if hasP
then closePElement
else return []
format <- reconstructFormattingElements
text <- genericRawTextElement t'
return $ close ++ format ++| text
, If (isStartTag ["iframe"]) $ \t' -> do
setFramesetNotOk
genericRawTextElement t'
, If (isStartTag ["noembed"]) genericRawTextElement
, If (isStartTag ["noscript"]) $ \t' -> do
state <- N.S.get
if scriptingEnabled state
then genericRawTextElement t'
else do -- "any other start tag"
format <- reconstructFormattingElements
insert <- insertElement t'
return $ format ++| insert
, If (isStartTag ["select"]) $ \t' -> do
setFramesetNotOk
state <- N.S.get
switchMode $ if elem (insertionMode state)
[ InTable
, InCaption
, InTableBody
, InRow
, InCell
]
then InSelectInTable
else InSelect
format <- reconstructFormattingElements
insert <- insertElement t'
return $ format ++| insert
, If (isStartTag ["optgroup", "option"]) $ \t' -> do
current <- currentNode
format <- case fmap elementName current of
Just "option" -> do
close <- closeCurrentNode_
format' <- reconstructFormattingElements
return $ close ++ format'
_ -> reconstructFormattingElements
insert <- insertElement t'
return $ format ++| insert
, If (isStartTag ["rb", "rtc"]) $ \t' -> do
hasRuby <- hasInScope ["ruby"]
generate <- if hasRuby
then do
generate' <- generateEndTags impliedEndTags
current <- currentNode
let errF = if maybe True (nodeIsElement "ruby") current
then id
else consTreeError_ UnexpectedElementWithImpliedEndTag
return $ errF generate'
else return []
insert <- insertElement t'
return $ generate ++| insert
, If (isStartTag ["rp", "rt"]) $ \t' -> do
hasRuby <- hasInScope ["ruby"]
generate <- if hasRuby
then do
generate' <- generateEndTags $ L.delete "rtc" impliedEndTags
current <- currentNode
let errF = if maybe True (\e -> nodeIsElement "ruby" e || nodeIsElement "rtc" e) current
then id
else consTreeError_ UnexpectedElementWithImpliedEndTag
return $ errF generate'
else return []
insert <- insertElement t'
return $ generate ++| insert
, If (isStartTag ["math"]) $ \t' -> do
let d = tokenTag t'
insertF
| tagIsSelfClosing d = insertForeignNullElement
| otherwise = insertForeignElement
format <- reconstructFormattingElements
insert <- insertF mathMLNamespace $ mapTokenOut (const . StartTag $ adjustMathMLAttributes d) t'
return $ format ++| insert
, If (isStartTag ["svg"]) $ \t' -> do
let d = tokenTag t'
insertF
| tagIsSelfClosing d = insertForeignNullElement
| otherwise = insertForeignElement
format <- reconstructFormattingElements
insert <- insertF svgNamespace $ mapTokenOut (const . StartTag $ adjustSvgAttributes d) t'
return $ format ++| insert
, If (isStartTag
[ "caption"
, "col"
, "colgroup"
, "frame"
, "head"
, "tbody"
, "td"
, "tfoot"
, "th"
, "thead"
, "tr"
]) $ \t' ->
packTreeErrors [UnexpectedDescendantElement $ tokenElement t'] t'
, If isAnyStartTag $ \t' -> do
format <- reconstructFormattingElements
insert <- insertElement t'
return $ format ++| insert
, If isAnyEndTag $ \t' -> do
state <- N.S.get
anyOtherEndTag (openElements state) t'
]
where headerNames = [ T.snoc "h" i | i <- ['1'..'6'] ]
hasUnexpectedOpenElement =
hasOpenElementExcept
[ "dd"
, "dt"
, "li"
, "optgroup"
, "option"
, "p"
, "rb"
, "rp"
, "rt"
, "rtc"
, "tbody"
, "td"
, "tfoot"
, "th"
, "thead"
, "tr"
, "body"
, "html"
]
-- | __HTML:__
-- the "any other end tag" entry in @[the "in body" insertion mode]
-- (https://html.spec.whatwg.org/multipage/parsing.html#parsing-main-inbody)@
--
-- Delegate a token to to the 'InBody' section of the state machine, but skip
-- the token-dependent behaviour and instead simply treat it according to the
-- fallback case for 'EndTag' tokens.
anyOtherEndTag
:: [(NodeIndex, ElementParams)]
-- ^ The stack of open elements.
-> TreeInput
-- ^ The token to process.
-> TreeBuilder TreeOutput
anyOtherEndTag [] t' = packTreeErrors [] t'
anyOtherEndTag ((i, e):es) t' = case tokenOut t' of
EndTag d | nodeIsElement (tagName d) e -> do
generate <- generateEndTags $ L.delete (tagName d) impliedEndTags
elementIndices <- map fst . openElements <$> N.S.get
let errF = if Y.listToMaybe elementIndices == Just i
then id
else consTreeError_ UnexpectedElementWithImpliedEndTag
count = length (takeWhile (/= i) elementIndices) + 1
clear <- clearCount $ fromIntegral count
packTree t' $ generate ++ errF clear
EndTag _ -> if nodeIsSpecial e
then packTreeErrors [UnexpectedElementWithImpliedEndTag] t'
else anyOtherEndTag es t'
_ -> packTreeErrors [] t'
-- | Check whether a node is in 'scopeElements' -- the tags which break
-- open-tag searches.
isScopeElement :: ElementParams -> Bool
isScopeElement d' = elem (Y.fromMaybe T.empty $ elementNamespace d', elementName d') scopeElements
-- | Check whether a node is in 'specialElements' -- the tags which are subject
-- to custom handling.
isSpecialElement :: ElementParams -> Bool
isSpecialElement d' = elem (Y.fromMaybe T.empty $ elementNamespace d', elementName d') specialElements
-- | __HTML:__
-- the substeps spanned by the /"Loop"/ for processing @\<dd\>@ and
-- @\<dt\>@ tags in @[the "in body" insertion mode]
-- (https://html.spec.whatwg.org/multipage/parsing.html#parsing-main-inbody)@
--
-- @\<dd\>@ and @\<dt\>@ elements should close most opened elements if the
-- relevant end tag is left implied.
ddLoop
:: [(NodeIndex, ElementParams)]
-- ^ The stack of open elements.
-> TreeBuilder [Patch]
ddLoop [] = return []
ddLoop ((_, e):es)
| nodeIsElement "dd" e = do
generate <- generateEndTags $ L.delete "dd" impliedEndTags
current <- currentNode
let err = case current of
Just e' | not $ nodeIsElement "dd" e' -> consTreeError_ UnexpectedElementWithImpliedEndTag
_ -> id
clear <- closeElement "dd"
return . err $ generate ++ clear
| nodeIsElement "dt" e = do
generate <- generateEndTags $ L.delete "dt" impliedEndTags
current <- currentNode
let err = case current of
Just e' | not $ nodeIsElement "dt" e' -> consTreeError_ UnexpectedElementWithImpliedEndTag
_ -> id
clear <- closeElement "dt"
return . err $ generate ++ clear
| nodeIsElement "address" e = ddLoop es
| nodeIsElement "div" e = ddLoop es
| nodeIsElement "p" e = ddLoop es
| isSpecialElement e = return []
| otherwise = ddLoop es
-- | __HTML:__
-- the substeps spanned by the /"Loop"/ for processing @\<li\>@ tags in
-- @[the "in body" insertion mode]
-- (https://html.spec.whatwg.org/multipage/parsing.html#parsing-main-inbody)@
--
-- @\<li\>@ elements should close most opened elements if the relevant end tag
-- is left implied.
liLoop
:: [(NodeIndex, ElementParams)]
-- ^ The stack of open elements.
-> TreeBuilder [Patch]
liLoop [] = return []
liLoop ((_, e):es)
| nodeIsElement "li" e = do
generate <- generateEndTags $ L.delete "li" impliedEndTags
current <- currentNode
let err = case current of
Just e' | not $ nodeIsElement "li" e' -> consTreeError_ UnexpectedElementWithImpliedEndTag
_ -> id
clear <- closeElement "li"
return . err $ generate ++ clear
| nodeIsElement "address" e = liLoop es
| nodeIsElement "div" e = liLoop es
| nodeIsElement "p" e = liLoop es
| isSpecialElement e = return []
| otherwise = liLoop es
-- | __HTML:__
-- @[adoption agency algorithm]
-- (https://html.spec.whatwg.org/multipage/parsing.html#adoption-agency-algorithm)@
--
-- Handle a misnested formatting element by closing its ancestors up to a
-- stable branch point, and then reconstructing the tree in a more logical
-- order.
runAdoptionAgency :: TreeInput -> TreeBuilder TreeOutput
runAdoptionAgency t' = case tokenOut t' of
StartTag d -> runAdoptionAgency' d
EndTag d -> runAdoptionAgency' d
_ -> packTreeErrors [] t'
where runAdoptionAgency' d = do
current <- currentNode
index <- currentNodeIndex
active <- concat . activeFormattingElements <$> N.S.get
let isCurrent = maybe False (nodeIsElement $ tagName d) current
inActive = Y.isJust $ L.find (\(i, _) -> Just i == index) active
if isCurrent && not inActive
then closeCurrentNode_ >>= packTree t'
else runAdoptionAgencyOuterLoop 8 t' d
-- | __HTML:__
-- the substeps spanned by the /"Outer loop"/ within the
-- @[adoption agency algorithm]
-- (https://html.spec.whatwg.org/multipage/parsing.html#adoption-agency-algorithm)@
--
-- Determine whether the current formatting element close tag is mis-nested,
-- and if so, close the element and reconstruct an equivalent formatting tree.
runAdoptionAgencyOuterLoop
:: Word
-- ^ The maximum number of times the loop should be run, to avoid
-- overly-costly input. Note that this implementation counts down
-- rather than up, and so this function should generally be passed @8@
-- when it is originally called to implement the official behaviour.
-> TreeInput
-- ^ The token to process.
-> TagParams
-- ^ The inner element data extracted from the second parameter.
-> TreeBuilder TreeOutput
-- 4.
runAdoptionAgencyOuterLoop 0 t' _ = packTreeErrors [] t'
runAdoptionAgencyOuterLoop i t' d = do
_ <- error "Adoption agency not yet implemented"
-- 6.
state <- N.S.get
let formatting = activeFormattingElements state
open = openElements state
case L.find (\f -> tagName (snd $ snd f) == tagName d) . zip [0..] $ concat formatting of
Nothing -> anyOtherEndTag open t'
Just (indexFormat, formattingElement) -> do
let removeFormattingElement = N.S.put $ state
{ activeFormattingElements = map (L.delete formattingElement) formatting
}
-- 7.
case L.elemIndex (fst formattingElement) (map fst open) of
Nothing -> do
removeFormattingElement
packTreeErrors [IncompletelyClosedFormattingElement] t'
Just indexOpen -> do
-- 8. Make use of the fact we can get an index rather than
-- just a 'Bool' when checking if the formatting element is
-- in the stack of open elements, to check if it's in
-- scope ('hasInScope' only checks the tag name, not UID).
let descendants = take indexOpen open
formattingNode = head $ drop indexOpen open
if any (isScopeElement . snd) descendants
then packTreeErrors [UnexpectedFormattingElementOutOfScope] t'
else do
-- 9.
let overlap = if maybe False (fst formattingElement ==) . Y.listToMaybe $ map fst open
then consTreeError_ OverlappingFormattingElements
else id
-- 10.
case L.find (isSpecialElement . snd) $ reverse descendants of
Nothing -> do
-- 11.
clear <- clearCount $ fromIntegral indexOpen
close <- closeCurrentNode_
removeFormattingElement
packTree t' $ overlap clear ++ close
Just furthestBlock -> do
-- 14.
(bookmark, lastTag) <-
runAdoptionAgencyInnerLoop 3 indexFormat formattingElement furthestBlock furthestBlock .
drop 1 $ dropWhile (/= furthestBlock) open
-- 15.
reparent <- case L.elemIndex (fst lastTag) $ map fst open of
Nothing -> return []
Just indexInner -> if indexInner < indexOpen
then closeAncestorNodes_
(fromIntegral indexInner)
(fromIntegral $ indexOpen - indexInner)
else return []
-- 16.
newElement <- createElement $ snd formattingNode
let newTag = unpackNodeData <$> newElement
N.S.modify $ \state' -> state'
-- 19.
{ activeFormattingElements =
let findBookmark _ [] = []
findBookmark bookmark' (es:ess)
| bookmark' > l = es : findBookmark (bookmark' - l) ess
| otherwise = (ds ++ newTag : drop 1 as) : ess
where l = length es
(ds, as) = splitAt bookmark' es
in findBookmark bookmark formatting
-- 20.
, openElements =
let es = L.delete formattingNode open
(ds, as) = break (== furthestBlock) es
in ds ++ newElement : as
}
-- 21.
recurse <- runAdoptionAgencyOuterLoop (i - 1) t' d
packTree t' $ overlap reparent ++ treePatches recurse
-- | __HTML:__
-- the substeps spanned by the /"Inner loop"/ within the
-- @[adoption agency algorithm]
-- (https://html.spec.whatwg.org/multipage/parsing.html#adoption-agency-algorithm)@
--
-- Close ancestor elements until reaching a stable node for the new tree, and
-- then reconstruct an equivalent tree.
runAdoptionAgencyInnerLoop
:: Word
-- ^ __HTML:__
-- @inner loop counter@
--
-- The maximum number of times the loop should be run, to avoid
-- overly-costly input. Note that this implementation counts down
-- rather than up, and so this function should generally be passed @3@.
-> Int
-- ^ __HTML:__
-- the bookmark noting the position of @formatting element@
-> (NodeIndex, TagParams)
-- ^ __HTML:__
-- @formatting element@
--
-- The node selected as the base of the reparenting process.
-> (NodeIndex, ElementParams)
-- ^ __HTML:__
-- @last node@
--
-- The child node actively being reparented.
-> (NodeIndex, ElementParams)
-- ^ __HTML:__
-- @furthest block@
--
-- The most senior descendant of @formatting element@ which will serve
-- as a secondary fixed point.
-> [(NodeIndex, ElementParams)]
-- ^ The stack of open elements; @inner node@ is derived from this.
-> TreeBuilder (Int, (NodeIndex, TagParams))
runAdoptionAgencyInnerLoop _ bookmark formattingElement _ _ [] = return (bookmark, formattingElement)
runAdoptionAgencyInnerLoop i bookmark formattingElement lastNode furthestBlock (innerNode:ns)
-- 4.
| fst formattingElement == fst innerNode = return (bookmark, formattingElement)
| otherwise = do
state <- N.S.get
let formatting = activeFormattingElements state
case L.elemIndex innerTag $ concat formatting of
Just innerIndex -> if i == 0
-- 5. / 6.
then do
N.S.modify $ \state' -> state'
--BUG: Not reflected in the patch list.
{ openElements = L.delete innerNode $ openElements state'
, activeFormattingElements = map (L.delete innerTag) formatting
}
let bookmark'
| innerIndex <= bookmark = pred bookmark
| otherwise = bookmark
runAdoptionAgencyInnerLoop i' bookmark' formattingElement lastNode furthestBlock ns
else do
-- 7.
newElement <- createElement $ snd innerNode
let newTag = unpackNodeData <$> newElement
N.S.modify $ \state' -> state'
{ openElements = replaceNode newElement innerNode $ openElements state'
, activeFormattingElements = map (replaceNode newTag innerTag) formatting
}
-- 8.
let bookmark'
| lastNode == furthestBlock =
maybe bookmark succ . L.elemIndex newTag $ concat formatting
| otherwise = bookmark
-- 10. / 11.
runAdoptionAgencyInnerLoop i' bookmark' formattingElement innerNode furthestBlock ns
-- 6.
Nothing -> do
N.S.modify $ \state' -> state'
--BUG: Not reflected in the patch list.
{ openElements = L.delete innerNode $ openElements state'
}
runAdoptionAgencyInnerLoop i' bookmark formattingElement lastNode furthestBlock ns
where i' = if i == 0 then 0 else i - 1
replaceNode newElement innerElement es = ds ++ newElement : drop 1 as
where (ds, as) = break (== innerElement) es
innerTag = unpackNodeData <$> innerNode
-- | Retrieve the data from the finalized form of the collection, and repack it
-- in the form expected by some of the parser combinators used by the
-- @runAdoptionAgency@ algorithm.
unpackNodeData :: ElementParams -> TagParams
unpackNodeData d = emptyTagParams
{ tagName = case elementPrefix d of
Just prefix -> prefix <> ":" <> elementName d
Nothing -> elementName d
, tagAttributes = M.fromList . map unpackAttribute . toAttrList $ elementAttributes d
-- Don't have to worry about self-closing tags, as if they're taking part
-- in the adoption agency algorithm, they must have been able to have
-- children.
}
where unpackAttribute d' = case attrPrefix d' of
Just prefix -> (prefix <> ":" <> attrName d', attrValue d')
Nothing -> (attrName d', attrValue d')