{-|
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 :: TreeBuilder TreeOutput
dispatcher = TreeBuilder TreeOutput
dispatchToken
  where dispatchToken :: TreeBuilder TreeOutput
dispatchToken = do
            TreeParserState
state <- StateT TreeParserState (Parser [TreeInput]) TreeParserState
forall (m :: * -> *) s. Monad m => StateT s m s
N.S.get
            Maybe ElementParams
adjusted <- TreeBuilder (Maybe ElementParams)
adjustedCurrentNode
            ([SwitchCase
    (Maybe ElementParams)
    (StateT TreeParserState (Parser [TreeInput]))
    TreeOutput]
 -> Maybe ElementParams -> TreeBuilder TreeOutput)
-> Maybe ElementParams
-> [SwitchCase
      (Maybe ElementParams)
      (StateT TreeParserState (Parser [TreeInput]))
      TreeOutput]
-> TreeBuilder TreeOutput
forall a b c. (a -> b -> c) -> b -> a -> c
flip [SwitchCase
   (Maybe ElementParams)
   (StateT TreeParserState (Parser [TreeInput]))
   TreeOutput]
-> Maybe ElementParams -> TreeBuilder TreeOutput
forall (m :: * -> *) test out.
Alternative m =>
[SwitchCase test m out] -> test -> m out
switch Maybe ElementParams
adjusted
                [ (Maybe ElementParams -> Bool)
-> TreeBuilder TreeOutput
-> SwitchCase
     (Maybe ElementParams)
     (StateT TreeParserState (Parser [TreeInput]))
     TreeOutput
forall test (m :: * -> *) out.
(test -> Bool) -> m out -> SwitchCase test m out
If_ (Bool -> Maybe ElementParams -> Bool
forall a b. a -> b -> a
const (Bool -> Maybe ElementParams -> Bool)
-> Bool -> Maybe ElementParams -> Bool
forall a b. (a -> b) -> a -> b
$ [(NodeIndex, ElementParams)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (TreeParserState -> [(NodeIndex, ElementParams)]
openElements TreeParserState
state)) TreeBuilder TreeOutput
dispatchHtml
                , (Maybe ElementParams -> Bool)
-> TreeBuilder TreeOutput
-> SwitchCase
     (Maybe ElementParams)
     (StateT TreeParserState (Parser [TreeInput]))
     TreeOutput
forall test (m :: * -> *) out.
(test -> Bool) -> m out -> SwitchCase test m out
If_ (\Maybe ElementParams
n -> (Maybe ElementParams
n Maybe ElementParams
-> (ElementParams -> Maybe Namespace) -> Maybe Namespace
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ElementParams -> Maybe Namespace
elementNamespace) Maybe Namespace -> Maybe Namespace -> Bool
forall a. Eq a => a -> a -> Bool
== Namespace -> Maybe Namespace
forall a. a -> Maybe a
Just Namespace
htmlNamespace) TreeBuilder TreeOutput
dispatchHtml
                , (Maybe ElementParams -> Bool)
-> TreeBuilder TreeOutput
-> SwitchCase
     (Maybe ElementParams)
     (StateT TreeParserState (Parser [TreeInput]))
     TreeOutput
forall test (m :: * -> *) out.
(test -> Bool) -> m out -> SwitchCase test m out
If_ (Bool -> (ElementParams -> Bool) -> Maybe ElementParams -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ElementParams -> Bool
atMathMLIntegration) (TreeBuilder TreeOutput
 -> SwitchCase
      (Maybe ElementParams)
      (StateT TreeParserState (Parser [TreeInput]))
      TreeOutput)
-> TreeBuilder TreeOutput
-> SwitchCase
     (Maybe ElementParams)
     (StateT TreeParserState (Parser [TreeInput]))
     TreeOutput
forall a b. (a -> b) -> a -> b
$ StateT TreeParserState (Parser [TreeInput]) TreeInput
-> StateT TreeParserState (Parser [TreeInput]) TreeInput
forall (m :: * -> *) stream token out.
MonadParser m stream token =>
m out -> m out
lookAhead 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)
-> TreeBuilder TreeOutput
-> SwitchCase
     TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall test (m :: * -> *) out.
(test -> Bool) -> m out -> SwitchCase test m out
If_ (Namespace -> TreeInput -> Bool
hasStartTagName (Namespace -> TreeInput -> Bool) -> Namespace -> TreeInput -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Namespace
T.pack String
"mglyph") TreeBuilder TreeOutput
treeForeign
                    , (TreeInput -> Bool)
-> TreeBuilder TreeOutput
-> SwitchCase
     TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall test (m :: * -> *) out.
(test -> Bool) -> m out -> SwitchCase test m out
If_ (Namespace -> TreeInput -> Bool
hasStartTagName (Namespace -> TreeInput -> Bool) -> Namespace -> TreeInput -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Namespace
T.pack String
"malignmark") TreeBuilder TreeOutput
treeForeign
                    , (TreeInput -> Bool)
-> TreeBuilder TreeOutput
-> SwitchCase
     TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall test (m :: * -> *) out.
(test -> Bool) -> m out -> SwitchCase test m out
If_ TreeInput -> Bool
isAnyStartTag TreeBuilder TreeOutput
dispatchHtml
                    , (TreeInput -> Bool)
-> TreeBuilder TreeOutput
-> SwitchCase
     TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall test (m :: * -> *) out.
(test -> Bool) -> m out -> SwitchCase test m out
If_ TreeInput -> Bool
isCharacter TreeBuilder TreeOutput
dispatchHtml
                    , TreeBuilder TreeOutput
-> SwitchCase
     TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall test (m :: * -> *) out. m out -> SwitchCase test m out
Else_ TreeBuilder TreeOutput
treeForeign
                    ]
                , (Maybe ElementParams -> Bool)
-> TreeBuilder TreeOutput
-> SwitchCase
     (Maybe ElementParams)
     (StateT TreeParserState (Parser [TreeInput]))
     TreeOutput
forall test (m :: * -> *) out.
(test -> Bool) -> m out -> SwitchCase test m out
If_ (Bool -> (ElementParams -> Bool) -> Maybe ElementParams -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ElementParams -> Bool
atHtmlIntegration) (TreeBuilder TreeOutput
 -> SwitchCase
      (Maybe ElementParams)
      (StateT TreeParserState (Parser [TreeInput]))
      TreeOutput)
-> TreeBuilder TreeOutput
-> SwitchCase
     (Maybe ElementParams)
     (StateT TreeParserState (Parser [TreeInput]))
     TreeOutput
forall a b. (a -> b) -> a -> b
$ StateT TreeParserState (Parser [TreeInput]) TreeInput
-> StateT TreeParserState (Parser [TreeInput]) TreeInput
forall (m :: * -> *) stream token out.
MonadParser m stream token =>
m out -> m out
lookAhead 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)
-> TreeBuilder TreeOutput
-> SwitchCase
     TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall test (m :: * -> *) out.
