InTable.hs

{-# LANGUAGE OverloadedStrings #-}

{-|
Description:    Token processing rules within a @\<table\>@ markup section.

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

Stability:      stable
Portability:    portable
-}
module Web.Mangrove.Parse.Tree.InTable
    ( treeInTable
    , anythingElse
    ) where


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 Web.Mangrove.Parse.Common.Error
import Web.Mangrove.Parse.Tree.Common
import Web.Mangrove.Parse.Tree.InBody
import Web.Mangrove.Parse.Tree.InHead
import Web.Mangrove.Parse.Tree.Patch
import Web.Willow.Common.Parser
import Web.Willow.Common.Parser.Switch


-- | __HTML:__
--      @[the "in table" insertion mode]
--      (https://html.spec.whatwg.org/multipage/parsing.html#parsing-main-intable)@
-- 
-- The parsing instructions corresponding to the 'InTable' section of the state
-- machine.
treeInTable :: TreeBuilder TreeOutput
treeInTable = next >>= switch
    [ If isCharacter $ \t' -> do
        current <- currentNode
        let toTableText = do
                N.S.modify $ \state -> state
                    { insertionMode = InTableText
                    , originalInsertionMode = Just $ insertionMode state
                    }
                push t'
                switchMode InTableText
                packTree_ []
        case fmap elementName current of
            Just "table" -> toTableText
            Just "tbody" -> toTableText
            Just "tfoot" -> toTableText
            Just "thead" -> toTableText
            Just "tr" -> toTableText
            _ -> anythingElse t'
    , If isComment insertComment
    , If isDoctype $ \t' ->
        packTreeErrors [UnexpectedDoctype $ tokenDocumentType t'] t'
    , If (isStartTag ["caption"]) $ \t' -> do
        switchMode InCaption
        clear <- clearToContext tableContext
        insertFormattingMarker
        insert <- insertElement t'
        return $ clear ++| insert
    , If (isStartTag ["colgroup"]) $ \t' -> do
        switchMode InColumnGroup
        clear <- clearToContext tableContext
        insert <- insertElement t'
        return $ clear ++| insert
    , If (isStartTag ["col"]) $ \t' -> do
        push t'
        switchMode InColumnGroup
        clear <- clearToContext tableContext
        insert <- insertElement_ $ emptyTagParams
            { tagName = "colgroup"
            }
        packTree_ $ clear ++ insert
    , If (isStartTag ["tbody", "tfoot", "thead"]) $ \t' -> do
        switchMode InTableBody
        clear <- clearToContext tableContext
        insert <- insertElement t'
        return $ clear ++| insert
    , If (isStartTag ["td", "th", "tr"]) $ \t' -> do
        push t'
        switchMode InTableBody
        clear <- clearToContext tableContext
        insert <- insertElement_ $ emptyTagParams
            { tagName = "tbody"
            }
        packTree_ $ clear ++ insert
    , If (isStartTag ["table"]) $ \t' -> do
        hasTable <- hasInTableScope ["table"]
        if hasTable
            then do
                push t'
                close <- closeTable
                packTree_ close
            else packTreeErrors [NestedNonRecursiveElement] t'
    , If (isEndTag ["table"]) $ \t' -> do
        hasTable <- hasInTableScope ["table"]
        if hasTable
            then fmap (|++) (packTreeErrors [] t') <*> closeTable
            else packTreeErrors [UnmatchedEndTag $ tokenElement t'] t'
    , If (isEndTag
        [ "body"
        , "caption"
        , "col"
        , "colgroup"
        , "html"
        , "tbody"
        , "td"
        , "tfoot"
        , "th"
        , "thead"
        , "tr"
        ]) $ \t' ->
            packTreeErrors [UnexpectedDescendantElement $ tokenElement t'] t'
    , If (isStartTag ["style", "script", "template"]) $ \t' -> do
        push t'
        treeInHead
    , If (isEndTag ["template"]) $ \t' -> do
        push t'
        treeInHead
    , If (isStartTag ["input"]) $ \t' ->
        case L.find (== "type") . map fst . M.toList . tagAttributes $ tokenTag t' of
            Just "hidden" -> consTreeError UnexpectedElementInTableStructure <$> insertNullElement t'
            _ -> anythingElse t'
    , 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 [UnexpectedElementInTableStructure] t'
            else do
                N.S.modify $ \state' -> state'
                    { formElementPointer = Just $ elementIndex state'
                    }
                insertNullElement t'
    , If isEOF $ \t' -> do
        push t'
        treeInBody
    , Else anythingElse
    ]
  where closeTable = closeElement "table" <* resetInsertionMode


-- | __HTML:__
--      the "anything else" entry in @[the "in table" insertion mode]
--      (https://html.spec.whatwg.org/multipage/parsing.html#parsing-main-intable)@
-- 
-- Delegate a token to to the 'InTable' section of the state machine, but skip
-- the token-dependent behaviour and instead simply treat it according to the
-- fallback case.
anythingElse :: TreeInput -> TreeBuilder TreeOutput
anythingElse t' = do
    _ <- error "Foster parenting not yet implemented"
    N.S.modify $ \state -> state
        { fosteringEnabled = True
        }
    push t'
    out <- treeInBody
    N.S.modify $ \state -> state
        { fosteringEnabled = False
        }
    return $ consTreeError UnexpectedNodeInTableStructure out