Dispatcher.hs

{-|
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.Dispatcher
    ( dispatcher
    , dispatchHtml
    ) where


import qualified Control.Monad.Trans.State as N.S

import qualified Data.Text as T

import Web.Willow.DOM

import Web.Mangrove.Parse.Tree.Common
import Web.Mangrove.Parse.Tree.Patch
import Web.Willow.Common.Parser
import Web.Willow.Common.Parser.Switch

import Web.Mangrove.Parse.Tree.Initial
import Web.Mangrove.Parse.Tree.AfterAfterBody
import Web.Mangrove.Parse.Tree.AfterAfterFrameset
import Web.Mangrove.Parse.Tree.AfterBody
import Web.Mangrove.Parse.Tree.AfterFrameset
import Web.Mangrove.Parse.Tree.AfterHead
import Web.Mangrove.Parse.Tree.BeforeHead
import Web.Mangrove.Parse.Tree.BeforeHtml
import Web.Mangrove.Parse.Tree.Foreign
import Web.Mangrove.Parse.Tree.InBody
import Web.Mangrove.Parse.Tree.InCaption
import Web.Mangrove.Parse.Tree.InCell
import Web.Mangrove.Parse.Tree.InColumnGroup
import Web.Mangrove.Parse.Tree.InFrameset
import Web.Mangrove.Parse.Tree.InHead
import Web.Mangrove.Parse.Tree.InHeadNoscript
import Web.Mangrove.Parse.Tree.InRow
import Web.Mangrove.Parse.Tree.InSelect
import Web.Mangrove.Parse.Tree.InSelectInTable
import Web.Mangrove.Parse.Tree.InTable
import Web.Mangrove.Parse.Tree.InTableBody
import Web.Mangrove.Parse.Tree.InTableText
import Web.Mangrove.Parse.Tree.InTemplate
import Web.Mangrove.Parse.Tree.InText


-- | __HTML:__
--      @[tree construction dispatcher]
--      (https://html.spec.whatwg.org/multipage/parsing.html#tree-construction-dispatcher)@
-- 
-- Delegate parsing the binary stream to the appropriate content class: lenient
-- HTML (via insertion mode) or embedded, more-structured MathML/SVG content.
dispatcher :: TreeBuilder TreeOutput
dispatcher = dispatchToken
  where dispatchToken = do
            state <- N.S.get
            adjusted <- adjustedCurrentNode
            flip switch adjusted
                [ If_ (const $ null (openElements state)) dispatchHtml
                , If_ (\n -> (n >>= elementNamespace) == Just htmlNamespace) dispatchHtml
                , If_ (maybe False atMathMLIntegration) $ lookAhead next >>= switch
                    [ If_ (hasStartTagName $ T.pack "mglyph") treeForeign
                    , If_ (hasStartTagName $ T.pack "malignmark") treeForeign
                    , If_ isAnyStartTag dispatchHtml
                    , If_ isCharacter dispatchHtml
                    , Else_ treeForeign
                    ]
                , If_ (maybe False atHtmlIntegration) $ lookAhead next >>= switch
                    [ If_ isAnyStartTag dispatchHtml
                    , If_ isCharacter dispatchHtml
                    , Else_ treeForeign
                    ]
                -- 'isMathMLAnnotationXml' is less specific than
                -- 'atHtmlIntegration' and so needs to appear after it.
                , If_ (maybe False isMathMLAnnotationXml) $ lookAhead next >>= switch
                    [ If_ (hasStartTagName $ T.pack "svg") dispatchHtml
                    , Else_ treeForeign
                    ]
                , Else_ treeForeign
                ]
        hasStartTagName name t' = case tokenOut t' of
            StartTag d -> tagName d == name
            _ -> False


-- | __HTML:__
--      @[the rules for parsing tokens in HTML content]
--      (https://html.spec.whatwg.org/multipage/parsing.html#parsing-main-inhtml)@
-- 
-- Defer processing of the current token to the instructions defined by the
-- active 'insertionMode'.
dispatchHtml :: TreeBuilder TreeOutput
dispatchHtml = N.S.get >>= \state -> case insertionMode state of
    Initial -> treeInitial
    BeforeHtml -> treeBeforeHtml
    BeforeHead -> treeBeforeHead
    InHead -> treeInHead
    InHeadNoscript -> treeInHeadNoscript
    AfterHead -> treeAfterHead
    InBody -> treeInBody
    InText -> treeInText
    InTable -> treeInTable
    InTableText -> treeInTableText
    InCaption -> treeInCaption
    InColumnGroup -> treeInColumnGroup
    InTableBody -> treeInTableBody
    InRow -> treeInRow
    InCell -> treeInCell
    InSelect -> treeInSelect
    InSelectInTable -> treeInSelectInTable
    InTemplate -> treeInTemplate
    AfterBody -> treeAfterBody
    InFrameset -> treeInFrameset
    AfterFrameset -> treeAfterFrameset
    AfterAfterBody -> treeAfterAfterBody
    AfterAfterFrameset -> treeAfterAfterFrameset