(test -> Bool) -> m out -> SwitchCase test m out
If_ TreeInput -> Bool
isAnyStartTag TreeBuilder TreeOutput
dispatchHtml
                    , (TreeInput -> Bool)
-> TreeBuilder TreeOutput
-> SwitchCase
     TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall test (m :: * -> *) out.
(test -> Bool) -> m out -> SwitchCase test m out
If_ TreeInput -> Bool
isCharacter TreeBuilder TreeOutput
dispatchHtml
                    , TreeBuilder TreeOutput
-> SwitchCase
     TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall test (m :: * -> *) out. m out -> SwitchCase test m out
Else_ TreeBuilder TreeOutput
treeForeign
                    ]
                -- 'isMathMLAnnotationXml' is less specific than
                -- 'atHtmlIntegration' and so needs to appear after it.
                , (Maybe ElementParams -> Bool)
-> TreeBuilder TreeOutput
-> SwitchCase
     (Maybe ElementParams)
     (StateT TreeParserState (Parser [TreeInput]))
     TreeOutput
forall test (m :: * -> *) out.
(test -> Bool) -> m out -> SwitchCase test m out
If_ (Bool -> (ElementParams -> Bool) -> Maybe ElementParams -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ElementParams -> Bool
isMathMLAnnotationXml) (TreeBuilder TreeOutput
 -> SwitchCase
      (Maybe ElementParams)
      (StateT TreeParserState (Parser [TreeInput]))
      TreeOutput)
-> TreeBuilder TreeOutput
-> SwitchCase
     (Maybe ElementParams)
     (StateT TreeParserState (Parser [TreeInput]))
     TreeOutput
