InSelect.hs

{-# LANGUAGE OverloadedStrings #-}

{-|
Description:    Token processing rules within a @\<select\>@ set of choices for user input.

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

Stability:      stable
Portability:    portable
-}
module Web.Mangrove.Parse.Tree.InSelect
    ( treeInSelect
    ) where


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

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 select" insertion mode]
--      (https://html.spec.whatwg.org/multipage/parsing.html#parsing-main-inselect)@
-- 
-- The parsing instructions corresponding to the 'InSelect' section of the
-- state machine.
treeInSelect :: TreeBuilder TreeOutput
treeInSelect = next >>= switch
    [ If isNull $ packTreeErrors [UnexpectedNullCharacter]
    , If isCharacter insertCharacter
    , If isComment insertComment
    , If isDoctype $ \t' ->
        packTreeErrors [UnexpectedDoctype $ tokenDocumentType t'] t'
    , If (isStartTag ["html"]) $ \t' -> do
        push t'
        treeInBody
    , If (isStartTag ["option"]) $ \t' -> do
        current <- currentNode
        close <- if maybe False (nodeIsElement "option") current
            then closeCurrentNode_
            else return []
        insert <- insertElement t'
        return $ close ++| insert
    , If (isStartTag ["optgroup"]) $ \t' -> do
        current <- currentNode
        option <- if maybe False (nodeIsElement "option") current
            then closeCurrentNode_
            else return []
        current' <- currentNode
        optgroup <- if maybe False (nodeIsElement "optgroup") current'
            then closeCurrentNode_
            else return []
        insert <- insertElement t'
        return $ option ++ optgroup ++| insert
    , If (isEndTag ["optgroup"]) $ \t' -> do
        current <- currentNode
        second <- fmap snd . Y.listToMaybe . drop 1 . openElements <$> N.S.get
        let firstIsOption = maybe False (nodeIsElement "option") current
            secondIsOptgroup = maybe False (nodeIsElement "optgroup") second
        option <- if firstIsOption && secondIsOptgroup
            then closeCurrentNode_
            else return []
        current' <- currentNode
        optgroup <- if maybe False (nodeIsElement "optgroup") current'
            then closeCurrentNode t'
            else packTreeErrors [UnmatchedEndTag $ tokenElement t'] t'
        return $ option ++| optgroup
    , If (isEndTag ["option"]) $ \t' -> do
        current <- currentNode
        if maybe False (nodeIsElement "option") current
            then closeCurrentNode t'
            else packTreeErrors [UnmatchedEndTag $ tokenElement t'] t'
    , If (isEndTag ["select"]) $ \t' -> do
        hasSelect <- hasInSelectScope ["select"]
        if hasSelect
            then do
                close <- closeElement "select"
                resetInsertionMode
                packTree t' close
            else packTreeErrors [UnmatchedEndTag $ tokenElement t'] t'
    , If (isStartTag ["select"]) $ \t' -> do
        hasSelect <- hasInSelectScope ["select"]
        consTreeError NestedNonRecursiveElement <$> if hasSelect
            then do
                close <- closeElement "select"
                resetInsertionMode
                packTree t' close
            else packTreeErrors [] t'
    , If (isStartTag ["input", "keygen", "textarea"]) $ \t' -> do
        hasSelect <- hasInSelectScope ["select"]
        consTreeError OverlappingInputElements <$> if hasSelect
            then do
                push t'
                close <- closeElement "select"
                resetInsertionMode
                packTree_ close
            else packTreeErrors [] t'
    , If (isStartTag ["script", "template"]) $ \t' -> do
        push t'
        treeInHead
    , If (isEndTag ["template"]) $ \t' -> do
        push t'
        treeInHead
    , If isEOF $ \t' -> do
        push t'
        treeInBody
    , Else $ \t' ->
        packTreeErrors [UnexpectedDescendantElement $ tokenElement t'] t'
    ]