Initial.hs

{-# LANGUAGE OverloadedStrings #-}

{-|
Description:    Token processing rules before the doctype declaration.

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

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


import qualified Data.Maybe as Y
import qualified Data.Text as T

import Web.Mangrove.Parse.Common.Error
import Web.Mangrove.Parse.Tokenize.Common
import Web.Mangrove.Parse.Tree.Common
import Web.Mangrove.Parse.Tree.Patch
import Web.Willow.Common.Encoding.Character
import Web.Willow.Common.Parser
import Web.Willow.Common.Parser.Switch


-- | __HTML:__
--      @[the "initial" insertion mode]
--      (https://html.spec.whatwg.org/multipage/parsing.html#the-initial-insertion-mode)@
-- 
-- The parsing instructions corresponding to the 'Initial' section of the
-- state machine.
treeInitial :: TreeBuilder TreeOutput
treeInitial = next >>= switch
    [ If isWhitespace $ packTreeErrors []
    , If isComment $ insertComment' InDocument
    , If isDoctype $ \t' -> do
        switchMode BeforeHtml
        doctype <- insertDoctype t'
        srcdoc <- inIFrameSrcDoc
        quirks <- setDocumentQuirks . requiredQuirks srcdoc $ tokenDoctype t'
        return $ doctype |++ quirks
    , Else $ \t' -> do
        push t'
        switchMode BeforeHtml
        srcdoc <- inIFrameSrcDoc
        ps <- if srcdoc
            then return []
            else do
                quirks <- setDocumentQuirks FullQuirks
                return $ consTreeError_ MissingDoctype quirks
        packTree_ ps
    ]

-- | Compare the addresses in the document type declaration to known values
-- which should trigger the backwards-compatible rendering mode.
requiredQuirks :: Bool -> DoctypeParams -> QuirksMode
requiredQuirks True _ = FullQuirks
requiredQuirks False d
    | doctypeQuirks d = FullQuirks
    | Y.isJust name && name /= Just "html" = FullQuirks
    | public == "-//W3O//DTD W3 HTML STRICT 3.0//EN//" = FullQuirks
    | public == "-/W3C/DTD HTML 4.0 TRANSITIONAL/EN" = FullQuirks
    | public == "HTML" = FullQuirks
    | system == "HTTP://WWW.IBM.COM/DATA/DTD/V11/IBMXHTML1-TRANSITIONAL.DTD" = FullQuirks
    | startsWith "+//SILMARIL//DTD HTML PRO V0R11 19970101//" public = FullQuirks
    | startsWith "-//AS//DTD HTML 3.0 ASWEDIT + EXTENSIONS//" public = FullQuirks
    | startsWith "//ADVASOFT LTD//DTD HTML 3.0 ASWEDIT + EXTENSIONS//" public = FullQuirks
    | startsWith "-//IETF//DTD HTML 2.0 LEVEL 1//" public = FullQuirks
    | startsWith "-//IETF//DTD HTML 2.0 LEVEL 2//" public = FullQuirks
    | startsWith "-//IETF//DTD HTML 2.0 STRICT LEVEL 1//" public = FullQuirks
    | startsWith "-//IETF//DTD HTML 2.0 STRICT LEVEL 2//" public = FullQuirks
    | startsWith "-//IETF//DTD HTML 2.0 STRICT//" public = FullQuirks
    | startsWith "-//IETF//DTD HTML 2.0//" public = FullQuirks
    | startsWith "-//IETF//DTD HTML 2.1E//" public = FullQuirks
    | startsWith "-//IETF//DTD HTML 3.0//" public = FullQuirks
    | startsWith "-//IETF//DTD HTML 3.2 FINAL//" public = FullQuirks
    | startsWith "-//IETF//DTD HTML 3.2//" public = FullQuirks
    | startsWith "-//IETF//DTD HTML 3//" public = FullQuirks
    | startsWith "-//IETF//DTD HTML LEVEL 0//" public = FullQuirks
    | startsWith "-//IETF//DTD HTML LEVEL 1//" public = FullQuirks
    | startsWith "-//IETF//DTD HTML LEVEL 2//" public = FullQuirks
    | startsWith "-//IETF//DTD HTML LEVEL 3//" public = FullQuirks
    | startsWith "-//IETF//DTD HTML STRICT LEVEL 0//" public = FullQuirks
    | startsWith "-//IETF//DTD HTML STRICT LEVEL 1//" public = FullQuirks
    | startsWith "-//IETF//DTD HTML STRICT LEVEL 2//" public = FullQuirks
    | startsWith "-//IETF//DTD HTML STRICT LEVEL 3//" public = FullQuirks
    | startsWith "-//IETF//DTD HTML STRICT//" public = FullQuirks
    | startsWith "-//IETF//DTD HTML//" public = FullQuirks
    | startsWith "-//METRIUS//DTD METRIUS PRESENTATIONAL//" public = FullQuirks
    | startsWith "-//MICROSOFT//DTD INTERNET EXPLORER 2.0 HTML STRICT//" public = FullQuirks
    | startsWith "-//MICROSOFT//DTD INTERNET EXPLORER 2.0 HTML//" public = FullQuirks
    | startsWith "-//MICROSOFT//DTD INTERNET EXPLORER 2.0 TABLES//" public = FullQuirks
    | startsWith "-//MICROSOFT//DTD INTERNET EXPLORER 3.0 HTML STRICT//" public = FullQuirks
    | startsWith "-//MICROSOFT//DTD INTERNET EXPLORER 3.0 HTML//" public = FullQuirks
    | startsWith "-//MICROSOFT//DTD INTERNET EXPLORER 3.0 TABLES//" public = FullQuirks
    | startsWith "-//NETSCAPE COMM. CORP.//DTD HTML//" public = FullQuirks
    | startsWith "-//NETSCAPE COMM. CORP.//DTD STRICT HTML//" public = FullQuirks
    | startsWith "-//O'REILLY AND ASSOCIATES//DTD HTML 2.0//" public = FullQuirks
    | startsWith "-//O'REILLY AND ASSOCIATES//DTD HTML EXTENDED 1.0//" public = FullQuirks
    | startsWith "-//O'REILLY AND ASSOCIATES//DTD HTML EXTENDED RELAXED 1.0//" public = FullQuirks
    | startsWith "-//SQ//DTD HTML 2.0 HOTMETAL + EXTENSIONS//" public = FullQuirks
    | startsWith "-//SOFTQUAD SOFTWARE//DTD HOTMETAL PRO 6.0::19990601::EXTENSIONS TO HTML 4.0//" public = FullQuirks
    | startsWith "-//SOFTQUAD//DTD HOTMETAL PRO 4.0::19971010::EXTENSIONS TO HTML 4.0//" public = FullQuirks
    | startsWith "-//SPYGLASS//DTD HTML 2.0 EXTENDED//" public = FullQuirks
    | startsWith "-//SUN MICROSYSTEMS CORP.//DTD HOTJAVA HTML//" public = FullQuirks
    | startsWith "-//SUN MICROSYSTEMS CORP.//DTD HOTJAVA STRICT HTML//" public = FullQuirks
    | startsWith "-//W3C//DTD HTML 3 1995-03-24//" public = FullQuirks
    | startsWith "-//W3C//DTD HTML 3.2 DRAFT//" public = FullQuirks
    | startsWith "-//W3C//DTD HTML 3.2 FINAL//" public = FullQuirks
    | startsWith "-//W3C//DTD HTML 3.2//" public = FullQuirks
    | startsWith "-//W3C//DTD HTML 3.2S DRAFT//" public = FullQuirks
    | startsWith "-//W3C//DTD HTML 4.0 FRAMESET//" public = FullQuirks
    | startsWith "-//W3C//DTD HTML 4.0 TRANSITIONAL//" public = FullQuirks
    | startsWith "-//W3C//DTD HTML EXPERIMENTAL 19960712//" public = FullQuirks
    | startsWith "-//W3C//DTD HTML EXPERIMENTAL 970421//" public = FullQuirks
    | startsWith "-//W3C//DTD W3 HTML//" public = FullQuirks
    | startsWith "-//W3O//DTD W3 HTML 3.0//" public = FullQuirks
    | startsWith "-//WEBTECHS//DTD MOZILLA HTML 2.0//" public = FullQuirks
    | startsWith "-//WEBTECHS//DTD MOZILLA HTML//" public = FullQuirks
    | startsWith "-//W3C//DTD HTML 4.01 FRAMESET//" public && Y.isNothing system' = FullQuirks
    | startsWith "-//W3C//DTD HTML 4.01 TRANSITIONAL//" public && Y.isNothing system' = FullQuirks
    | startsWith "-//W3C//DTD XHTML 1.0 FRAMESET//" public = LimitedQuirks
    | startsWith "-//W3C//DTD XHTML 1.0 TRANSITIONAL//" public = LimitedQuirks
    | startsWith "-//W3C//DTD HTML 4.01 FRAMESET//" public = LimitedQuirks
    | startsWith "-//W3C//DTD HTML 4.01 TRANSITIONAL//" public = LimitedQuirks
    | otherwise = NoQuirks
  where name = doctypeName d
        public = maybe T.empty (T.map toAsciiUpper) public'
        public' = doctypePublicId d
        system = maybe T.empty (T.map toAsciiUpper) system'
        system' = doctypeSystemId d
        startsWith = T.isPrefixOf