forall a b. (a -> b) -> a -> b
$ StateT TreeParserState (Parser [TreeInput]) TreeInput
-> StateT TreeParserState (Parser [TreeInput]) TreeInput
forall (m :: * -> *) stream token out.
MonadParser m stream token =>
m out -> m out
lookAhead 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)
-> TreeBuilder TreeOutput
-> SwitchCase
     TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall test (m :: * -> *) out.
(test -> Bool) -> m out -> SwitchCase test m out
If_ (Namespace -> TreeInput -> Bool
hasStartTagName (Namespace -> TreeInput -> Bool) -> Namespace -> TreeInput -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Namespace
T.pack String
"svg") TreeBuilder TreeOutput
dispatchHtml
                    , TreeBuilder TreeOutput
-> SwitchCase
     TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall test (m :: * -> *) out. m out -> SwitchCase test m out
Else_ TreeBuilder TreeOutput
treeForeign
                    ]
                , TreeBuilder TreeOutput
-> SwitchCase
     (Maybe ElementParams)
     (StateT TreeParserState (Parser [TreeInput]))
     TreeOutput
forall test (m :: * -> *) out. m out -> SwitchCase test m out
Else_ TreeBuilder TreeOutput
treeForeign
                ]
        hasStartTagName :: Namespace -> TreeInput -> Bool
hasStartTagName Namespace
name TreeInput
t' = case TreeInput -> Token
tokenOut TreeInput
t' of
            StartTag TagParams
d -> TagParams -> Namespace
tagName TagParams
d Namespace -> Namespace -> Bool
forall a. Eq a => a -> a -> Bool
== Namespace
name
            Token
_ -> Bool
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 :: TreeBuilder TreeOutput
dispatchHtml = StateT TreeParserState (Parser [TreeInput]) TreeParserState
forall (m :: * -> *) s. Monad m => StateT s m s
N.S.get StateT TreeParserState (Parser [TreeInput]) TreeParserState
-> (TreeParserState -> TreeBuilder TreeOutput)
-> TreeBuilder TreeOutput
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TreeParserState
state -> case TreeParserState -> InsertionMode
insertionMode TreeParserState
state of
    InsertionMode
Initial -> TreeBuilder TreeOutput
treeInitial
    InsertionMode
BeforeHtml -> TreeBuilder TreeOutput
treeBeforeHtml
    InsertionMode
BeforeHead -> TreeBuilder TreeOutput
treeBeforeHead
    InsertionMode
InHead -> TreeBuilder TreeOutput
treeInHead
    InsertionMode
InHeadNoscript -> TreeBuilder TreeOutput
treeInHeadNoscript
    InsertionMode
AfterHead -> TreeBuilder TreeOutput
treeAfterHead
    InsertionMode
InBody -> TreeBuilder TreeOutput
treeInBody
    InsertionMode
InText -> TreeBuilder TreeOutput
treeInText
    InsertionMode
InTable -> TreeBuilder TreeOutput
treeInTable
    InsertionMode
InTableText -> TreeBuilder TreeOutput
treeInTableText
    InsertionMode
InCaption -> TreeBuilder TreeOutput
treeInCaption
    InsertionMode
InColumnGroup -> TreeBuilder TreeOutput
treeInColumnGroup
    InsertionMode
InTableBody -> TreeBuilder TreeOutput
treeInTableBody
    InsertionMode
InRow -> TreeBuilder TreeOutput
treeInRow
    InsertionMode
InCell -> TreeBuilder TreeOutput
treeInCell
    InsertionMode
InSelect -> TreeBuilder TreeOutput
treeInSelect
    InsertionMode
InSelectInTable -> TreeBuilder TreeOutput
treeInSelectInTable
    InsertionMode
InTemplate -> TreeBuilder TreeOutput
treeInTemplate
    InsertionMode
AfterBody -> TreeBuilder TreeOutput
treeAfterBody
    InsertionMode
InFrameset -> TreeBuilder TreeOutput
treeInFrameset
    InsertionMode
AfterFrameset -> TreeBuilder TreeOutput
treeAfterFrameset
    InsertionMode
AfterAfterBody -> TreeBuilder TreeOutput
treeAfterAfterBody
    InsertionMode
AfterAfterFrameset -> TreeBuilder TreeOutput
treeAfterAfterFrameset