{-# 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 :: TreeBuilder TreeOutput
treeInitial = 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)
-> (TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
     TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall test (m :: * -> *) out.
(test -> Bool) -> (test -> m out) -> SwitchCase test m out
If TreeInput -> Bool
isWhitespace ((TreeInput -> TreeBuilder TreeOutput)
 -> SwitchCase
      TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput)
-> (TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
     TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall a b. (a -> b) -> a -> b
$ [ParseError] -> TreeInput -> TreeBuilder TreeOutput
packTreeErrors []
    , (TreeInput -> Bool)
-> (TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
     TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall test (m :: * -> *) out.
(test -> Bool) -> (test -> m out) -> SwitchCase test m out
If TreeInput -> Bool
isComment ((TreeInput -> TreeBuilder TreeOutput)
 -> SwitchCase
      TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput)
-> (TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
     TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall a b. (a -> b) -> a -> b
$ InsertAt -> TreeInput -> TreeBuilder TreeOutput
insertComment' InsertAt
InDocument
    , (TreeInput -> Bool)
-> (TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
     TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall test (m :: * -> *) out.
(test -> Bool) -> (test -> m out) -> SwitchCase test m out
If TreeInput -> Bool
isDoctype ((TreeInput -> TreeBuilder TreeOutput)
 -> SwitchCase
      TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput)
-> (TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
     TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall a b. (a -> b) -> a -> b
$ \TreeInput
t' -> do
        InsertionMode -> TreeBuilder ()
switchMode InsertionMode
BeforeHtml
        TreeOutput
doctype <- TreeInput -> TreeBuilder TreeOutput
insertDoctype TreeInput
t'
        Bool
srcdoc <- TreeBuilder Bool
inIFrameSrcDoc
        [Patch]
quirks <- QuirksMode -> TreeBuilder [Patch]
setDocumentQuirks (QuirksMode -> TreeBuilder [Patch])
-> (DoctypeParams -> QuirksMode)
-> DoctypeParams
-> TreeBuilder [Patch]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> DoctypeParams -> QuirksMode
requiredQuirks Bool
srcdoc (DoctypeParams -> TreeBuilder [Patch])
-> DoctypeParams -> TreeBuilder [Patch]
forall a b. (a -> b) -> a -> b
$ TreeInput -> DoctypeParams
tokenDoctype TreeInput
t'
        TreeOutput -> TreeBuilder TreeOutput
forall (m :: * -> *) a. Monad m => a -> m a
return (TreeOutput -> TreeBuilder TreeOutput)
-> TreeOutput -> TreeBuilder TreeOutput
forall a b. (a -> b) -> a -> b
$ TreeOutput
doctype TreeOutput -> [Patch] -> TreeOutput
|++ [Patch]
quirks
    , (TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
     TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall test (m :: * -> *) out.
(test -> m out) -> SwitchCase test m out
Else ((TreeInput -> TreeBuilder TreeOutput)
 -> SwitchCase
      TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput)
-> (TreeInput -> TreeBuilder TreeOutput)
-> SwitchCase
     TreeInput (StateT TreeParserState (Parser [TreeInput])) TreeOutput
forall a b. (a -> b) -> a -> b
$ \TreeInput
t' -> do
        TreeInput -> TreeBuilder ()
forall (m :: * -> *) stream token.
MonadParser m stream token =>
token -> m ()
push TreeInput
t'
        InsertionMode -> TreeBuilder ()
switchMode InsertionMode
BeforeHtml
        Bool
srcdoc <- TreeBuilder Bool
inIFrameSrcDoc
        [Patch]
ps <- if Bool
srcdoc
            then [Patch] -> TreeBuilder [Patch]
forall (m :: * -> *) a. Monad m => a -> m a
return []
            else do
                [Patch]
quirks <- QuirksMode -> TreeBuilder [Patch]
setDocumentQuirks QuirksMode
FullQuirks
                [Patch] -> TreeBuilder [Patch]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Patch] -> TreeBuilder [Patch]) -> [Patch] -> TreeBuilder [Patch]
forall a b. (a -> b) -> a -> b
$ ParseError -> [Patch] -> [Patch]
consTreeError_ ParseError
MissingDoctype [Patch]
quirks
        [Patch] -> TreeBuilder TreeOutput
packTree_ [Patch]
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 :: Bool -> DoctypeParams -> QuirksMode
requiredQuirks Bool
True DoctypeParams
_ = QuirksMode
FullQuirks
requiredQuirks Bool
False DoctypeParams
d
    | DoctypeParams -> Bool
doctypeQuirks DoctypeParams
d = QuirksMode
FullQuirks
    | Maybe Text -> Bool
forall a. Maybe a -> Bool
Y.isJust Maybe Text
name Bool -> Bool -> Bool
&& Maybe Text
name Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"html" = QuirksMode
FullQuirks
    | Text
public Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"-//W3O//DTD W3 HTML STRICT 3.0//EN//" = QuirksMode
FullQuirks
    | Text
public Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"-/W3C/DTD HTML 4.0 TRANSITIONAL/EN" = QuirksMode
FullQuirks
    | Text
public Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"HTML" = QuirksMode
FullQuirks
    | Text
system Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"HTTP://WWW.IBM.COM/DATA/DTD/V11/IBMXHTML1-TRANSITIONAL.DTD" = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"+//SILMARIL//DTD HTML PRO V0R11 19970101//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//AS//DTD HTML 3.0 ASWEDIT + EXTENSIONS//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"//ADVASOFT LTD//DTD HTML 3.0 ASWEDIT + EXTENSIONS//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//IETF//DTD HTML 2.0 LEVEL 1//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//IETF//DTD HTML 2.0 LEVEL 2//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//IETF//DTD HTML 2.0 STRICT LEVEL 1//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//IETF//DTD HTML 2.0 STRICT LEVEL 2//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//IETF//DTD HTML 2.0 STRICT//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//IETF//DTD HTML 2.0//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//IETF//DTD HTML 2.1E//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//IETF//DTD HTML 3.0//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//IETF//DTD HTML 3.2 FINAL//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//IETF//DTD HTML 3.2//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//IETF//DTD HTML 3//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//IETF//DTD HTML LEVEL 0//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//IETF//DTD HTML LEVEL 1//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//IETF//DTD HTML LEVEL 2//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//IETF//DTD HTML LEVEL 3//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//IETF//DTD HTML STRICT LEVEL 0//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//IETF//DTD HTML STRICT LEVEL 1//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//IETF//DTD HTML STRICT LEVEL 2//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//IETF//DTD HTML STRICT LEVEL 3//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//IETF//DTD HTML STRICT//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//IETF//DTD HTML//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//METRIUS//DTD METRIUS PRESENTATIONAL//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//MICROSOFT//DTD INTERNET EXPLORER 2.0 HTML STRICT//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//MICROSOFT//DTD INTERNET EXPLORER 2.0 HTML//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//MICROSOFT//DTD INTERNET EXPLORER 2.0 TABLES//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//MICROSOFT//DTD INTERNET EXPLORER 3.0 HTML STRICT//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//MICROSOFT//DTD INTERNET EXPLORER 3.0 HTML//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//MICROSOFT//DTD INTERNET EXPLORER 3.0 TABLES//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//NETSCAPE COMM. CORP.//DTD HTML//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//NETSCAPE COMM. CORP.//DTD STRICT HTML//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//O'REILLY AND ASSOCIATES//DTD HTML 2.0//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//O'REILLY AND ASSOCIATES//DTD HTML EXTENDED 1.0//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//O'REILLY AND ASSOCIATES//DTD HTML EXTENDED RELAXED 1.0//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//SQ//DTD HTML 2.0 HOTMETAL + EXTENSIONS//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//SOFTQUAD SOFTWARE//DTD HOTMETAL PRO 6.0::19990601::EXTENSIONS TO HTML 4.0//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//SOFTQUAD//DTD HOTMETAL PRO 4.0::19971010::EXTENSIONS TO HTML 4.0//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//SPYGLASS//DTD HTML 2.0 EXTENDED//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//SUN MICROSYSTEMS CORP.//DTD HOTJAVA HTML//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//SUN MICROSYSTEMS CORP.//DTD HOTJAVA STRICT HTML//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//W3C//DTD HTML 3 1995-03-24//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//W3C//DTD HTML 3.2 DRAFT//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//W3C//DTD HTML 3.2 FINAL//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//W3C//DTD HTML 3.2//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//W3C//DTD HTML 3.2S DRAFT//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//W3C//DTD HTML 4.0 FRAMESET//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//W3C//DTD HTML 4.0 TRANSITIONAL//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//W3C//DTD HTML EXPERIMENTAL 19960712//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//W3C//DTD HTML EXPERIMENTAL 970421//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//W3C//DTD W3 HTML//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//W3O//DTD W3 HTML 3.0//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//WEBTECHS//DTD MOZILLA HTML 2.0//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//WEBTECHS//DTD MOZILLA HTML//" Text
public = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//W3C//DTD HTML 4.01 FRAMESET//" Text
public Bool -> Bool -> Bool
&& Maybe Text -> Bool
forall a. Maybe a -> Bool
Y.isNothing Maybe Text
system' = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//W3C//DTD HTML 4.01 TRANSITIONAL//" Text
public Bool -> Bool -> Bool
&& Maybe Text -> Bool
forall a. Maybe a -> Bool
Y.isNothing Maybe Text
system' = QuirksMode
FullQuirks
    | Text -> Text -> Bool
startsWith Text
"-//W3C//DTD XHTML 1.0 FRAMESET//" Text
public = QuirksMode
LimitedQuirks
    | Text -> Text -> Bool
startsWith Text
"-//W3C//DTD XHTML 1.0 TRANSITIONAL//" Text
public = QuirksMode
LimitedQuirks
    | Text -> Text -> Bool
startsWith Text
"-//W3C//DTD HTML 4.01 FRAMESET//" Text
public = QuirksMode
LimitedQuirks
    | Text -> Text -> Bool
startsWith Text
"-//W3C//DTD HTML 4.01 TRANSITIONAL//" Text
public = QuirksMode
LimitedQuirks
    | Bool
otherwise = QuirksMode
NoQuirks
  where name :: Maybe Text
name = DoctypeParams -> Maybe Text
doctypeName DoctypeParams
d
        public :: Text
public = Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
T.empty ((Char -> Char) -> Text -> Text
T.map Char -> Char
toAsciiUpper) Maybe Text
public'
        public' :: Maybe Text
public' = DoctypeParams -> Maybe Text
doctypePublicId DoctypeParams
d
        system :: Text
system = Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
T.empty ((Char -> Char) -> Text -> Text
T.map Char -> Char
toAsciiUpper) Maybe Text
system'
        system' :: Maybe Text
system' = DoctypeParams -> Maybe Text
doctypeSystemId DoctypeParams
d
        startsWith :: Text -> Text -> Bool
startsWith = Text -> Text -> Bool
T.isPrefixOf