diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,9 @@ +# Change Log + +## 2.0.0 + +* Initial FOSS release + +## 1.0.0 + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2020 Michael Williams + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,241 @@ +# Zenacy HTML [![Hackage version](https://img.shields.io/hackage/v/zenacy-html.svg?label=Hackage)](https://hackage.haskell.org/package/zenacy-html) [![Stackage version](https://www.stackage.org/package/zenacy-html/badge/nightly?label=Stackage)](https://www.stackage.org/package/zenacy-html) [![Linux build status](https://img.shields.io/travis/mlcfp/zenacy-html/master.svg?label=Linux%20build)](https://travis-ci.org/mlcfp/zenacy-html) + +Zenacy HTML is an HTML parsing and processing library that implements the +WHATWG HTML parsing standard. The standard is described as a state machine +that this library implements exactly as spelled out including all the error +handling, recovery, and conformance checks that makes it robust in handling +any HTML pulled from the web. In addition to parsing, the library provides +many processing features to help extract information from web pages or +rewrite them and render the modified results. + +## Introduction + +The Zenacy HTML parser is an implementation of the HTML parsing standard +defined by the WHATWG. + +https://html.spec.whatwg.org/multipage/parsing.html + +The standard defines a parsing state machine, so it is very prescriptive +on how HTML is handled including many edge cases and error recovery. +This library aims to follow the standard closely in such a way to match the +code back to the standard and make future updates straightforward. + +One of the main uses an a HTML parser is for extracting information from +the web. Having a parser that can handle all the nuances of poorly +formatted HTML helps to make this extraction as robust as possible. +This was a key motivation in deciding to implement a parser in this fashion. +Additionally, the standard describes the algorithms needed to produce the +correct document structure. Applications that are sensitive to the +document structure, such as extracting and rewriting large portions of +a web page, may benefit from Zenacy HTML. + +The library provides a wide variety of features including: + +* A fully standard compliant HTML parser +* HTML Fragment parsing +* Document rendering +* A zipper type for document traversal +* An iterator type for document walking +* Various functions for processing aspects of HTML +* Lightweight queries for rewriting + +## Parsing + +The library is designed to be imported unqualified. + +```haskell +import Zenacy.HTML +``` + +The `htmlParseEasy` function can be used to parse an HTML document string +and return the document model. + +```haskell +htmlParseEasy "
HelloWorld
" +``` + +Note that some of the missing elements where automatically added to +the document structure as required by the standard. + +```haskell +HTMLDocument "" + [ HTMLElement "html" HTMLNamespaceHTML [] + [ HTMLElement "head" HTMLNamespaceHTML [] [] + , HTMLElement "body" HTMLNamespaceHTML [] + [ HTMLElement "div" HTMLNamespaceHTML [] + [ HTMLText "HelloWorld" ] ] ] ] +``` + +The parsed result can also be rendered using `htmlRender`. + +```haskell +htmlRender $ htmlParseEasy "
HelloWorld
" +``` + +The resulting rendered document appears like so. + +```html +
HelloWorld
+``` + +## Rewriting + +This example illustrates a function that converts span elements to divs. + +```haskell +rewrite :: Text -> Text +rewrite = htmlRender . htmlMapElem f . fromJust . htmlDocHtml . htmlParseEasy + where + f x + | htmlElemHasName "span" x = htmlElemRename "div" x + | otherwise = x + +rewrite "HelloWorld" +``` + +Running the above gives the modified document. + +```html +
Hello
World
+``` + +## Extraction + +The next example shows one way to find all the hyperlinks in a document. +This solution recurses over the document elements while ignoring fragments +and templates. + +```haskell +extract :: Text -> [Text] +extract = go . htmlParseEasy + where + go = \case + HTMLDocument n c -> + concatMap go c + e @ (HTMLElement "a" s a c) -> + case htmlElemAttrFind (htmlAttrHasName "href") e of + Just (HTMLAttr n v s) -> + v : concatMap go c + Nothing -> + concatMap go c + HTMLElement n s a c -> + concatMap go c + _otherwise -> + [] + +extract "" +``` + +The extract function will give the following list. + +```haskell +[ "https://example1.com" +, "https://example2.com" +] +``` + +## Queries + +The library includes a basic query facility implemented as a thin wrapper +around an `HTMLZipper`. Queries match patterns in HTML structures and can +be used to extract information or update documents. As a first example, +consider the following HTML. + +```html +

+ +
+ AAA + +

+``` + +The HTML can be parsed as normal. Note though the additional step of +whitespace removal, which is often important in documents that include +indentation such as above. + +```haskell +fromJust . htmlSpaceRemove . fromJust . htmlDocBody . htmlParseEasy +``` + +Now a query function can be defined. This function expects to be given +a `body` element whose first child is a `p` element whose first child +has an id of `x` whose second sibling is an anchor element. If all of +those conditions are met, the the text contents of the anchor is returned. + +```haskell +query :: HTMLNode -> Maybe Text +query = htmlQueryExec $ do + htmlQueryName "body" + htmlQueryFirst + htmlQueryName "p" + htmlQueryFirst + htmlQueryId "x" + htmlQueryNext + htmlQueryNext + htmlQueryName "a" + a <- htmlQueryNode + htmlQuerySucc $ + fromMaybe "" $ htmlElemText a +``` + +Running the query on the parsed document will give the result. + +```haskell +Just "AAA" +``` + +Queries can also be used to modifiy documents. In the next example, let's +say we would like to find any `img` that is the only content in a `div` and +replace the `div` with a link. The document could look as follows. + +```html +
+
+
+``` + +A query function can be defined to match the desired pattern and return the +modified element. + +```haskell +query2 :: HTMLNode -> HTMLNode +query2 = htmlQueryTry $ do + htmlQueryName "div" + htmlQueryOnly "img" + a <- htmlQueryNode + let Just b = htmlElemGetAttr "src" a + htmlQuerySucc $ + htmlElem "a" [ htmlAttr "href" b ] + [ htmlText b ] +``` + +The query can then be applied to the entire document using `htmlMapElem`. + +```haskell +htmlMapElem query2 +``` + +Rendering the mapped query with give the updated content. + +```html +
aaa
+
bbb
+
ccc
+``` + +## Samples + +The unit tests include the above samples as well as many other example +usages of the library. + +## Origin + +Zenacy HTML was originally developed for Zenacy Reader Technologies LLC +starting around 2015 and used in a web reading SaaS for a few years. +The need to understand and handle the wide variety and sublties of HTML +found on the web lead to the development of library that closely followed +the standard. The library was tweaked and optimized a bit and though +there is room for more improvements the result worked quite well in +production (a lot of credit goes to the GHC team and Haskell community +for providing such great, fast functional programming tools). diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Zenacy.HTML +import Control.Monad +import Data.Default + ( Default(..) + ) +import qualified Data.Text as T + ( unpack + ) +import qualified Data.Text.IO as T + ( readFile + ) +import System.Environment + ( getArgs + ) + +-- | Application main. +main :: IO () +main = getArgs >>= \case + (x:[]) -> + validate x + _otherwise -> + pure () + +validate :: FilePath -> IO () +validate x = do + a <- T.readFile x + let p = htmlParse def { htmlOptionLogErrors = True } + case p a of + Left (HTMLError {..}) -> do + putStrLn $ T.unpack htmlErrorText + Right (HTMLResult {..}) -> do + if | null htmlResultErrors -> + putStrLn "no warnings" + | otherwise -> do + forM_ htmlResultErrors + ( putStrLn + . T.unpack + . htmlErrorText + ) diff --git a/bench/BenchMain.hs b/bench/BenchMain.hs new file mode 100644 --- /dev/null +++ b/bench/BenchMain.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Main where + +import Zenacy.HTML.Internal.BS +import Zenacy.HTML.Internal.Char +import Zenacy.HTML.Internal.Lexer +import Zenacy.HTML.Internal.Token +import Criterion.Main +import Control.Monad +import Control.Monad.ST +import Data.ByteString + ( ByteString + ) +import qualified Data.ByteString as S +import Data.Default + ( Default(..) + ) +import Text.RawString.QQ + +main :: IO () +main = do + putStrLn $ "data size: " ++ show (S.length (htmlBuild 1000) `div` 1024) ++ "KB" + defaultMain + [ env setupEnv $ \ ~x -> bgroup "a" + [ bench "1" $ whnf countTokens x + ] + ] + +setupEnv = do + pure $ htmlBuild 1000 + +countTokens :: ByteString -> Int +countTokens s = + runST $ do + Right x <- lexerNew def { lexerOptionInput = s } + go x 0 + where + go x a = do + lexerNext x + n <- tokenCount (lexerToken x) + if n == 0 + then pure a + else do + eof <- tokenHasEOF (lexerToken x) + if eof + then pure $ a + n + else go x $ a + n + +htmlData = [r|sjdkhfljksdhfjshdlkjfhsdjkhfljskdhlfjshldjkfhsd|] + +htmlBuild x = S.concat $ take x $ repeat htmlData diff --git a/src/Zenacy/HTML.hs b/src/Zenacy/HTML.hs new file mode 100644 --- /dev/null +++ b/src/Zenacy/HTML.hs @@ -0,0 +1,238 @@ +-- | Zenacy HTML is an HTML parsing and processing library that implements the +-- WHATWG HTML parsing standard. The standard is described as a state machine +-- that this library implements exactly as spelled out including all the error +-- handling, recovery, and conformance checks that makes it robust in handling +-- any HTML pulled from the web. In addition to parsing, the library provides +-- many processing features to help extract information from web pages or +-- rewrite them and render the modified results. +module Zenacy.HTML + ( + -- * Introduction + -- $intro + + -- * Parsing + -- $parse + + -- * Rewriting + -- $rewrite + + -- * Extraction + -- $extract + + -- * Queries + -- $query + + -- * Samples + -- $samples + + -- * Origin + -- $history + + module X + ) where + +import Zenacy.HTML.Internal.HTML as X +import Zenacy.HTML.Internal.Filter as X +import Zenacy.HTML.Internal.Image as X +import Zenacy.HTML.Internal.Oper as X +import Zenacy.HTML.Internal.Query as X +import Zenacy.HTML.Internal.Render as X +import Zenacy.HTML.Internal.Zip as X + +-- $intro +-- +-- The Zenacy HTML parser is an implementation of the HTML parsing standard +-- defined by the WHATWG. +-- +-- https://html.spec.whatwg.org/multipage/parsing.html +-- +-- The standard defines a parsing state machine, so it is very prescriptive +-- on how HTML is handled including many edge cases and error recovery. +-- This library aims to follow the standard closely in such a way to match the +-- code back to the standard and make future updates straightforward. +-- +-- One of the main uses an a HTML parser is for extracting information from +-- the web. Having a parser that can handle all the nuances of poorly +-- formatted HTML helps to make this extraction as robust as possible. +-- This was a key motivation in deciding to implement a parser in this fashion. +-- Additionally, the standard describes the algorithms needed to produce the +-- correct document structure. Applications that are sensitive to the +-- document structure, such as extracting and rewriting large portions of +-- a web page, may benefit from Zenacy HTML. +-- +-- The library provides a wide variety of features including: +-- +-- * A fully standard compliant HTML parser +-- * HTML Fragment parsing +-- * Document rendering +-- * A zipper type for document traversal +-- * An iterator type for document walking +-- * Various functions for processing aspects of HTML +-- * Lightweight queries for rewriting +-- +-- $parse +-- +-- The library is designed to be imported unqualified. +-- +-- > import Zenacy.HTML +-- +-- The `htmlParseEasy` function can be used to parse an HTML document string +-- and return the document model. +-- +-- > htmlParseEasy "
HelloWorld
" +-- +-- Note that some of the missing elements where automatically added to +-- the document structure as required by the standard. +-- +-- > HTMLDocument "" +-- > [ HTMLElement "html" HTMLNamespaceHTML [] +-- > [ HTMLElement "head" HTMLNamespaceHTML [] [] +-- > , HTMLElement "body" HTMLNamespaceHTML [] +-- > [ HTMLElement "div" HTMLNamespaceHTML [] +-- > [ HTMLText "HelloWorld" ] ] ] ] +-- +-- The parsed result can also be rendered using `htmlRender`. +-- +-- > htmlRender $ htmlParseEasy "
HelloWorld
" +-- +-- The resulting rendered document appears like so. +-- +-- >
HelloWorld
+-- +-- $rewrite +-- +-- This example illustrates a function that converts span elements to divs. +-- +-- > rewrite :: Text -> Text +-- > rewrite = htmlRender . htmlMapElem f . fromJust . htmlDocHtml . htmlParseEasy +-- > where +-- > f x +-- > | htmlElemHasName "span" x = htmlElemRename "div" x +-- > | otherwise = x +-- > +-- > rewrite "HelloWorld" +-- +-- Running the above gives the modified document. +-- +-- >
Hello
World
+-- +-- $extract +-- +-- The next example shows one way to find all the hyperlinks in a document. +-- This solution recurses over the document elements while ignoring fragments +-- and templates. +-- +-- > extract :: Text -> [Text] +-- > extract = go . htmlParseEasy +-- > where +-- > go = \case +-- > HTMLDocument n c -> +-- > concatMap go c +-- > e @ (HTMLElement "a" s a c) -> +-- > case htmlElemAttrFind (htmlAttrHasName "href") e of +-- > Just (HTMLAttr n v s) -> +-- > v : concatMap go c +-- > Nothing -> +-- > concatMap go c +-- > HTMLElement n s a c -> +-- > concatMap go c +-- > _otherwise -> +-- > [] +-- > +-- > extract "" +-- +-- The extract function will give the following list. +-- +-- > [ "https://example1.com" +-- > , "https://example2.com" +-- > ] +-- +-- $query +-- +-- The library includes a basic query facility implemented as a thin wrapper +-- around an `HTMLZipper`. Queries match patterns in HTML structures and can +-- be used to extract information or update documents. As a first example, +-- consider the following HTML. +-- +-- >

+-- > +-- >
+-- > AAA +-- > +-- >

+-- +-- The HTML can be parsed as normal. Note though the additional step of +-- whitespace removal, which is often important in documents that include +-- indentation such as above. +-- +-- > fromJust . htmlSpaceRemove . fromJust . htmlDocBody . htmlParseEasy +-- +-- Now a query function can be defined. This function expects to be given +-- a @body@ element whose first child is a @p@ element whose first child +-- has an id of @x@ whose second sibling is an anchor element. If all of +-- those conditions are met, the the text contents of the anchor is returned. +-- +-- > query :: HTMLNode -> Maybe Text +-- > query = htmlQueryExec $ do +-- > htmlQueryName "body" +-- > htmlQueryFirst +-- > htmlQueryName "p" +-- > htmlQueryFirst +-- > htmlQueryId "x" +-- > htmlQueryNext +-- > htmlQueryNext +-- > htmlQueryName "a" +-- > a <- htmlQueryNode +-- > htmlQuerySucc $ +-- > fromMaybe "" $ htmlElemText a +-- +-- Running the query on the parsed document will give the result. +-- +-- > Just "AAA" +-- +-- Queries can also be used to modifiy documents. In the next example, let's +-- say we would like to find any @img@ that is the only content in a @div@ and +-- replace the @div@ with a link. The document could look as follows. +-- +-- >
+-- >
+-- >
+-- +-- A query function can be defined to match the desired pattern and return the +-- modified element. +-- +-- > query2 :: HTMLNode -> HTMLNode +-- > query2 = htmlQueryTry $ do +-- > htmlQueryName "div" +-- > htmlQueryOnly "img" +-- > a <- htmlQueryNode +-- > let Just b = htmlElemGetAttr "src" a +-- > htmlQuerySucc $ +-- > htmlElem "a" [ htmlAttr "href" b ] +-- > [ htmlText b ] +-- +-- The query can then be applied to the entire document using `htmlMapElem`. +-- +-- > htmlMapElem query2 +-- +-- Rendering the mapped query with give the updated content. +-- +-- >
aaa
+-- >
bbb
+-- >
ccc
+-- +-- $samples +-- +-- The unit tests include the above samples as well as many other example +-- usages of the library. +-- +-- $history +-- +-- Zenacy HTML was originally developed for Zenacy Reader Technologies LLC +-- starting around 2015 and used in a web reading SaaS for a few years. +-- The need to understand and handle the wide variety and sublties of HTML +-- found on the web lead to the development of library that closely followed +-- the standard. The library was tweaked and optimized a bit and though +-- there is room for more improvements the result worked quite well in +-- production (a lot of credit goes to the GHC team and Haskell community +-- for providing such great, fast functional programming tools). diff --git a/src/Zenacy/HTML/Internal/BS.hs b/src/Zenacy/HTML/Internal/BS.hs new file mode 100644 --- /dev/null +++ b/src/Zenacy/HTML/Internal/BS.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Convenience wrappers and utilities for byte strings. +module Zenacy.HTML.Internal.BS + ( BS + -- * Word functions. + , bsEmpty + , bsOnly + , bsLen + , bsPack + , bsUnpack + , bsConcat + , bsIndex + , bsElemIndex + , bsLower + , bsPrefixCI + , bsPart + , bsLast + , bsTake + , bsDrop + , bsUncons + -- * Character functions. + , bcPack + , bcUnpack + ) where + +import Zenacy.HTML.Internal.Char +import Data.ByteString + ( ByteString + ) +import qualified Data.ByteString as S + ( concat + , drop + , elemIndex + , empty + , isPrefixOf + , index + , last + , length + , map + , pack + , singleton + , take + , uncons + , unpack + ) +import qualified Data.ByteString.Char8 as C + ( pack + , unpack + ) +import Data.Word + ( Word8 + ) + +-- | A type abbreviation for a byte string. +type BS = ByteString + +-- | An empty byte string. +bsEmpty :: BS +bsEmpty = S.empty +{-# INLINE bsEmpty #-} + +-- | A byte string with only one character. +bsOnly :: Word8 -> BS +bsOnly = S.singleton +{-# INLINE bsOnly #-} + +-- | Gets the length of a byte string. +bsLen :: BS -> Int +bsLen = S.length +{-# INLINE bsLen #-} + +-- | Converts a list of characters to a byte string. +bsPack :: [Word8] -> BS +bsPack = S.pack +{-# INLINE bsPack #-} + +-- | Converts a byte string to a list of characters. +bsUnpack :: BS -> [Word8] +bsUnpack = S.unpack +{-# INLINE bsUnpack #-} + +-- | Concatenates byte strings into one. +bsConcat :: [BS] -> BS +bsConcat = S.concat +{-# INLINE bsConcat #-} + +-- | Gets the character at an index in a byte string. +bsIndex :: BS -> Int -> Word8 +bsIndex = S.index +{-# INLINE bsIndex #-} + +-- | Gets the index of a character in a byte string. +bsElemIndex :: Word8 -> BS -> Maybe Int +bsElemIndex = S.elemIndex +{-# INLINE bsElemIndex #-} + +-- | Converts a bytestring to lowercase. +bsLower :: BS -> BS +bsLower = S.map chrToLower + +-- | Determines if a bytestring is a case-insensitive prefix of another. +bsPrefixCI :: BS -> BS -> Bool +bsPrefixCI x y = bsLower x `S.isPrefixOf` bsLower y + +-- | Selects a substring for a byte string. +bsPart :: Int -> Int -> BS -> BS +bsPart offset len = S.take len . S.drop offset + +-- | Returns the last word of a bytestring. +bsLast :: BS -> Maybe Word8 +bsLast x + | bsLen x > 0 = Just $ S.last x + | otherwise = Nothing + +-- | Takes characters from a byte string. +bsTake :: Int -> BS -> BS +bsTake = S.take +{-# INLINE bsTake #-} + +-- | Drops characters from a byte string. +bsDrop :: Int -> BS -> BS +bsDrop = S.drop +{-# INLINE bsDrop #-} + +-- | Removes a character from the end of a byte string. +bsUncons :: BS -> Maybe (Word8, BS) +bsUncons = S.uncons +{-# INLINE bsUncons #-} + +-- | Converts a string to a byte string. +bcPack :: String -> BS +bcPack = C.pack +{-# INLINE bcPack #-} + +-- | Converts a bytestring to a string. +bcUnpack :: BS -> String +bcUnpack = C.unpack +{-# INLINE bcUnpack #-} diff --git a/src/Zenacy/HTML/Internal/Buffer.hs b/src/Zenacy/HTML/Internal/Buffer.hs new file mode 100644 --- /dev/null +++ b/src/Zenacy/HTML/Internal/Buffer.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Defines an buffer type. +module Zenacy.HTML.Internal.Buffer + ( Buffer(..) + , bufferNew + , bufferCapacity + , bufferSize + , bufferReset + , bufferAppend + , bufferApply + , bufferTake + , bufferContains + , bufferPack + , bufferString + ) where + +import Zenacy.HTML.Internal.BS +-- import Foreign +-- ( castPtr +-- , withForeignPtr +-- ) +import Control.Monad.ST + ( ST + ) +import Data.STRef + ( STRef + , newSTRef + , readSTRef + , writeSTRef + ) +import qualified Data.DList as D + ( empty + , snoc + , toList + ) +-- import Data.Vector.Storable.Mutable +import qualified Data.Vector.Unboxed as U + ( freeze + , slice + , toList + ) +import Data.Vector.Unboxed.Mutable + ( MVector + ) +import qualified Data.Vector.Unboxed.Mutable as U +-- import qualified Data.Vector.Storable.Mutable as U + ( new + , length + , read + , write + , grow + -- , unsafeToForeignPtr0 + ) +import Data.Word + ( Word8 + ) +-- import System.IO.Unsafe +-- ( unsafePerformIO +-- ) + +-- | A type of buffer used to hold bytes. +data Buffer s = Buffer + { bfCntl :: MVector s Int + , bfData :: MVector s Word8 + } + +-- | Makes a new buffer. +bufferNew :: ST s (STRef s (Buffer s)) +bufferNew = do + c <- U.new 1 + d <- U.new 100 + r <- newSTRef (Buffer c d) + bufferReset r + pure r + +-- | Gets the capacity of the buffer. +bufferCapacity :: STRef s (Buffer s) -> ST s (Int, Int) +bufferCapacity r = do + Buffer{..} <- readSTRef r + pure (U.length bfCntl, U.length bfData) + +-- | Gets the size of the buffer. +bufferSize :: STRef s (Buffer s) -> ST s Int +bufferSize r = do + Buffer{..} <- readSTRef r + U.read bfCntl 0 + +-- | Resets a buffer. +bufferReset :: STRef s (Buffer s) -> ST s () +bufferReset r = do + Buffer{..} <- readSTRef r + U.write bfCntl 0 0 + +-- | Appends a word to a buffer. +bufferAppend :: Word8 -> STRef s (Buffer s) -> ST s () +bufferAppend word r = do + Buffer{..} <- readSTRef r + i <- U.read bfCntl 0 + d <- if i + 1 < U.length bfData + then pure bfData + else do + v <- U.grow bfData $ U.length bfData + writeSTRef r $ Buffer bfCntl v + pure v + U.write d i word + U.write bfCntl 0 (i + 1) + +-- | Applies an action to each word in the buffer. +bufferApply :: (Word8 -> ST s ()) -> STRef s (Buffer s) -> ST s () +bufferApply f r = do + Buffer{..} <- readSTRef r + n <- U.read bfCntl 0 + let go i + | i < n = + U.read bfData i >>= f >> go (i + 1) + | otherwise = + pure () + go 0 + +-- | Takes elements from the front of the buffer. +bufferTake :: Int -> STRef s (Buffer s) -> ST s [Word8] +bufferTake x r = do + Buffer{..} <- readSTRef r + n <- min x <$> U.read bfCntl 0 + let go i y + | i < n = do + a <- U.read bfData i + go (i + 1) $ D.snoc y a + | otherwise = + pure $ D.toList y + go 0 D.empty + +-- | Determines if a buffer has the specified contents. +bufferContains :: [Word8] -> STRef s (Buffer s) -> ST s Bool +bufferContains x r = do + n <- bufferSize r + if n /= length x + then pure False + else do + a <- bufferTake n r + pure $ x == a + +-- | Packs a buffer into a byte string. +bufferPack :: STRef s (Buffer s) -> ST s BS +bufferPack r = do + Buffer{..} <- readSTRef r + n <- U.read bfCntl 0 + bufferString bfData n + +-- | Converts a storable vector to a byte string. +bufferString :: MVector s Word8 -> Int -> ST s BS +bufferString v n = + U.freeze v >>= pure . bsPack . U.toList . U.slice 0 n + -- pure $ unsafePerformIO $ do + -- let (f, _) = U.unsafeToForeignPtr0 v + -- withForeignPtr f $ \p -> + -- S.packCStringLen (castPtr p, n) diff --git a/src/Zenacy/HTML/Internal/Char.hs b/src/Zenacy/HTML/Internal/Char.hs new file mode 100644 --- /dev/null +++ b/src/Zenacy/HTML/Internal/Char.hs @@ -0,0 +1,240 @@ +-- | Functions for identifying and manipulating character codes. +module Zenacy.HTML.Internal.Char + ( ctow + , chrWord8 + , chrUTF8 + , chrSurrogate + , chrScalar + , chrNonCharacter + , chrASCIIDigit + , chrASCIIUpperHexDigit + , chrASCIILowerHexDigit + , chrASCIIHexDigit + , chrASCIIUpperAlpha + , chrASCIILowerAlpha + , chrASCIIAlpha + , chrASCIIAlphanumeric + , chrWhitespace + , chrC0Control + , chrControl + , chrToUpper + , chrToLower + , chrAmpersand + , chrEOF + , chrExclamation + , chrGreater + , chrLess + , chrQuestion + , chrSolidus + , chrTab + , chrLF + , chrFF + , chrCR + , chrSpace + , chrEqual + , chrQuote + , chrApostrophe + , chrGrave + , chrNumberSign + , chrHyphen + , chrBracketRight + , chrSemicolon + , chrUpperX + , chrLowerX + ) where + +import qualified Data.ByteString as S + ( unpack + ) +import Data.Char + ( chr + , ord + ) +import qualified Data.Text as Text + ( singleton + ) +import qualified Data.Text.Encoding as Text + ( encodeUtf8 + ) +import Data.Word8 + +-- | Converts a character to a Word8. +ctow :: Char -> Word8 +ctow x = fromIntegral (ord x) + +-- | Determines if a character code is in the range of a Word8. +chrWord8 :: Int -> Bool +chrWord8 x = x >= 0 && x <= 0xFF + +-- | Decodes a UTF8 unicode character. +chrUTF8 :: Int -> [Word8] +chrUTF8 = S.unpack . Text.encodeUtf8 . Text.singleton . chr + +-- | Determines if a character code is a surrogate. +chrSurrogate :: Int -> Bool +chrSurrogate x = x >= 0xD800 && x <= 0xDFFF + +-- | Determines if a character code is a scalar. +chrScalar :: Int -> Bool +chrScalar = not . chrSurrogate + +-- | Determines if a code is a not a character code. +chrNonCharacter :: Int -> Bool +chrNonCharacter x = + (x >= 0xFDD0 && x <= 0xFDEF) || + any (==x) + [ 0xFFFE, 0xFFFF, 0x1FFFE, 0x1FFFF + , 0x2FFFE, 0x2FFFF, 0x3FFFE, 0x3FFFF + , 0x4FFFE, 0x4FFFF, 0x5FFFE, 0x5FFFF + , 0x6FFFE, 0x6FFFF, 0x7FFFE, 0x7FFFF + , 0x8FFFE, 0x8FFFF, 0x9FFFE, 0x9FFFF + , 0xAFFFE, 0xAFFFF, 0xBFFFE, 0xBFFFF + , 0xCFFFE, 0xCFFFF, 0xDFFFE, 0xDFFFF + , 0xEFFFE, 0xEFFFF, 0xFFFFE, 0xFFFFF + , 0x10FFFE, 0x10FFFF + ] + +-- | Determines if a character is an ASCII digit. +chrASCIIDigit :: Word8 -> Bool +chrASCIIDigit x = x >= 0x30 && x <= 0x39 + +-- | Determines if a character is an ASCII uppercase hex digit. +chrASCIIUpperHexDigit :: Word8 -> Bool +chrASCIIUpperHexDigit x = chrASCIIDigit x || (x >= 0x41 && x <= 0x46) + +-- | Determines if a character is an ASCII lowercase hex digit. +chrASCIILowerHexDigit :: Word8 -> Bool +chrASCIILowerHexDigit x = chrASCIIDigit x || (x >= 0x61 && x <= 0x66) + +-- | Determines if a character is an ASCII hex digit (any case). +chrASCIIHexDigit :: Word8 -> Bool +chrASCIIHexDigit x = chrASCIIUpperHexDigit x || chrASCIILowerHexDigit x + +-- | Determines if a character is an ASCII uppercase alpha character. +chrASCIIUpperAlpha :: Word8 -> Bool +chrASCIIUpperAlpha x = x >= 0x41 && x <= 0x5A + +-- | Determines if a character is an ASCII lowercase alpha character. +chrASCIILowerAlpha :: Word8 -> Bool +chrASCIILowerAlpha x = x >= 0x61 && x <= 0x7A + +-- | Determines if a character is an ASCII alpha character (any case). +chrASCIIAlpha :: Word8 -> Bool +chrASCIIAlpha x = chrASCIIUpperAlpha x || chrASCIILowerAlpha x + +-- | Determines if a character is an ASCII alphanumeric character (any case). +chrASCIIAlphanumeric :: Word8 -> Bool +chrASCIIAlphanumeric x = chrASCIIDigit x || chrASCIIAlpha x + +-- | Determines if a character is a whitespace character. +chrWhitespace :: Word8 -> Bool +chrWhitespace x = + x == chrTab || + x == chrLF || + x == chrFF || + x == chrCR || + x == chrSpace + +-- | Determines if a character is a C0 control character. +chrC0Control :: Word8 -> Bool +chrC0Control x = x >= 0x00 && x <= 0x1F + +-- | Determines if a character is a control character. +chrControl :: Word8 -> Bool +chrControl x = chrC0Control x || (x >= 0x7F && x <= 0x9F) + +-- | Converts a character to uppercase. +chrToUpper :: Word8 -> Word8 +chrToUpper = toUpper + +-- | Converts a character to lowercase. +chrToLower :: Word8 -> Word8 +chrToLower = toLower + +-- | Character code for ampersand. +chrAmpersand :: Word8 +chrAmpersand = _ampersand + +-- | Character code for EOF. +chrEOF :: Word8 +chrEOF = _nul + +-- | Character code for exclamation. +chrExclamation :: Word8 +chrExclamation = _exclam + +-- | Character code for greater. +chrGreater :: Word8 +chrGreater = _greater + +-- | Character code for less. +chrLess :: Word8 +chrLess = _less + +-- | Character code for question. +chrQuestion :: Word8 +chrQuestion = _question + +-- | Character code for solidus (slash). +chrSolidus :: Word8 +chrSolidus = _slash + +-- | Character code for tab. +chrTab :: Word8 +chrTab = _tab + +-- | Character code for line feed. +chrLF :: Word8 +chrLF = _lf + +-- | Character code for form feed. +chrFF :: Word8 +chrFF = _np + +-- | Character code for carraige return. +chrCR :: Word8 +chrCR = _cr + +-- | Character code for space. +chrSpace :: Word8 +chrSpace = _space + +-- | Character code for equal. +chrEqual :: Word8 +chrEqual = _equal + +-- | Character code for quote. +chrQuote :: Word8 +chrQuote = _quotedbl + +-- | Character code for apostrophe. +chrApostrophe :: Word8 +chrApostrophe = _quotesingle + +-- | Character code for grave. +chrGrave :: Word8 +chrGrave = _grave + +-- | Character code for number sign. +chrNumberSign :: Word8 +chrNumberSign = _numbersign + +-- | Character code for hyphen. +chrHyphen :: Word8 +chrHyphen = _hyphen + +-- | Character code for right bracket. +chrBracketRight :: Word8 +chrBracketRight = _bracketright + +-- | Character code for semicolon. +chrSemicolon :: Word8 +chrSemicolon = _semicolon + +-- | Character code for upper x. +chrUpperX :: Word8 +chrUpperX = 0x58 + +-- | Character code for lower x. +chrLowerX :: Word8 +chrLowerX = 0x78 diff --git a/src/Zenacy/HTML/Internal/Core.hs b/src/Zenacy/HTML/Internal/Core.hs new file mode 100644 --- /dev/null +++ b/src/Zenacy/HTML/Internal/Core.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Defines core functions that augment the prelude. +module Zenacy.HTML.Internal.Core + ( updateSTRef + , rref + , wref + , uref + , findSucc + , insertBefore + , removeFirst + , textExtract + , textBlank + , textReadDec + ) where + +import Data.Text + ( Text + ) +import qualified Data.Text as T + ( breakOn + , drop + , length + , null + , replicate + , singleton + , unpack + ) +import Control.Monad.ST + ( ST + ) +import Data.STRef + ( STRef + , readSTRef + , writeSTRef + ) +import qualified Numeric as N + ( readDec + ) + +-- | Updates an STRef by applying a function to its value. +updateSTRef :: STRef s a -> (a -> a) -> ST s () +updateSTRef r f = readSTRef r >>= writeSTRef r . f +{-# INLINE updateSTRef #-} + +-- | Abbreviation for reading an STRef. +rref :: STRef s a -> ST s a +rref = readSTRef +{-# INLINE rref #-} + +-- | Abbreviation for writing an STRef. +wref :: STRef s a -> a -> ST s () +wref = writeSTRef +{-# INLINE wref #-} + +-- | Abbreviation for updating an STRef. +uref :: STRef s a -> (a -> a) -> ST s () +uref = updateSTRef +{-# INLINE uref #-} + +-- | Finds the element in a list that is the succeessor of the element +-- matching a predicate. +findSucc :: (a -> Bool) -> [a] -> Maybe a +findSucc p [] = Nothing +findSucc p (y:x:xs) = if p y then Just x else findSucc p (x:xs) +findSucc p (x:xs) = findSucc p xs + +-- | Inserts an element in a list before the element satisfied by a predicate. +insertBefore :: (a -> Bool) -> a -> [a] -> [a] +insertBefore f _ [] = [] +insertBefore f x (y:ys) = if f y then x : y : ys else y : insertBefore f x ys + +-- | Removes the first item from a list that satisfies a predicate. +removeFirst :: (a -> Bool) -> [a] -> [a] +removeFirst p [] = [] +removeFirst p (x:xs) = if p x then xs else x : removeFirst p xs + +-- | Extracts a range of text bewteen two delimiters. +textExtract :: Text -> Text -> Text -> Maybe Text +textExtract d0 d1 t + | T.null b = Nothing + | T.null y = Nothing + | T.null x = Nothing + | otherwise = Just x + where + (a,b) = T.breakOn d0 t + (x,y) = T.breakOn d1 $ T.drop (T.length d0) b + +-- | Returns a blank text of the specified length. +textBlank :: Int -> Text +textBlank x = T.replicate x (T.singleton ' ') + +-- | Converts a decimal string to a integer. +textReadDec :: Text -> Maybe Int +textReadDec x = + case N.readDec (T.unpack x) of + [(a,_)] -> Just a + _otherwise -> Nothing diff --git a/src/Zenacy/HTML/Internal/DOM.hs b/src/Zenacy/HTML/Internal/DOM.hs new file mode 100644 --- /dev/null +++ b/src/Zenacy/HTML/Internal/DOM.hs @@ -0,0 +1,721 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Defines the HTML DOM types and functions. +module Zenacy.HTML.Internal.DOM + ( DOM(..) + , DOMNode(..) + , DOMAttr(..) + , DOMType(..) + , DOMQuirks(..) + , DOMPos(..) + , DOMID + , DOMMap + , domAttrMake + , domDefaultDocument + , domDefaultDoctype + , domDefaultFragment + , domDefaultElement + , domDefaultTemplate + , domDefaultText + , domDefaultComment + , domDefaultType + , domMakeTypeHTML + , domMakeTypeMathML + , domMakeTypeSVG + , domPos + , domNull + , domRoot + , domRootPos + , domDocument + , domQuirksSet + , domQuirksGet + , domNewID + , domGetNode + , domPutNode + , domInsert + , domInsertNew + , domAppend + , domAppendNew + , domElementHasAttr + , domElementFindAttr + , domElementAttrValue + , domAttrMerge + , domMatch + , domLastChild + , domMapID + , domFindParent + , domSetParent + , domMapChild + , domRemoveChild + , domRemoveChildren + , domMove + , domMoveChildren + , domChildren + , domHasChild + , domNodeID + , domNodeParent + , domNodeIsHTML + , domNodeIsSVG + , domNodeIsMathML + , domNodeIsDocument + , domNodeIsFragment + , domNodeIsElement + , domNodeIsTemplate + , domNodeIsHtmlElement + , domNodeIsText + , domNodeElementName + , domNodeElementNamespace + , domNodeType + , domTypesHTML + , domTypesMathML + , domTypesSVG + , domRender + ) where + +import Zenacy.HTML.Internal.BS +import Zenacy.HTML.Internal.Core +import Zenacy.HTML.Internal.Types +import Data.Foldable + ( toList + ) +import Data.List + ( find + ) +import Data.Maybe + ( fromJust + , listToMaybe + , isJust + , mapMaybe + ) +import Data.Monoid + ( (<>) + ) +import Data.Word + ( Word8 + ) +import Data.Default + ( Default(..) + ) +import Data.IntMap + ( IntMap + ) +import qualified Data.IntMap as IntMap + ( singleton + , lookup + , insert + , keys + ) +import Data.Sequence + ( Seq(..) + , ViewL(..) + , ViewR(..) + , (<|) + , (|>) + , (><) + ) +import qualified Data.Sequence as Seq + ( breakl + , empty + , filter + , viewl + , viewr + ) + +-- | DOM represents an HTML document while being parsed. +data DOM = DOM + { domNodes :: !DOMMap + , domNextID :: !DOMID + } deriving (Eq, Ord, Show) + +-- | Defines an ID for a node in a document. +type DOMID = Int + +-- | Defines a mapping between node references and nodes. +type DOMMap = IntMap DOMNode + +-- | Node is the model type for an HTML document. +data DOMNode + = DOMDocument + { domDocumentID :: DOMID + , domDocumentParent :: DOMID + , domDocumentName :: BS + , domDocumentChildren :: Seq DOMID + , domDocumentQuirksMode :: DOMQuirks + } + | DOMDoctype + { domDoctypeID :: DOMID + , domDoctypeParent :: DOMID + , domDoctypeName :: BS + , domDoctypePublicID :: Maybe BS + , domDoctypeSystemID :: Maybe BS + } + | DOMFragment + { domFragmentID :: DOMID + , domFragmentParent :: DOMID + , domFragmentName :: BS + , domFragmentChildren :: Seq DOMID + } + | DOMElement + { domElementID :: DOMID + , domElementParent :: DOMID + , domElementName :: BS + , domElementNamespace :: HTMLNamespace + , domElementAttributes :: Seq DOMAttr + , domElementChildren :: Seq DOMID + } + | DOMTemplate + { domTemplateID :: DOMID + , domTemplateParent :: DOMID + , domTemplateNamespace :: HTMLNamespace + , domTemplateAttributes :: Seq DOMAttr + , domTemplateContents :: DOMID + } + | DOMText + { domTextID :: DOMID + , domTextParent :: DOMID + , domTextData :: BS + } + | DOMComment + { domCommentID :: DOMID + , domCommentParent :: DOMID + , domCommentData :: BS + } + deriving (Eq, Ord, Show) + +-- | An HTML element attribute type. +data DOMAttr = DOMAttr + { domAttrName :: BS + , domAttrVal :: BS + , domAttrNamespace :: HTMLAttrNamespace + } deriving (Eq, Ord, Show) + + +-- | Identifies the type of an element. +data DOMType = DOMType + { domTypeName :: BS + , domTypeNamespace :: HTMLNamespace + } deriving (Eq, Ord, Show) + +-- | Indentifies the quirks mode. +data DOMQuirks + = DOMQuirksNone + | DOMQuirksMode + | DOMQuirksLimited + deriving (Eq, Ord, Show) + +-- | Defines a position in the DOM. +data DOMPos = DOMPos + { domPosParent :: DOMID + , domPosChild :: Maybe DOMID + } deriving (Eq, Ord, Show) + +-- | Defines a default DOM. +instance Default DOM where + def = DOM + { domNodes = IntMap.singleton domRoot domDefaultDocument + , domNextID = domRoot + 1 + } + +-- | Defines a default attribute. +instance Default DOMAttr where + def = DOMAttr + { domAttrName = bsEmpty + , domAttrVal = bsEmpty + , domAttrNamespace = def + } + +-- | Makes an attribute. +domAttrMake :: BS -> BS -> DOMAttr +domAttrMake n v = DOMAttr n v def + +-- | Defines a default document. +domDefaultDocument :: DOMNode +domDefaultDocument = + DOMDocument + { domDocumentID = domNull + , domDocumentName = bsEmpty + , domDocumentChildren = Seq.empty + , domDocumentQuirksMode = DOMQuirksNone + , domDocumentParent = domNull + } + +-- | Defines a default document type. +domDefaultDoctype :: DOMNode +domDefaultDoctype = + DOMDoctype + { domDoctypeID = domNull + , domDoctypeName = bsEmpty + , domDoctypePublicID = Nothing + , domDoctypeSystemID = Nothing + , domDoctypeParent = domNull + } + +-- | Defines a default document fragment. +domDefaultFragment :: DOMNode +domDefaultFragment = + DOMFragment + { domFragmentID = domNull + , domFragmentName = bsEmpty + , domFragmentChildren = Seq.empty + , domFragmentParent = domNull + } + +-- | Defines a default element. +domDefaultElement :: DOMNode +domDefaultElement = + DOMElement + { domElementID = domNull + , domElementName = bsEmpty + , domElementNamespace = HTMLNamespaceHTML + , domElementAttributes = Seq.empty + , domElementChildren = Seq.empty + , domElementParent = domNull + } + +-- | Defines a default template. +domDefaultTemplate :: DOMNode +domDefaultTemplate = + DOMTemplate + { domTemplateID = domNull + , domTemplateNamespace = HTMLNamespaceHTML + , domTemplateAttributes = Seq.empty + , domTemplateContents = domNull + , domTemplateParent = domNull + } + +-- | Defines a default text. +domDefaultText :: DOMNode +domDefaultText = + DOMText + { domTextID = domNull + , domTextData = bsEmpty + , domTextParent = domNull + } + +-- | Defines a default comment. +domDefaultComment :: DOMNode +domDefaultComment = + DOMComment + { domCommentID = domNull + , domCommentData = bsEmpty + , domCommentParent = domNull + } + +-- | Defines a default type. +domDefaultType :: DOMType +domDefaultType = domMakeTypeHTML bsEmpty + +-- | Makes a new HTML element type. +domMakeTypeHTML :: BS -> DOMType +domMakeTypeHTML = flip DOMType HTMLNamespaceHTML + +-- | Makes a new MathML element type. +domMakeTypeMathML :: BS -> DOMType +domMakeTypeMathML = flip DOMType HTMLNamespaceMathML + +-- | Makes a new SVG element type. +domMakeTypeSVG :: BS -> DOMType +domMakeTypeSVG = flip DOMType HTMLNamespaceSVG + +-- | Makes a new position. +domPos :: DOMID -> DOMPos +domPos x = DOMPos x Nothing + +-- | The null node ID. +domNull :: DOMID +domNull = 0 + +-- | The root document node ID. +domRoot :: DOMID +domRoot = 1 + +-- | Defines an appending position in a document node. +domRootPos :: DOMPos +domRootPos = domPos domRoot + +-- | Gets the document node for a DOM. +domDocument :: DOM -> DOMNode +domDocument d = fromJust $ IntMap.lookup domRoot $ domNodes d + +-- | Sets the quirks mode for a document. +domQuirksSet :: DOMQuirks -> DOM -> DOM +domQuirksSet x d = domPutNode domRoot y' d + where + y = domDocument d + y' = y { domDocumentQuirksMode = x } + +-- | Gets the quirks mode for a document. +domQuirksGet :: DOM -> DOMQuirks +domQuirksGet = domDocumentQuirksMode . domDocument + +-- | Adds a new node to a DOM. +domNewID :: DOM -> DOMNode -> (DOM, DOMID) +domNewID d n = (d', i) + where + i = domNextID d + n' = domSetID n i + d' = d { domNodes = IntMap.insert i n' $ domNodes d + , domNextID = i + 1 + } + +-- | Sets the ID for a node. +domSetID :: DOMNode -> DOMID -> DOMNode +domSetID x y = + case x of + DOMDocument{} -> x { domDocumentID = y } + DOMDoctype{} -> x { domDoctypeID = y } + DOMFragment{} -> x { domFragmentID = y } + DOMElement{} -> x { domElementID = y } + DOMTemplate{} -> x { domTemplateID = y } + DOMText{} -> x { domTextID = y } + DOMComment{} -> x { domCommentID = y } + +-- | Gets a node for a node ID. +domGetNode :: DOM -> DOMID -> Maybe DOMNode +domGetNode d x = IntMap.lookup x $ domNodes d + +-- | Updates a node in the DOM. +domPutNode :: DOMID -> DOMNode -> DOM -> DOM +domPutNode x n d = d { domNodes = IntMap.insert x n $ domNodes d } + +-- | Inserts a node at a position. +domInsert :: DOMPos -> DOMID -> DOM -> DOM +domInsert p@(DOMPos r c) x d = + case domGetNode d r of + Just n@(DOMDocument { domDocumentChildren = a }) -> + f $ n { domDocumentChildren = g a } + Just n@(DOMElement { domElementChildren = a }) -> + f $ n { domElementChildren = g a } + Just n@(DOMFragment { domFragmentChildren = a }) -> + f $ n { domFragmentChildren = g a } + Just n@(DOMTemplate { domTemplateContents = a }) -> + domInsert (DOMPos a c) x d + _otherwise -> d + where + f a = domSetParent x r (domPutNode r a d) + g = domInsertChild p x + +-- | Inserts a node at a position. +domInsertNew :: DOMPos -> DOMNode -> DOM -> (DOM, DOMID) +domInsertNew p x d = + (domInsert p i d', i) + where + (d', i) = domNewID d x + +-- | Inserts a child in a list of children. +domInsertChild :: DOMPos -> DOMID -> Seq DOMID -> Seq DOMID +domInsertChild (DOMPos _ Nothing) x = (|> x) +domInsertChild (DOMPos _ (Just a)) x = seqInsertBefore (==a) x + +-- | Appends a node ID to a node. +domAppend :: DOMID -> DOMID -> DOM -> DOM +domAppend x y d = + case domGetNode d x of + Just (DOMDocument i p n c q) -> + f $ DOMDocument i p n (c |> y) q + Just (DOMElement i p n s a c) -> + f $ DOMElement i p n s a (c |> y) + Just (DOMFragment i p n c) -> + f $ DOMFragment i p n (c |> y) + Just (DOMTemplate _ _ _ _ c) -> + domAppend c y d + _otherwise -> d + where + f a = domSetParent y x (domPutNode x a d) + +-- | Appends a node to a node. +domAppendNew :: DOMID -> DOMNode -> DOM -> DOM +domAppendNew x y d = domAppend x i d' + where (d', i) = domNewID d y + +-- | Finds an attribute for an element. +domElementFindAttr :: DOMNode -> BS -> Maybe DOMAttr +domElementFindAttr node name = case node of + DOMElement{..} -> f domElementAttributes + DOMTemplate{..} -> f domTemplateAttributes + _otherwise -> Nothing + where + f = seqFind (\DOMAttr{..} -> domAttrName == name) + +-- | Gets the last element in a sequence if it exists. +seqLast :: Seq a -> Maybe a +seqLast (Seq.viewr -> EmptyR) = Nothing +seqLast (Seq.viewr -> _ :> a) = Just a +seqLast _ = Nothing + +-- | Finds an element in a sequence. +seqFind :: (a -> Bool) -> Seq a -> Maybe a +seqFind f x = go x + where + go (Seq.viewl -> EmptyL) = Nothing + go (Seq.viewl -> a :< b) = if f a then Just a else go b + go _ = Nothing + +-- | Inserts an element into a sequence before the element satisfying a predicate. +seqInsertBefore :: (a -> Bool) -> a -> Seq a -> Seq a +seqInsertBefore f x y = + (a |> x) <> b + where + (a, b) = Seq.breakl f y + +-- | Finds an attribute value for an element. +domElementAttrValue :: DOMNode -> BS -> Maybe BS +domElementAttrValue x n = domAttrVal <$> domElementFindAttr x n + +-- | Determines if a node has a named attribute. +domElementHasAttr :: DOMNode -> BS -> Bool +domElementHasAttr x = isJust . domElementFindAttr x + +-- | Merges attributes into an existing node. +domAttrMerge :: DOMID -> Seq DOMAttr -> DOM -> DOM +domAttrMerge x y d = + case domGetNode d x of + Just n@(DOMElement { domElementAttributes = a }) -> + domPutNode x (n { domElementAttributes = a <> f n y }) d + Just n@(DOMTemplate { domTemplateAttributes = a }) -> + domPutNode x (n { domTemplateAttributes = a <> f n y }) d + _otherwise -> d + where + f n = Seq.filter (not . domElementHasAttr n . domAttrName) + +-- | Detmermines if two elements match. +domMatch :: DOM -> DOMID -> DOMID -> Bool +domMatch d i j = + case (domGetNode d i, domGetNode d j) of + (Just (DOMElement _ _ n1 s1 a1 _), Just (DOMElement _ _ n2 s2 a2 _)) -> + n1 == n2 && s1 == s2 && a1 == a1 + (Just (DOMTemplate _ _ s1 a1 _ ), Just (DOMTemplate _ _ s2 a2 _)) -> + s1 == s2 && a1 == a1 + _otherwise -> + False + +-- | Returns the last child of a node if it exists. +domLastChild :: DOM -> DOMID -> Maybe DOMID +domLastChild d x = + domGetNode d x >>= \case + DOMDocument{..} -> seqLast domDocumentChildren + DOMFragment{..} -> seqLast domFragmentChildren + DOMElement{..} -> seqLast domElementChildren + DOMTemplate{..} -> domLastChild d domTemplateContents + _otherwise -> Nothing + +-- | Converts a list of node IDs to nodes. +domMapID :: DOM -> [DOMID] -> [DOMNode] +domMapID d = mapMaybe $ domGetNode d + +-- | Finds the parent node for a node. +domFindParent :: DOM -> DOMID -> Maybe DOMID +domFindParent d x = find (domHasChild d x) $ IntMap.keys $ domNodes d + +-- | Sets the parent for a node. +domSetParent :: DOMID -> DOMID -> DOM -> DOM +domSetParent x y d = + case domGetNode d x of + Just a -> case a of + DOMDocument{} -> f a { domDocumentParent = y } + DOMDoctype{} -> f a { domDoctypeParent = y } + DOMFragment{} -> f a { domFragmentParent = y } + DOMElement{} -> f a { domElementParent = y } + DOMTemplate{} -> f a { domTemplateParent = y } + DOMText{} -> f a { domTextParent = y } + DOMComment{} -> f a { domCommentParent = y } + Nothing -> d + where + f z = domPutNode x z d + +-- | Maps a function over children of a node. +domMapChild :: DOMID -> (Seq DOMID -> Seq DOMID)-> DOM -> DOM +domMapChild x f d = + case domGetNode d x of + Just a -> case a of + DOMDocument { domDocumentChildren = c } -> + domPutNode x a { domDocumentChildren = f c } d + DOMFragment { domFragmentChildren = c } -> + domPutNode x a { domFragmentChildren = f c } d + DOMElement { domElementChildren = c } -> + domPutNode x a { domElementChildren = f c } d + DOMTemplate { domTemplateContents = c } -> + domMapChild c f d + _otherwise -> d + Nothing -> d + +-- | Removes a child from a node. +domRemoveChild :: DOMID -> DOMID -> DOM -> DOM +domRemoveChild parent child = domMapChild parent $ Seq.filter (/=child) + +-- | Removes all the children from a node. +domRemoveChildren :: DOMID -> DOM -> DOM +domRemoveChildren x = domMapChild x $ const Seq.empty + +-- | Moves a node to another parent. +domMove :: DOMID -> DOMID -> DOM -> DOM +domMove x newParent d = + case domGetNode d x of + Just a -> + let d' = domRemoveChild (domNodeParent a) x d + in domAppend newParent x d' + Nothing -> d + +-- | Moves the children of a node to another node. +domMoveChildren :: DOMID -> DOMID -> DOM -> DOM +domMoveChildren x y d = + foldl (\d' c -> domAppend y c d') (domRemoveChildren x d) $ domChildren d x + +-- | Gets the children of a node. +domChildren :: DOM -> DOMID -> Seq DOMID +domChildren d x = + case domGetNode d x of + Just (DOMDocument{..}) -> domDocumentChildren + Just (DOMFragment{..}) -> domFragmentChildren + Just (DOMElement{..}) -> domElementChildren + Just (DOMTemplate{..}) -> domChildren d domTemplateContents + _otherwise -> Seq.empty + +-- | Determines if a node has a specific child. +domHasChild :: DOM -> DOMID -> DOMID -> Bool +domHasChild d x z = z `elem` domChildren d x + +-- | Gets the id for a node. +domNodeID :: DOMNode -> DOMID +domNodeID = \case + DOMDocument{..} -> domDocumentID + DOMDoctype{..} -> domDoctypeID + DOMFragment{..} -> domFragmentID + DOMElement{..} -> domElementID + DOMTemplate{..} -> domTemplateID + DOMText{..} -> domTextID + DOMComment{..} -> domCommentID + +-- | Gets the parent for a node. +domNodeParent :: DOMNode -> DOMID +domNodeParent = \case + DOMDocument{..} -> domDocumentParent + DOMDoctype{..} -> domDoctypeParent + DOMFragment{..} -> domFragmentParent + DOMElement{..} -> domElementParent + DOMTemplate{..} -> domTemplateParent + DOMText{..} -> domTextParent + DOMComment{..} -> domCommentParent + +-- | Detmermines if a node is in the HTML namespace. +domNodeIsHTML :: DOMNode -> Bool +domNodeIsHTML = \case + DOMElement{..} -> domElementNamespace == HTMLNamespaceHTML + DOMTemplate{..} -> domTemplateNamespace == HTMLNamespaceHTML + _otherwise -> False + +-- | Detmermines if a node is in the SVG namespace. +domNodeIsSVG :: DOMNode -> Bool +domNodeIsSVG = \case + DOMElement{..} -> domElementNamespace == HTMLNamespaceSVG + DOMTemplate{..} -> domTemplateNamespace == HTMLNamespaceSVG + _otherwise -> False + +-- | Detmermines if a node is in the MathML namespace. +domNodeIsMathML :: DOMNode -> Bool +domNodeIsMathML = \case + DOMElement{..} -> domElementNamespace == HTMLNamespaceMathML + DOMTemplate{..} -> domTemplateNamespace == HTMLNamespaceMathML + _otherwise -> False + +-- | Detmermines if a node is a document node. +domNodeIsDocument :: DOMNode -> Bool +domNodeIsDocument DOMDocument{} = True +domNodeIsDocument _ = False + +-- | Detmermines if a node is a document fragment node. +domNodeIsFragment :: DOMNode -> Bool +domNodeIsFragment DOMFragment{} = True +domNodeIsFragment _ = False + +-- | Detmermines if a node is an element node. +domNodeIsElement :: DOMNode -> Bool +domNodeIsElement DOMElement{} = True +domNodeIsElement _ = False + +-- | Detmermines if a node is a template node. +domNodeIsTemplate :: DOMNode -> Bool +domNodeIsTemplate DOMTemplate{} = True +domNodeIsTemplate _ = False + +-- | Detmermines if a node is an HTML element node. +domNodeIsHtmlElement :: DOMNode -> Bool +domNodeIsHtmlElement x = domNodeIsElement x && domNodeIsHTML x + +-- | Detmermines if a node is a text node. +domNodeIsText :: DOMNode -> Bool +domNodeIsText DOMText{} = True +domNodeIsText _ = False + +-- | Gets the name for an element node. +domNodeElementName :: DOMNode -> BS +domNodeElementName DOMElement{..} = domElementName +domNodeElementName DOMTemplate{} = "template" +domNodeElementName _ = "" + +-- | Gets the name for an element node. +domNodeElementNamespace :: DOMNode -> HTMLNamespace +domNodeElementNamespace DOMElement{..} = domElementNamespace +domNodeElementNamespace DOMTemplate{..} = domTemplateNamespace +domNodeElementNamespace _ = HTMLNamespaceHTML + +-- | Gets the type for an element node. +domNodeType :: DOMNode -> DOMType +domNodeType x = DOMType (domNodeElementName x) (domNodeElementNamespace x) + +-- | Gets a list of HTML types for element names. +domTypesHTML :: [BS] -> [DOMType] +domTypesHTML = map domMakeTypeHTML + +-- | Gets a list of MathML types for element names. +domTypesMathML :: [BS] -> [DOMType] +domTypesMathML = map domMakeTypeMathML + +-- | Gets a list of SVG types for element names. +domTypesSVG :: [BS] -> [DOMType] +domTypesSVG = map domMakeTypeSVG + +-- | Renders the DOM. +domRender :: DOM -> BS +domRender d = domRenderIndent d 0 domRoot + +-- | Renders the DOM with indentaion. +domRenderIndent :: DOM -> Int -> DOMID -> BS +domRenderIndent d x y = + case fromJust (domGetNode d y) of + DOMDocument{..} -> + bsConcat $ map (domRenderIndent d x) $ toList domDocumentChildren + DOMDoctype{} -> + bsEmpty + DOMFragment{..} -> + bsConcat $ map (domRenderIndent d x) $ toList domFragmentChildren + DOMElement{..} -> + bsConcat + [ indent + , domElementName + , "\n" + , bsConcat $ map (domRenderIndent d $ x + 1) $ toList domElementChildren + ] + DOMTemplate{..} -> + bsConcat + [ indent + , "template" + , "\n" + , domRenderIndent d (x + 1) domTemplateContents + ] + DOMText{..} -> + bsConcat + [ indent + , domTextData + , "\n" + ] + DOMComment{} -> + bsEmpty + where + indent = bsPack $ take x $ repeat 0x20 diff --git a/src/Zenacy/HTML/Internal/Entity.hs b/src/Zenacy/HTML/Internal/Entity.hs new file mode 100644 --- /dev/null +++ b/src/Zenacy/HTML/Internal/Entity.hs @@ -0,0 +1,2302 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Matches and extracts entities from byte strings. +module Zenacy.HTML.Internal.Entity + ( entityMatch + , entityTrie + , entityData + ) where + +import Zenacy.HTML.Internal.BS +import Zenacy.HTML.Internal.Char +import Data.Char + ( chr + , ord + ) +import qualified Data.Text as Text + ( pack + ) +import qualified Data.Text.Encoding as Text + ( encodeUtf8 + ) +import Zenacy.HTML.Internal.Trie + ( Trie + ) +import qualified Zenacy.HTML.Internal.Trie as Trie + ( fromList + , match + ) +import Data.Word + ( Word8 + ) + +-- | Searches for an entity match. +-- Returns a tuple with the prefix, its value, and the remaining string. +entityMatch :: BS -> Maybe (BS, BS, BS) +entityMatch = Trie.match entityTrie + +-- | A trie of the entity data with surrogates converted. +entityTrie :: Trie BS +entityTrie = + Trie.fromList $ map (f . g) entityData + where + f (x, y) = (x, Text.encodeUtf8 $ Text.pack y) + g (x, y) = case y of + [a, b] -> + let a' = ord a + b' = ord b + in if isUTF16Surrogate a' b' + then (x, [convUTF16Surrogate a' b']) + else (x, [a,b]) + _otherwise -> + (x, y) + +-- | Converts a surrogate pair to a unicode character. +convUTF16Surrogate :: Int -> Int -> Char +convUTF16Surrogate high low = + chr $ (high - 0xD800) * 0x400 + (low - 0xDC00) + 0x10000 + +-- | Determines is a pair of codes represent a surrogate. +isUTF16Surrogate :: Int -> Int -> Bool +isUTF16Surrogate high low = + high >= 0xD800 && high <= 0xDBFF && low >= 0xDC00 && low <= 0xDFFF + +-- | The raw entity data. +entityData :: [(BS,String)] +entityData = + [("Aacute","\x00C1") + ,("aacute","\x00E1") + ,("Aacute;","\x00C1") + ,("aacute;","\x00E1") + ,("Abreve;","\x0102") + ,("abreve;","\x0103") + ,("ac;","\x223E") + ,("acd;","\x223F") + ,("acE;","\x223E\x0333") + ,("Acirc","\x00C2") + ,("acirc","\x00E2") + ,("Acirc;","\x00C2") + ,("acirc;","\x00E2") + ,("acute","\x00B4") + ,("acute;","\x00B4") + ,("Acy;","\x0410") + ,("acy;","\x0430") + ,("AElig","\x00C6") + ,("aelig","\x00E6") + ,("AElig;","\x00C6") + ,("aelig;","\x00E6") + ,("af;","\x2061") + ,("Afr;","\xD835\xDD04") + ,("afr;","\xD835\xDD1E") + ,("Agrave","\x00C0") + ,("agrave","\x00E0") + ,("Agrave;","\x00C0") + ,("agrave;","\x00E0") + ,("alefsym;","\x2135") + ,("aleph;","\x2135") + ,("Alpha;","\x0391") + ,("alpha;","\x03B1") + ,("Amacr;","\x0100") + ,("amacr;","\x0101") + ,("amalg;","\x2A3F") + ,("AMP","\x0026") + ,("amp","\x0026") + ,("AMP;","\x0026") + ,("amp;","\x0026") + ,("and;","\x2227") + ,("And;","\x2A53") + ,("andand;","\x2A55") + ,("andd;","\x2A5C") + ,("andslope;","\x2A58") + ,("andv;","\x2A5A") + ,("ang;","\x2220") + ,("ange;","\x29A4") + ,("angle;","\x2220") + ,("angmsd;","\x2221") + ,("angmsdaa;","\x29A8") + ,("angmsdab;","\x29A9") + ,("angmsdac;","\x29AA") + ,("angmsdad;","\x29AB") + ,("angmsdae;","\x29AC") + ,("angmsdaf;","\x29AD") + ,("angmsdag;","\x29AE") + ,("angmsdah;","\x29AF") + ,("angrt;","\x221F") + ,("angrtvb;","\x22BE") + ,("angrtvbd;","\x299D") + ,("angsph;","\x2222") + ,("angst;","\x00C5") + ,("angzarr;","\x237C") + ,("Aogon;","\x0104") + ,("aogon;","\x0105") + ,("Aopf;","\xD835\xDD38") + ,("aopf;","\xD835\xDD52") + ,("ap;","\x2248") + ,("apacir;","\x2A6F") + ,("ape;","\x224A") + ,("apE;","\x2A70") + ,("apid;","\x224B") + ,("apos;","\x0027") + ,("ApplyFunction;","\x2061") + ,("approx;","\x2248") + ,("approxeq;","\x224A") + ,("Aring","\x00C5") + ,("aring","\x00E5") + ,("Aring;","\x00C5") + ,("aring;","\x00E5") + ,("Ascr;","\xD835\xDC9C") + ,("ascr;","\xD835\xDCB6") + ,("Assign;","\x2254") + ,("ast;","\x002A") + ,("asymp;","\x2248") + ,("asympeq;","\x224D") + ,("Atilde","\x00C3") + ,("atilde","\x00E3") + ,("Atilde;","\x00C3") + ,("atilde;","\x00E3") + ,("Auml","\x00C4") + ,("auml","\x00E4") + ,("Auml;","\x00C4") + ,("auml;","\x00E4") + ,("awconint;","\x2233") + ,("awint;","\x2A11") + ,("backcong;","\x224C") + ,("backepsilon;","\x03F6") + ,("backprime;","\x2035") + ,("backsim;","\x223D") + ,("backsimeq;","\x22CD") + ,("Backslash;","\x2216") + ,("Barv;","\x2AE7") + ,("barvee;","\x22BD") + ,("barwed;","\x2305") + ,("Barwed;","\x2306") + ,("barwedge;","\x2305") + ,("bbrk;","\x23B5") + ,("bbrktbrk;","\x23B6") + ,("bcong;","\x224C") + ,("Bcy;","\x0411") + ,("bcy;","\x0431") + ,("bdquo;","\x201E") + ,("becaus;","\x2235") + ,("Because;","\x2235") + ,("because;","\x2235") + ,("bemptyv;","\x29B0") + ,("bepsi;","\x03F6") + ,("bernou;","\x212C") + ,("Bernoullis;","\x212C") + ,("Beta;","\x0392") + ,("beta;","\x03B2") + ,("beth;","\x2136") + ,("between;","\x226C") + ,("Bfr;","\xD835\xDD05") + ,("bfr;","\xD835\xDD1F") + ,("bigcap;","\x22C2") + ,("bigcirc;","\x25EF") + ,("bigcup;","\x22C3") + ,("bigodot;","\x2A00") + ,("bigoplus;","\x2A01") + ,("bigotimes;","\x2A02") + ,("bigsqcup;","\x2A06") + ,("bigstar;","\x2605") + ,("bigtriangledown;","\x25BD") + ,("bigtriangleup;","\x25B3") + ,("biguplus;","\x2A04") + ,("bigvee;","\x22C1") + ,("bigwedge;","\x22C0") + ,("bkarow;","\x290D") + ,("blacklozenge;","\x29EB") + ,("blacksquare;","\x25AA") + ,("blacktriangle;","\x25B4") + ,("blacktriangledown;","\x25BE") + ,("blacktriangleleft;","\x25C2") + ,("blacktriangleright;","\x25B8") + ,("blank;","\x2423") + ,("blk12;","\x2592") + ,("blk14;","\x2591") + ,("blk34;","\x2593") + ,("block;","\x2588") + ,("bne;","\x003D\x20E5") + ,("bnequiv;","\x2261\x20E5") + ,("bnot;","\x2310") + ,("bNot;","\x2AED") + ,("Bopf;","\xD835\xDD39") + ,("bopf;","\xD835\xDD53") + ,("bot;","\x22A5") + ,("bottom;","\x22A5") + ,("bowtie;","\x22C8") + ,("boxbox;","\x29C9") + ,("boxdl;","\x2510") + ,("boxdL;","\x2555") + ,("boxDl;","\x2556") + ,("boxDL;","\x2557") + ,("boxdr;","\x250C") + ,("boxdR;","\x2552") + ,("boxDr;","\x2553") + ,("boxDR;","\x2554") + ,("boxh;","\x2500") + ,("boxH;","\x2550") + ,("boxhd;","\x252C") + ,("boxHd;","\x2564") + ,("boxhD;","\x2565") + ,("boxHD;","\x2566") + ,("boxhu;","\x2534") + ,("boxHu;","\x2567") + ,("boxhU;","\x2568") + ,("boxHU;","\x2569") + ,("boxminus;","\x229F") + ,("boxplus;","\x229E") + ,("boxtimes;","\x22A0") + ,("boxul;","\x2518") + ,("boxuL;","\x255B") + ,("boxUl;","\x255C") + ,("boxUL;","\x255D") + ,("boxur;","\x2514") + ,("boxuR;","\x2558") + ,("boxUr;","\x2559") + ,("boxUR;","\x255A") + ,("boxv;","\x2502") + ,("boxV;","\x2551") + ,("boxvh;","\x253C") + ,("boxvH;","\x256A") + ,("boxVh;","\x256B") + ,("boxVH;","\x256C") + ,("boxvl;","\x2524") + ,("boxvL;","\x2561") + ,("boxVl;","\x2562") + ,("boxVL;","\x2563") + ,("boxvr;","\x251C") + ,("boxvR;","\x255E") + ,("boxVr;","\x255F") + ,("boxVR;","\x2560") + ,("bprime;","\x2035") + ,("Breve;","\x02D8") + ,("breve;","\x02D8") + ,("brvbar","\x00A6") + ,("brvbar;","\x00A6") + ,("Bscr;","\x212C") + ,("bscr;","\xD835\xDCB7") + ,("bsemi;","\x204F") + ,("bsim;","\x223D") + ,("bsime;","\x22CD") + ,("bsol;","\x005C") + ,("bsolb;","\x29C5") + ,("bsolhsub;","\x27C8") + ,("bull;","\x2022") + ,("bullet;","\x2022") + ,("bump;","\x224E") + ,("bumpe;","\x224F") + ,("bumpE;","\x2AAE") + ,("Bumpeq;","\x224E") + ,("bumpeq;","\x224F") + ,("Cacute;","\x0106") + ,("cacute;","\x0107") + ,("cap;","\x2229") + ,("Cap;","\x22D2") + ,("capand;","\x2A44") + ,("capbrcup;","\x2A49") + ,("capcap;","\x2A4B") + ,("capcup;","\x2A47") + ,("capdot;","\x2A40") + ,("CapitalDifferentialD;","\x2145") + ,("caps;","\x2229\xFE00") + ,("caret;","\x2041") + ,("caron;","\x02C7") + ,("Cayleys;","\x212D") + ,("ccaps;","\x2A4D") + ,("Ccaron;","\x010C") + ,("ccaron;","\x010D") + ,("Ccedil","\x00C7") + ,("ccedil","\x00E7") + ,("Ccedil;","\x00C7") + ,("ccedil;","\x00E7") + ,("Ccirc;","\x0108") + ,("ccirc;","\x0109") + ,("Cconint;","\x2230") + ,("ccups;","\x2A4C") + ,("ccupssm;","\x2A50") + ,("Cdot;","\x010A") + ,("cdot;","\x010B") + ,("cedil","\x00B8") + ,("cedil;","\x00B8") + ,("Cedilla;","\x00B8") + ,("cemptyv;","\x29B2") + ,("cent","\x00A2") + ,("cent;","\x00A2") + ,("CenterDot;","\x00B7") + ,("centerdot;","\x00B7") + ,("Cfr;","\x212D") + ,("cfr;","\xD835\xDD20") + ,("CHcy;","\x0427") + ,("chcy;","\x0447") + ,("check;","\x2713") + ,("checkmark;","\x2713") + ,("Chi;","\x03A7") + ,("chi;","\x03C7") + ,("cir;","\x25CB") + ,("circ;","\x02C6") + ,("circeq;","\x2257") + ,("circlearrowleft;","\x21BA") + ,("circlearrowright;","\x21BB") + ,("circledast;","\x229B") + ,("circledcirc;","\x229A") + ,("circleddash;","\x229D") + ,("CircleDot;","\x2299") + ,("circledR;","\x00AE") + ,("circledS;","\x24C8") + ,("CircleMinus;","\x2296") + ,("CirclePlus;","\x2295") + ,("CircleTimes;","\x2297") + ,("cire;","\x2257") + ,("cirE;","\x29C3") + ,("cirfnint;","\x2A10") + ,("cirmid;","\x2AEF") + ,("cirscir;","\x29C2") + ,("ClockwiseContourIntegral;","\x2232") + ,("CloseCurlyDoubleQuote;","\x201D") + ,("CloseCurlyQuote;","\x2019") + ,("clubs;","\x2663") + ,("clubsuit;","\x2663") + ,("colon;","\x003A") + ,("Colon;","\x2237") + ,("colone;","\x2254") + ,("Colone;","\x2A74") + ,("coloneq;","\x2254") + ,("comma;","\x002C") + ,("commat;","\x0040") + ,("comp;","\x2201") + ,("compfn;","\x2218") + ,("complement;","\x2201") + ,("complexes;","\x2102") + ,("cong;","\x2245") + ,("congdot;","\x2A6D") + ,("Congruent;","\x2261") + ,("conint;","\x222E") + ,("Conint;","\x222F") + ,("ContourIntegral;","\x222E") + ,("Copf;","\x2102") + ,("copf;","\xD835\xDD54") + ,("coprod;","\x2210") + ,("Coproduct;","\x2210") + ,("COPY","\x00A9") + ,("copy","\x00A9") + ,("COPY;","\x00A9") + ,("copy;","\x00A9") + ,("copysr;","\x2117") + ,("CounterClockwiseContourIntegral;","\x2233") + ,("crarr;","\x21B5") + ,("cross;","\x2717") + ,("Cross;","\x2A2F") + ,("Cscr;","\xD835\xDC9E") + ,("cscr;","\xD835\xDCB8") + ,("csub;","\x2ACF") + ,("csube;","\x2AD1") + ,("csup;","\x2AD0") + ,("csupe;","\x2AD2") + ,("ctdot;","\x22EF") + ,("cudarrl;","\x2938") + ,("cudarrr;","\x2935") + ,("cuepr;","\x22DE") + ,("cuesc;","\x22DF") + ,("cularr;","\x21B6") + ,("cularrp;","\x293D") + ,("cup;","\x222A") + ,("Cup;","\x22D3") + ,("cupbrcap;","\x2A48") + ,("CupCap;","\x224D") + ,("cupcap;","\x2A46") + ,("cupcup;","\x2A4A") + ,("cupdot;","\x228D") + ,("cupor;","\x2A45") + ,("cups;","\x222A\xFE00") + ,("curarr;","\x21B7") + ,("curarrm;","\x293C") + ,("curlyeqprec;","\x22DE") + ,("curlyeqsucc;","\x22DF") + ,("curlyvee;","\x22CE") + ,("curlywedge;","\x22CF") + ,("curren","\x00A4") + ,("curren;","\x00A4") + ,("curvearrowleft;","\x21B6") + ,("curvearrowright;","\x21B7") + ,("cuvee;","\x22CE") + ,("cuwed;","\x22CF") + ,("cwconint;","\x2232") + ,("cwint;","\x2231") + ,("cylcty;","\x232D") + ,("dagger;","\x2020") + ,("Dagger;","\x2021") + ,("daleth;","\x2138") + ,("darr;","\x2193") + ,("Darr;","\x21A1") + ,("dArr;","\x21D3") + ,("dash;","\x2010") + ,("dashv;","\x22A3") + ,("Dashv;","\x2AE4") + ,("dbkarow;","\x290F") + ,("dblac;","\x02DD") + ,("Dcaron;","\x010E") + ,("dcaron;","\x010F") + ,("Dcy;","\x0414") + ,("dcy;","\x0434") + ,("DD;","\x2145") + ,("dd;","\x2146") + ,("ddagger;","\x2021") + ,("ddarr;","\x21CA") + ,("DDotrahd;","\x2911") + ,("ddotseq;","\x2A77") + ,("deg","\x00B0") + ,("deg;","\x00B0") + ,("Del;","\x2207") + ,("Delta;","\x0394") + ,("delta;","\x03B4") + ,("demptyv;","\x29B1") + ,("dfisht;","\x297F") + ,("Dfr;","\xD835\xDD07") + ,("dfr;","\xD835\xDD21") + ,("dHar;","\x2965") + ,("dharl;","\x21C3") + ,("dharr;","\x21C2") + ,("DiacriticalAcute;","\x00B4") + ,("DiacriticalDot;","\x02D9") + ,("DiacriticalDoubleAcute;","\x02DD") + ,("DiacriticalGrave;","\x0060") + ,("DiacriticalTilde;","\x02DC") + ,("diam;","\x22C4") + ,("Diamond;","\x22C4") + ,("diamond;","\x22C4") + ,("diamondsuit;","\x2666") + ,("diams;","\x2666") + ,("die;","\x00A8") + ,("DifferentialD;","\x2146") + ,("digamma;","\x03DD") + ,("disin;","\x22F2") + ,("div;","\x00F7") + ,("divide","\x00F7") + ,("divide;","\x00F7") + ,("divideontimes;","\x22C7") + ,("divonx;","\x22C7") + ,("DJcy;","\x0402") + ,("djcy;","\x0452") + ,("dlcorn;","\x231E") + ,("dlcrop;","\x230D") + ,("dollar;","\x0024") + ,("Dopf;","\xD835\xDD3B") + ,("dopf;","\xD835\xDD55") + ,("Dot;","\x00A8") + ,("dot;","\x02D9") + ,("DotDot;","\x20DC") + ,("doteq;","\x2250") + ,("doteqdot;","\x2251") + ,("DotEqual;","\x2250") + ,("dotminus;","\x2238") + ,("dotplus;","\x2214") + ,("dotsquare;","\x22A1") + ,("doublebarwedge;","\x2306") + ,("DoubleContourIntegral;","\x222F") + ,("DoubleDot;","\x00A8") + ,("DoubleDownArrow;","\x21D3") + ,("DoubleLeftArrow;","\x21D0") + ,("DoubleLeftRightArrow;","\x21D4") + ,("DoubleLeftTee;","\x2AE4") + ,("DoubleLongLeftArrow;","\x27F8") + ,("DoubleLongLeftRightArrow;","\x27FA") + ,("DoubleLongRightArrow;","\x27F9") + ,("DoubleRightArrow;","\x21D2") + ,("DoubleRightTee;","\x22A8") + ,("DoubleUpArrow;","\x21D1") + ,("DoubleUpDownArrow;","\x21D5") + ,("DoubleVerticalBar;","\x2225") + ,("DownArrow;","\x2193") + ,("downarrow;","\x2193") + ,("Downarrow;","\x21D3") + ,("DownArrowBar;","\x2913") + ,("DownArrowUpArrow;","\x21F5") + ,("DownBreve;","\x0311") + ,("downdownarrows;","\x21CA") + ,("downharpoonleft;","\x21C3") + ,("downharpoonright;","\x21C2") + ,("DownLeftRightVector;","\x2950") + ,("DownLeftTeeVector;","\x295E") + ,("DownLeftVector;","\x21BD") + ,("DownLeftVectorBar;","\x2956") + ,("DownRightTeeVector;","\x295F") + ,("DownRightVector;","\x21C1") + ,("DownRightVectorBar;","\x2957") + ,("DownTee;","\x22A4") + ,("DownTeeArrow;","\x21A7") + ,("drbkarow;","\x2910") + ,("drcorn;","\x231F") + ,("drcrop;","\x230C") + ,("Dscr;","\xD835\xDC9F") + ,("dscr;","\xD835\xDCB9") + ,("DScy;","\x0405") + ,("dscy;","\x0455") + ,("dsol;","\x29F6") + ,("Dstrok;","\x0110") + ,("dstrok;","\x0111") + ,("dtdot;","\x22F1") + ,("dtri;","\x25BF") + ,("dtrif;","\x25BE") + ,("duarr;","\x21F5") + ,("duhar;","\x296F") + ,("dwangle;","\x29A6") + ,("DZcy;","\x040F") + ,("dzcy;","\x045F") + ,("dzigrarr;","\x27FF") + ,("Eacute","\x00C9") + ,("eacute","\x00E9") + ,("Eacute;","\x00C9") + ,("eacute;","\x00E9") + ,("easter;","\x2A6E") + ,("Ecaron;","\x011A") + ,("ecaron;","\x011B") + ,("ecir;","\x2256") + ,("Ecirc","\x00CA") + ,("ecirc","\x00EA") + ,("Ecirc;","\x00CA") + ,("ecirc;","\x00EA") + ,("ecolon;","\x2255") + ,("Ecy;","\x042D") + ,("ecy;","\x044D") + ,("eDDot;","\x2A77") + ,("Edot;","\x0116") + ,("edot;","\x0117") + ,("eDot;","\x2251") + ,("ee;","\x2147") + ,("efDot;","\x2252") + ,("Efr;","\xD835\xDD08") + ,("efr;","\xD835\xDD22") + ,("eg;","\x2A9A") + ,("Egrave","\x00C8") + ,("egrave","\x00E8") + ,("Egrave;","\x00C8") + ,("egrave;","\x00E8") + ,("egs;","\x2A96") + ,("egsdot;","\x2A98") + ,("el;","\x2A99") + ,("Element;","\x2208") + ,("elinters;","\x23E7") + ,("ell;","\x2113") + ,("els;","\x2A95") + ,("elsdot;","\x2A97") + ,("Emacr;","\x0112") + ,("emacr;","\x0113") + ,("empty;","\x2205") + ,("emptyset;","\x2205") + ,("EmptySmallSquare;","\x25FB") + ,("emptyv;","\x2205") + ,("EmptyVerySmallSquare;","\x25AB") + ,("emsp13;","\x2004") + ,("emsp14;","\x2005") + ,("emsp;","\x2003") + ,("ENG;","\x014A") + ,("eng;","\x014B") + ,("ensp;","\x2002") + ,("Eogon;","\x0118") + ,("eogon;","\x0119") + ,("Eopf;","\xD835\xDD3C") + ,("eopf;","\xD835\xDD56") + ,("epar;","\x22D5") + ,("eparsl;","\x29E3") + ,("eplus;","\x2A71") + ,("epsi;","\x03B5") + ,("Epsilon;","\x0395") + ,("epsilon;","\x03B5") + ,("epsiv;","\x03F5") + ,("eqcirc;","\x2256") + ,("eqcolon;","\x2255") + ,("eqsim;","\x2242") + ,("eqslantgtr;","\x2A96") + ,("eqslantless;","\x2A95") + ,("Equal;","\x2A75") + ,("equals;","\x003D") + ,("EqualTilde;","\x2242") + ,("equest;","\x225F") + ,("Equilibrium;","\x21CC") + ,("equiv;","\x2261") + ,("equivDD;","\x2A78") + ,("eqvparsl;","\x29E5") + ,("erarr;","\x2971") + ,("erDot;","\x2253") + ,("escr;","\x212F") + ,("Escr;","\x2130") + ,("esdot;","\x2250") + ,("esim;","\x2242") + ,("Esim;","\x2A73") + ,("Eta;","\x0397") + ,("eta;","\x03B7") + ,("ETH","\x00D0") + ,("eth","\x00F0") + ,("ETH;","\x00D0") + ,("eth;","\x00F0") + ,("Euml","\x00CB") + ,("euml","\x00EB") + ,("Euml;","\x00CB") + ,("euml;","\x00EB") + ,("euro;","\x20AC") + ,("excl;","\x0021") + ,("exist;","\x2203") + ,("Exists;","\x2203") + ,("expectation;","\x2130") + ,("ExponentialE;","\x2147") + ,("exponentiale;","\x2147") + ,("fallingdotseq;","\x2252") + ,("Fcy;","\x0424") + ,("fcy;","\x0444") + ,("female;","\x2640") + ,("ffilig;","\xFB03") + ,("fflig;","\xFB00") + ,("ffllig;","\xFB04") + ,("Ffr;","\xD835\xDD09") + ,("ffr;","\xD835\xDD23") + ,("filig;","\xFB01") + ,("FilledSmallSquare;","\x25FC") + ,("FilledVerySmallSquare;","\x25AA") + ,("fjlig;","\x0066\x006A") + ,("flat;","\x266D") + ,("fllig;","\xFB02") + ,("fltns;","\x25B1") + ,("fnof;","\x0192") + ,("Fopf;","\xD835\xDD3D") + ,("fopf;","\xD835\xDD57") + ,("ForAll;","\x2200") + ,("forall;","\x2200") + ,("fork;","\x22D4") + ,("forkv;","\x2AD9") + ,("Fouriertrf;","\x2131") + ,("fpartint;","\x2A0D") + ,("frac12","\x00BD") + ,("frac12;","\x00BD") + ,("frac13;","\x2153") + ,("frac14","\x00BC") + ,("frac14;","\x00BC") + ,("frac15;","\x2155") + ,("frac16;","\x2159") + ,("frac18;","\x215B") + ,("frac23;","\x2154") + ,("frac25;","\x2156") + ,("frac34","\x00BE") + ,("frac34;","\x00BE") + ,("frac35;","\x2157") + ,("frac38;","\x215C") + ,("frac45;","\x2158") + ,("frac56;","\x215A") + ,("frac58;","\x215D") + ,("frac78;","\x215E") + ,("frasl;","\x2044") + ,("frown;","\x2322") + ,("Fscr;","\x2131") + ,("fscr;","\xD835\xDCBB") + ,("gacute;","\x01F5") + ,("Gamma;","\x0393") + ,("gamma;","\x03B3") + ,("Gammad;","\x03DC") + ,("gammad;","\x03DD") + ,("gap;","\x2A86") + ,("Gbreve;","\x011E") + ,("gbreve;","\x011F") + ,("Gcedil;","\x0122") + ,("Gcirc;","\x011C") + ,("gcirc;","\x011D") + ,("Gcy;","\x0413") + ,("gcy;","\x0433") + ,("Gdot;","\x0120") + ,("gdot;","\x0121") + ,("ge;","\x2265") + ,("gE;","\x2267") + ,("gel;","\x22DB") + ,("gEl;","\x2A8C") + ,("geq;","\x2265") + ,("geqq;","\x2267") + ,("geqslant;","\x2A7E") + ,("ges;","\x2A7E") + ,("gescc;","\x2AA9") + ,("gesdot;","\x2A80") + ,("gesdoto;","\x2A82") + ,("gesdotol;","\x2A84") + ,("gesl;","\x22DB\xFE00") + ,("gesles;","\x2A94") + ,("Gfr;","\xD835\xDD0A") + ,("gfr;","\xD835\xDD24") + ,("gg;","\x226B") + ,("Gg;","\x22D9") + ,("ggg;","\x22D9") + ,("gimel;","\x2137") + ,("GJcy;","\x0403") + ,("gjcy;","\x0453") + ,("gl;","\x2277") + ,("gla;","\x2AA5") + ,("glE;","\x2A92") + ,("glj;","\x2AA4") + ,("gnap;","\x2A8A") + ,("gnapprox;","\x2A8A") + ,("gnE;","\x2269") + ,("gne;","\x2A88") + ,("gneq;","\x2A88") + ,("gneqq;","\x2269") + ,("gnsim;","\x22E7") + ,("Gopf;","\xD835\xDD3E") + ,("gopf;","\xD835\xDD58") + ,("grave;","\x0060") + ,("GreaterEqual;","\x2265") + ,("GreaterEqualLess;","\x22DB") + ,("GreaterFullEqual;","\x2267") + ,("GreaterGreater;","\x2AA2") + ,("GreaterLess;","\x2277") + ,("GreaterSlantEqual;","\x2A7E") + ,("GreaterTilde;","\x2273") + ,("gscr;","\x210A") + ,("Gscr;","\xD835\xDCA2") + ,("gsim;","\x2273") + ,("gsime;","\x2A8E") + ,("gsiml;","\x2A90") + ,("GT","\x003E") + ,("gt","\x003E") + ,("GT;","\x003E") + ,("gt;","\x003E") + ,("Gt;","\x226B") + ,("gtcc;","\x2AA7") + ,("gtcir;","\x2A7A") + ,("gtdot;","\x22D7") + ,("gtlPar;","\x2995") + ,("gtquest;","\x2A7C") + ,("gtrapprox;","\x2A86") + ,("gtrarr;","\x2978") + ,("gtrdot;","\x22D7") + ,("gtreqless;","\x22DB") + ,("gtreqqless;","\x2A8C") + ,("gtrless;","\x2277") + ,("gtrsim;","\x2273") + ,("gvertneqq;","\x2269\xFE00") + ,("gvnE;","\x2269\xFE00") + ,("Hacek;","\x02C7") + ,("hairsp;","\x200A") + ,("half;","\x00BD") + ,("hamilt;","\x210B") + ,("HARDcy;","\x042A") + ,("hardcy;","\x044A") + ,("harr;","\x2194") + ,("hArr;","\x21D4") + ,("harrcir;","\x2948") + ,("harrw;","\x21AD") + ,("Hat;","\x005E") + ,("hbar;","\x210F") + ,("Hcirc;","\x0124") + ,("hcirc;","\x0125") + ,("hearts;","\x2665") + ,("heartsuit;","\x2665") + ,("hellip;","\x2026") + ,("hercon;","\x22B9") + ,("Hfr;","\x210C") + ,("hfr;","\xD835\xDD25") + ,("HilbertSpace;","\x210B") + ,("hksearow;","\x2925") + ,("hkswarow;","\x2926") + ,("hoarr;","\x21FF") + ,("homtht;","\x223B") + ,("hookleftarrow;","\x21A9") + ,("hookrightarrow;","\x21AA") + ,("Hopf;","\x210D") + ,("hopf;","\xD835\xDD59") + ,("horbar;","\x2015") + ,("HorizontalLine;","\x2500") + ,("Hscr;","\x210B") + ,("hscr;","\xD835\xDCBD") + ,("hslash;","\x210F") + ,("Hstrok;","\x0126") + ,("hstrok;","\x0127") + ,("HumpDownHump;","\x224E") + ,("HumpEqual;","\x224F") + ,("hybull;","\x2043") + ,("hyphen;","\x2010") + ,("Iacute","\x00CD") + ,("iacute","\x00ED") + ,("Iacute;","\x00CD") + ,("iacute;","\x00ED") + ,("ic;","\x2063") + ,("Icirc","\x00CE") + ,("icirc","\x00EE") + ,("Icirc;","\x00CE") + ,("icirc;","\x00EE") + ,("Icy;","\x0418") + ,("icy;","\x0438") + ,("Idot;","\x0130") + ,("IEcy;","\x0415") + ,("iecy;","\x0435") + ,("iexcl","\x00A1") + ,("iexcl;","\x00A1") + ,("iff;","\x21D4") + ,("Ifr;","\x2111") + ,("ifr;","\xD835\xDD26") + ,("Igrave","\x00CC") + ,("igrave","\x00EC") + ,("Igrave;","\x00CC") + ,("igrave;","\x00EC") + ,("ii;","\x2148") + ,("iiiint;","\x2A0C") + ,("iiint;","\x222D") + ,("iinfin;","\x29DC") + ,("iiota;","\x2129") + ,("IJlig;","\x0132") + ,("ijlig;","\x0133") + ,("Im;","\x2111") + ,("Imacr;","\x012A") + ,("imacr;","\x012B") + ,("image;","\x2111") + ,("ImaginaryI;","\x2148") + ,("imagline;","\x2110") + ,("imagpart;","\x2111") + ,("imath;","\x0131") + ,("imof;","\x22B7") + ,("imped;","\x01B5") + ,("Implies;","\x21D2") + ,("in;","\x2208") + ,("incare;","\x2105") + ,("infin;","\x221E") + ,("infintie;","\x29DD") + ,("inodot;","\x0131") + ,("int;","\x222B") + ,("Int;","\x222C") + ,("intcal;","\x22BA") + ,("integers;","\x2124") + ,("Integral;","\x222B") + ,("intercal;","\x22BA") + ,("Intersection;","\x22C2") + ,("intlarhk;","\x2A17") + ,("intprod;","\x2A3C") + ,("InvisibleComma;","\x2063") + ,("InvisibleTimes;","\x2062") + ,("IOcy;","\x0401") + ,("iocy;","\x0451") + ,("Iogon;","\x012E") + ,("iogon;","\x012F") + ,("Iopf;","\xD835\xDD40") + ,("iopf;","\xD835\xDD5A") + ,("Iota;","\x0399") + ,("iota;","\x03B9") + ,("iprod;","\x2A3C") + ,("iquest","\x00BF") + ,("iquest;","\x00BF") + ,("Iscr;","\x2110") + ,("iscr;","\xD835\xDCBE") + ,("isin;","\x2208") + ,("isindot;","\x22F5") + ,("isinE;","\x22F9") + ,("isins;","\x22F4") + ,("isinsv;","\x22F3") + ,("isinv;","\x2208") + ,("it;","\x2062") + ,("Itilde;","\x0128") + ,("itilde;","\x0129") + ,("Iukcy;","\x0406") + ,("iukcy;","\x0456") + ,("Iuml","\x00CF") + ,("iuml","\x00EF") + ,("Iuml;","\x00CF") + ,("iuml;","\x00EF") + ,("Jcirc;","\x0134") + ,("jcirc;","\x0135") + ,("Jcy;","\x0419") + ,("jcy;","\x0439") + ,("Jfr;","\xD835\xDD0D") + ,("jfr;","\xD835\xDD27") + ,("jmath;","\x0237") + ,("Jopf;","\xD835\xDD41") + ,("jopf;","\xD835\xDD5B") + ,("Jscr;","\xD835\xDCA5") + ,("jscr;","\xD835\xDCBF") + ,("Jsercy;","\x0408") + ,("jsercy;","\x0458") + ,("Jukcy;","\x0404") + ,("jukcy;","\x0454") + ,("Kappa;","\x039A") + ,("kappa;","\x03BA") + ,("kappav;","\x03F0") + ,("Kcedil;","\x0136") + ,("kcedil;","\x0137") + ,("Kcy;","\x041A") + ,("kcy;","\x043A") + ,("Kfr;","\xD835\xDD0E") + ,("kfr;","\xD835\xDD28") + ,("kgreen;","\x0138") + ,("KHcy;","\x0425") + ,("khcy;","\x0445") + ,("KJcy;","\x040C") + ,("kjcy;","\x045C") + ,("Kopf;","\xD835\xDD42") + ,("kopf;","\xD835\xDD5C") + ,("Kscr;","\xD835\xDCA6") + ,("kscr;","\xD835\xDCC0") + ,("lAarr;","\x21DA") + ,("Lacute;","\x0139") + ,("lacute;","\x013A") + ,("laemptyv;","\x29B4") + ,("lagran;","\x2112") + ,("Lambda;","\x039B") + ,("lambda;","\x03BB") + ,("lang;","\x27E8") + ,("Lang;","\x27EA") + ,("langd;","\x2991") + ,("langle;","\x27E8") + ,("lap;","\x2A85") + ,("Laplacetrf;","\x2112") + ,("laquo","\x00AB") + ,("laquo;","\x00AB") + ,("larr;","\x2190") + ,("Larr;","\x219E") + ,("lArr;","\x21D0") + ,("larrb;","\x21E4") + ,("larrbfs;","\x291F") + ,("larrfs;","\x291D") + ,("larrhk;","\x21A9") + ,("larrlp;","\x21AB") + ,("larrpl;","\x2939") + ,("larrsim;","\x2973") + ,("larrtl;","\x21A2") + ,("lat;","\x2AAB") + ,("latail;","\x2919") + ,("lAtail;","\x291B") + ,("late;","\x2AAD") + ,("lates;","\x2AAD\xFE00") + ,("lbarr;","\x290C") + ,("lBarr;","\x290E") + ,("lbbrk;","\x2772") + ,("lbrace;","\x007B") + ,("lbrack;","\x005B") + ,("lbrke;","\x298B") + ,("lbrksld;","\x298F") + ,("lbrkslu;","\x298D") + ,("Lcaron;","\x013D") + ,("lcaron;","\x013E") + ,("Lcedil;","\x013B") + ,("lcedil;","\x013C") + ,("lceil;","\x2308") + ,("lcub;","\x007B") + ,("Lcy;","\x041B") + ,("lcy;","\x043B") + ,("ldca;","\x2936") + ,("ldquo;","\x201C") + ,("ldquor;","\x201E") + ,("ldrdhar;","\x2967") + ,("ldrushar;","\x294B") + ,("ldsh;","\x21B2") + ,("le;","\x2264") + ,("lE;","\x2266") + ,("LeftAngleBracket;","\x27E8") + ,("LeftArrow;","\x2190") + ,("leftarrow;","\x2190") + ,("Leftarrow;","\x21D0") + ,("LeftArrowBar;","\x21E4") + ,("LeftArrowRightArrow;","\x21C6") + ,("leftarrowtail;","\x21A2") + ,("LeftCeiling;","\x2308") + ,("LeftDoubleBracket;","\x27E6") + ,("LeftDownTeeVector;","\x2961") + ,("LeftDownVector;","\x21C3") + ,("LeftDownVectorBar;","\x2959") + ,("LeftFloor;","\x230A") + ,("leftharpoondown;","\x21BD") + ,("leftharpoonup;","\x21BC") + ,("leftleftarrows;","\x21C7") + ,("LeftRightArrow;","\x2194") + ,("leftrightarrow;","\x2194") + ,("Leftrightarrow;","\x21D4") + ,("leftrightarrows;","\x21C6") + ,("leftrightharpoons;","\x21CB") + ,("leftrightsquigarrow;","\x21AD") + ,("LeftRightVector;","\x294E") + ,("LeftTee;","\x22A3") + ,("LeftTeeArrow;","\x21A4") + ,("LeftTeeVector;","\x295A") + ,("leftthreetimes;","\x22CB") + ,("LeftTriangle;","\x22B2") + ,("LeftTriangleBar;","\x29CF") + ,("LeftTriangleEqual;","\x22B4") + ,("LeftUpDownVector;","\x2951") + ,("LeftUpTeeVector;","\x2960") + ,("LeftUpVector;","\x21BF") + ,("LeftUpVectorBar;","\x2958") + ,("LeftVector;","\x21BC") + ,("LeftVectorBar;","\x2952") + ,("leg;","\x22DA") + ,("lEg;","\x2A8B") + ,("leq;","\x2264") + ,("leqq;","\x2266") + ,("leqslant;","\x2A7D") + ,("les;","\x2A7D") + ,("lescc;","\x2AA8") + ,("lesdot;","\x2A7F") + ,("lesdoto;","\x2A81") + ,("lesdotor;","\x2A83") + ,("lesg;","\x22DA\xFE00") + ,("lesges;","\x2A93") + ,("lessapprox;","\x2A85") + ,("lessdot;","\x22D6") + ,("lesseqgtr;","\x22DA") + ,("lesseqqgtr;","\x2A8B") + ,("LessEqualGreater;","\x22DA") + ,("LessFullEqual;","\x2266") + ,("LessGreater;","\x2276") + ,("lessgtr;","\x2276") + ,("LessLess;","\x2AA1") + ,("lesssim;","\x2272") + ,("LessSlantEqual;","\x2A7D") + ,("LessTilde;","\x2272") + ,("lfisht;","\x297C") + ,("lfloor;","\x230A") + ,("Lfr;","\xD835\xDD0F") + ,("lfr;","\xD835\xDD29") + ,("lg;","\x2276") + ,("lgE;","\x2A91") + ,("lHar;","\x2962") + ,("lhard;","\x21BD") + ,("lharu;","\x21BC") + ,("lharul;","\x296A") + ,("lhblk;","\x2584") + ,("LJcy;","\x0409") + ,("ljcy;","\x0459") + ,("ll;","\x226A") + ,("Ll;","\x22D8") + ,("llarr;","\x21C7") + ,("llcorner;","\x231E") + ,("Lleftarrow;","\x21DA") + ,("llhard;","\x296B") + ,("lltri;","\x25FA") + ,("Lmidot;","\x013F") + ,("lmidot;","\x0140") + ,("lmoust;","\x23B0") + ,("lmoustache;","\x23B0") + ,("lnap;","\x2A89") + ,("lnapprox;","\x2A89") + ,("lnE;","\x2268") + ,("lne;","\x2A87") + ,("lneq;","\x2A87") + ,("lneqq;","\x2268") + ,("lnsim;","\x22E6") + ,("loang;","\x27EC") + ,("loarr;","\x21FD") + ,("lobrk;","\x27E6") + ,("LongLeftArrow;","\x27F5") + ,("longleftarrow;","\x27F5") + ,("Longleftarrow;","\x27F8") + ,("LongLeftRightArrow;","\x27F7") + ,("longleftrightarrow;","\x27F7") + ,("Longleftrightarrow;","\x27FA") + ,("longmapsto;","\x27FC") + ,("LongRightArrow;","\x27F6") + ,("longrightarrow;","\x27F6") + ,("Longrightarrow;","\x27F9") + ,("looparrowleft;","\x21AB") + ,("looparrowright;","\x21AC") + ,("lopar;","\x2985") + ,("Lopf;","\xD835\xDD43") + ,("lopf;","\xD835\xDD5D") + ,("loplus;","\x2A2D") + ,("lotimes;","\x2A34") + ,("lowast;","\x2217") + ,("lowbar;","\x005F") + ,("LowerLeftArrow;","\x2199") + ,("LowerRightArrow;","\x2198") + ,("loz;","\x25CA") + ,("lozenge;","\x25CA") + ,("lozf;","\x29EB") + ,("lpar;","\x0028") + ,("lparlt;","\x2993") + ,("lrarr;","\x21C6") + ,("lrcorner;","\x231F") + ,("lrhar;","\x21CB") + ,("lrhard;","\x296D") + ,("lrm;","\x200E") + ,("lrtri;","\x22BF") + ,("lsaquo;","\x2039") + ,("Lscr;","\x2112") + ,("lscr;","\xD835\xDCC1") + ,("Lsh;","\x21B0") + ,("lsh;","\x21B0") + ,("lsim;","\x2272") + ,("lsime;","\x2A8D") + ,("lsimg;","\x2A8F") + ,("lsqb;","\x005B") + ,("lsquo;","\x2018") + ,("lsquor;","\x201A") + ,("Lstrok;","\x0141") + ,("lstrok;","\x0142") + ,("LT","\x003C") + ,("lt","\x003C") + ,("LT;","\x003C") + ,("lt;","\x003C") + ,("Lt;","\x226A") + ,("ltcc;","\x2AA6") + ,("ltcir;","\x2A79") + ,("ltdot;","\x22D6") + ,("lthree;","\x22CB") + ,("ltimes;","\x22C9") + ,("ltlarr;","\x2976") + ,("ltquest;","\x2A7B") + ,("ltri;","\x25C3") + ,("ltrie;","\x22B4") + ,("ltrif;","\x25C2") + ,("ltrPar;","\x2996") + ,("lurdshar;","\x294A") + ,("luruhar;","\x2966") + ,("lvertneqq;","\x2268\xFE00") + ,("lvnE;","\x2268\xFE00") + ,("macr","\x00AF") + ,("macr;","\x00AF") + ,("male;","\x2642") + ,("malt;","\x2720") + ,("maltese;","\x2720") + ,("map;","\x21A6") + ,("Map;","\x2905") + ,("mapsto;","\x21A6") + ,("mapstodown;","\x21A7") + ,("mapstoleft;","\x21A4") + ,("mapstoup;","\x21A5") + ,("marker;","\x25AE") + ,("mcomma;","\x2A29") + ,("Mcy;","\x041C") + ,("mcy;","\x043C") + ,("mdash;","\x2014") + ,("mDDot;","\x223A") + ,("measuredangle;","\x2221") + ,("MediumSpace;","\x205F") + ,("Mellintrf;","\x2133") + ,("Mfr;","\xD835\xDD10") + ,("mfr;","\xD835\xDD2A") + ,("mho;","\x2127") + ,("micro","\x00B5") + ,("micro;","\x00B5") + ,("mid;","\x2223") + ,("midast;","\x002A") + ,("midcir;","\x2AF0") + ,("middot","\x00B7") + ,("middot;","\x00B7") + ,("minus;","\x2212") + ,("minusb;","\x229F") + ,("minusd;","\x2238") + ,("minusdu;","\x2A2A") + ,("MinusPlus;","\x2213") + ,("mlcp;","\x2ADB") + ,("mldr;","\x2026") + ,("mnplus;","\x2213") + ,("models;","\x22A7") + ,("Mopf;","\xD835\xDD44") + ,("mopf;","\xD835\xDD5E") + ,("mp;","\x2213") + ,("Mscr;","\x2133") + ,("mscr;","\xD835\xDCC2") + ,("mstpos;","\x223E") + ,("Mu;","\x039C") + ,("mu;","\x03BC") + ,("multimap;","\x22B8") + ,("mumap;","\x22B8") + ,("nabla;","\x2207") + ,("Nacute;","\x0143") + ,("nacute;","\x0144") + ,("nang;","\x2220\x20D2") + ,("nap;","\x2249") + ,("napE;","\x2A70\x0338") + ,("napid;","\x224B\x0338") + ,("napos;","\x0149") + ,("napprox;","\x2249") + ,("natur;","\x266E") + ,("natural;","\x266E") + ,("naturals;","\x2115") + ,("nbsp","\x00A0") + ,("nbsp;","\x00A0") + ,("nbump;","\x224E\x0338") + ,("nbumpe;","\x224F\x0338") + ,("ncap;","\x2A43") + ,("Ncaron;","\x0147") + ,("ncaron;","\x0148") + ,("Ncedil;","\x0145") + ,("ncedil;","\x0146") + ,("ncong;","\x2247") + ,("ncongdot;","\x2A6D\x0338") + ,("ncup;","\x2A42") + ,("Ncy;","\x041D") + ,("ncy;","\x043D") + ,("ndash;","\x2013") + ,("ne;","\x2260") + ,("nearhk;","\x2924") + ,("nearr;","\x2197") + ,("neArr;","\x21D7") + ,("nearrow;","\x2197") + ,("nedot;","\x2250\x0338") + ,("NegativeMediumSpace;","\x200B") + ,("NegativeThickSpace;","\x200B") + ,("NegativeThinSpace;","\x200B") + ,("NegativeVeryThinSpace;","\x200B") + ,("nequiv;","\x2262") + ,("nesear;","\x2928") + ,("nesim;","\x2242\x0338") + ,("NestedGreaterGreater;","\x226B") + ,("NestedLessLess;","\x226A") + ,("NewLine;","\x000A") + ,("nexist;","\x2204") + ,("nexists;","\x2204") + ,("Nfr;","\xD835\xDD11") + ,("nfr;","\xD835\xDD2B") + ,("ngE;","\x2267\x0338") + ,("nge;","\x2271") + ,("ngeq;","\x2271") + ,("ngeqq;","\x2267\x0338") + ,("ngeqslant;","\x2A7E\x0338") + ,("nges;","\x2A7E\x0338") + ,("nGg;","\x22D9\x0338") + ,("ngsim;","\x2275") + ,("nGt;","\x226B\x20D2") + ,("ngt;","\x226F") + ,("ngtr;","\x226F") + ,("nGtv;","\x226B\x0338") + ,("nharr;","\x21AE") + ,("nhArr;","\x21CE") + ,("nhpar;","\x2AF2") + ,("ni;","\x220B") + ,("nis;","\x22FC") + ,("nisd;","\x22FA") + ,("niv;","\x220B") + ,("NJcy;","\x040A") + ,("njcy;","\x045A") + ,("nlarr;","\x219A") + ,("nlArr;","\x21CD") + ,("nldr;","\x2025") + ,("nlE;","\x2266\x0338") + ,("nle;","\x2270") + ,("nleftarrow;","\x219A") + ,("nLeftarrow;","\x21CD") + ,("nleftrightarrow;","\x21AE") + ,("nLeftrightarrow;","\x21CE") + ,("nleq;","\x2270") + ,("nleqq;","\x2266\x0338") + ,("nleqslant;","\x2A7D\x0338") + ,("nles;","\x2A7D\x0338") + ,("nless;","\x226E") + ,("nLl;","\x22D8\x0338") + ,("nlsim;","\x2274") + ,("nLt;","\x226A\x20D2") + ,("nlt;","\x226E") + ,("nltri;","\x22EA") + ,("nltrie;","\x22EC") + ,("nLtv;","\x226A\x0338") + ,("nmid;","\x2224") + ,("NoBreak;","\x2060") + ,("NonBreakingSpace;","\x00A0") + ,("Nopf;","\x2115") + ,("nopf;","\xD835\xDD5F") + ,("not","\x00AC") + ,("not;","\x00AC") + ,("Not;","\x2AEC") + ,("NotCongruent;","\x2262") + ,("NotCupCap;","\x226D") + ,("NotDoubleVerticalBar;","\x2226") + ,("NotElement;","\x2209") + ,("NotEqual;","\x2260") + ,("NotEqualTilde;","\x2242\x0338") + ,("NotExists;","\x2204") + ,("NotGreater;","\x226F") + ,("NotGreaterEqual;","\x2271") + ,("NotGreaterFullEqual;","\x2267\x0338") + ,("NotGreaterGreater;","\x226B\x0338") + ,("NotGreaterLess;","\x2279") + ,("NotGreaterSlantEqual;","\x2A7E\x0338") + ,("NotGreaterTilde;","\x2275") + ,("NotHumpDownHump;","\x224E\x0338") + ,("NotHumpEqual;","\x224F\x0338") + ,("notin;","\x2209") + ,("notindot;","\x22F5\x0338") + ,("notinE;","\x22F9\x0338") + ,("notinva;","\x2209") + ,("notinvb;","\x22F7") + ,("notinvc;","\x22F6") + ,("NotLeftTriangle;","\x22EA") + ,("NotLeftTriangleBar;","\x29CF\x0338") + ,("NotLeftTriangleEqual;","\x22EC") + ,("NotLess;","\x226E") + ,("NotLessEqual;","\x2270") + ,("NotLessGreater;","\x2278") + ,("NotLessLess;","\x226A\x0338") + ,("NotLessSlantEqual;","\x2A7D\x0338") + ,("NotLessTilde;","\x2274") + ,("NotNestedGreaterGreater;","\x2AA2\x0338") + ,("NotNestedLessLess;","\x2AA1\x0338") + ,("notni;","\x220C") + ,("notniva;","\x220C") + ,("notnivb;","\x22FE") + ,("notnivc;","\x22FD") + ,("NotPrecedes;","\x2280") + ,("NotPrecedesEqual;","\x2AAF\x0338") + ,("NotPrecedesSlantEqual;","\x22E0") + ,("NotReverseElement;","\x220C") + ,("NotRightTriangle;","\x22EB") + ,("NotRightTriangleBar;","\x29D0\x0338") + ,("NotRightTriangleEqual;","\x22ED") + ,("NotSquareSubset;","\x228F\x0338") + ,("NotSquareSubsetEqual;","\x22E2") + ,("NotSquareSuperset;","\x2290\x0338") + ,("NotSquareSupersetEqual;","\x22E3") + ,("NotSubset;","\x2282\x20D2") + ,("NotSubsetEqual;","\x2288") + ,("NotSucceeds;","\x2281") + ,("NotSucceedsEqual;","\x2AB0\x0338") + ,("NotSucceedsSlantEqual;","\x22E1") + ,("NotSucceedsTilde;","\x227F\x0338") + ,("NotSuperset;","\x2283\x20D2") + ,("NotSupersetEqual;","\x2289") + ,("NotTilde;","\x2241") + ,("NotTildeEqual;","\x2244") + ,("NotTildeFullEqual;","\x2247") + ,("NotTildeTilde;","\x2249") + ,("NotVerticalBar;","\x2224") + ,("npar;","\x2226") + ,("nparallel;","\x2226") + ,("nparsl;","\x2AFD\x20E5") + ,("npart;","\x2202\x0338") + ,("npolint;","\x2A14") + ,("npr;","\x2280") + ,("nprcue;","\x22E0") + ,("npre;","\x2AAF\x0338") + ,("nprec;","\x2280") + ,("npreceq;","\x2AAF\x0338") + ,("nrarr;","\x219B") + ,("nrArr;","\x21CF") + ,("nrarrc;","\x2933\x0338") + ,("nrarrw;","\x219D\x0338") + ,("nrightarrow;","\x219B") + ,("nRightarrow;","\x21CF") + ,("nrtri;","\x22EB") + ,("nrtrie;","\x22ED") + ,("nsc;","\x2281") + ,("nsccue;","\x22E1") + ,("nsce;","\x2AB0\x0338") + ,("Nscr;","\xD835\xDCA9") + ,("nscr;","\xD835\xDCC3") + ,("nshortmid;","\x2224") + ,("nshortparallel;","\x2226") + ,("nsim;","\x2241") + ,("nsime;","\x2244") + ,("nsimeq;","\x2244") + ,("nsmid;","\x2224") + ,("nspar;","\x2226") + ,("nsqsube;","\x22E2") + ,("nsqsupe;","\x22E3") + ,("nsub;","\x2284") + ,("nsube;","\x2288") + ,("nsubE;","\x2AC5\x0338") + ,("nsubset;","\x2282\x20D2") + ,("nsubseteq;","\x2288") + ,("nsubseteqq;","\x2AC5\x0338") + ,("nsucc;","\x2281") + ,("nsucceq;","\x2AB0\x0338") + ,("nsup;","\x2285") + ,("nsupe;","\x2289") + ,("nsupE;","\x2AC6\x0338") + ,("nsupset;","\x2283\x20D2") + ,("nsupseteq;","\x2289") + ,("nsupseteqq;","\x2AC6\x0338") + ,("ntgl;","\x2279") + ,("Ntilde","\x00D1") + ,("ntilde","\x00F1") + ,("Ntilde;","\x00D1") + ,("ntilde;","\x00F1") + ,("ntlg;","\x2278") + ,("ntriangleleft;","\x22EA") + ,("ntrianglelefteq;","\x22EC") + ,("ntriangleright;","\x22EB") + ,("ntrianglerighteq;","\x22ED") + ,("Nu;","\x039D") + ,("nu;","\x03BD") + ,("num;","\x0023") + ,("numero;","\x2116") + ,("numsp;","\x2007") + ,("nvap;","\x224D\x20D2") + ,("nvdash;","\x22AC") + ,("nvDash;","\x22AD") + ,("nVdash;","\x22AE") + ,("nVDash;","\x22AF") + ,("nvge;","\x2265\x20D2") + ,("nvgt;","\x003E\x20D2") + ,("nvHarr;","\x2904") + ,("nvinfin;","\x29DE") + ,("nvlArr;","\x2902") + ,("nvle;","\x2264\x20D2") + ,("nvlt;","\x003C\x20D2") + ,("nvltrie;","\x22B4\x20D2") + ,("nvrArr;","\x2903") + ,("nvrtrie;","\x22B5\x20D2") + ,("nvsim;","\x223C\x20D2") + ,("nwarhk;","\x2923") + ,("nwarr;","\x2196") + ,("nwArr;","\x21D6") + ,("nwarrow;","\x2196") + ,("nwnear;","\x2927") + ,("Oacute","\x00D3") + ,("oacute","\x00F3") + ,("Oacute;","\x00D3") + ,("oacute;","\x00F3") + ,("oast;","\x229B") + ,("ocir;","\x229A") + ,("Ocirc","\x00D4") + ,("ocirc","\x00F4") + ,("Ocirc;","\x00D4") + ,("ocirc;","\x00F4") + ,("Ocy;","\x041E") + ,("ocy;","\x043E") + ,("odash;","\x229D") + ,("Odblac;","\x0150") + ,("odblac;","\x0151") + ,("odiv;","\x2A38") + ,("odot;","\x2299") + ,("odsold;","\x29BC") + ,("OElig;","\x0152") + ,("oelig;","\x0153") + ,("ofcir;","\x29BF") + ,("Ofr;","\xD835\xDD12") + ,("ofr;","\xD835\xDD2C") + ,("ogon;","\x02DB") + ,("Ograve","\x00D2") + ,("ograve","\x00F2") + ,("Ograve;","\x00D2") + ,("ograve;","\x00F2") + ,("ogt;","\x29C1") + ,("ohbar;","\x29B5") + ,("ohm;","\x03A9") + ,("oint;","\x222E") + ,("olarr;","\x21BA") + ,("olcir;","\x29BE") + ,("olcross;","\x29BB") + ,("oline;","\x203E") + ,("olt;","\x29C0") + ,("Omacr;","\x014C") + ,("omacr;","\x014D") + ,("Omega;","\x03A9") + ,("omega;","\x03C9") + ,("Omicron;","\x039F") + ,("omicron;","\x03BF") + ,("omid;","\x29B6") + ,("ominus;","\x2296") + ,("Oopf;","\xD835\xDD46") + ,("oopf;","\xD835\xDD60") + ,("opar;","\x29B7") + ,("OpenCurlyDoubleQuote;","\x201C") + ,("OpenCurlyQuote;","\x2018") + ,("operp;","\x29B9") + ,("oplus;","\x2295") + ,("or;","\x2228") + ,("Or;","\x2A54") + ,("orarr;","\x21BB") + ,("ord;","\x2A5D") + ,("order;","\x2134") + ,("orderof;","\x2134") + ,("ordf","\x00AA") + ,("ordf;","\x00AA") + ,("ordm","\x00BA") + ,("ordm;","\x00BA") + ,("origof;","\x22B6") + ,("oror;","\x2A56") + ,("orslope;","\x2A57") + ,("orv;","\x2A5B") + ,("oS;","\x24C8") + ,("oscr;","\x2134") + ,("Oscr;","\xD835\xDCAA") + ,("Oslash","\x00D8") + ,("oslash","\x00F8") + ,("Oslash;","\x00D8") + ,("oslash;","\x00F8") + ,("osol;","\x2298") + ,("Otilde","\x00D5") + ,("otilde","\x00F5") + ,("Otilde;","\x00D5") + ,("otilde;","\x00F5") + ,("otimes;","\x2297") + ,("Otimes;","\x2A37") + ,("otimesas;","\x2A36") + ,("Ouml","\x00D6") + ,("ouml","\x00F6") + ,("Ouml;","\x00D6") + ,("ouml;","\x00F6") + ,("ovbar;","\x233D") + ,("OverBar;","\x203E") + ,("OverBrace;","\x23DE") + ,("OverBracket;","\x23B4") + ,("OverParenthesis;","\x23DC") + ,("par;","\x2225") + ,("para","\x00B6") + ,("para;","\x00B6") + ,("parallel;","\x2225") + ,("parsim;","\x2AF3") + ,("parsl;","\x2AFD") + ,("part;","\x2202") + ,("PartialD;","\x2202") + ,("Pcy;","\x041F") + ,("pcy;","\x043F") + ,("percnt;","\x0025") + ,("period;","\x002E") + ,("permil;","\x2030") + ,("perp;","\x22A5") + ,("pertenk;","\x2031") + ,("Pfr;","\xD835\xDD13") + ,("pfr;","\xD835\xDD2D") + ,("Phi;","\x03A6") + ,("phi;","\x03C6") + ,("phiv;","\x03D5") + ,("phmmat;","\x2133") + ,("phone;","\x260E") + ,("Pi;","\x03A0") + ,("pi;","\x03C0") + ,("pitchfork;","\x22D4") + ,("piv;","\x03D6") + ,("planck;","\x210F") + ,("planckh;","\x210E") + ,("plankv;","\x210F") + ,("plus;","\x002B") + ,("plusacir;","\x2A23") + ,("plusb;","\x229E") + ,("pluscir;","\x2A22") + ,("plusdo;","\x2214") + ,("plusdu;","\x2A25") + ,("pluse;","\x2A72") + ,("PlusMinus;","\x00B1") + ,("plusmn","\x00B1") + ,("plusmn;","\x00B1") + ,("plussim;","\x2A26") + ,("plustwo;","\x2A27") + ,("pm;","\x00B1") + ,("Poincareplane;","\x210C") + ,("pointint;","\x2A15") + ,("Popf;","\x2119") + ,("popf;","\xD835\xDD61") + ,("pound","\x00A3") + ,("pound;","\x00A3") + ,("pr;","\x227A") + ,("Pr;","\x2ABB") + ,("prap;","\x2AB7") + ,("prcue;","\x227C") + ,("pre;","\x2AAF") + ,("prE;","\x2AB3") + ,("prec;","\x227A") + ,("precapprox;","\x2AB7") + ,("preccurlyeq;","\x227C") + ,("Precedes;","\x227A") + ,("PrecedesEqual;","\x2AAF") + ,("PrecedesSlantEqual;","\x227C") + ,("PrecedesTilde;","\x227E") + ,("preceq;","\x2AAF") + ,("precnapprox;","\x2AB9") + ,("precneqq;","\x2AB5") + ,("precnsim;","\x22E8") + ,("precsim;","\x227E") + ,("prime;","\x2032") + ,("Prime;","\x2033") + ,("primes;","\x2119") + ,("prnap;","\x2AB9") + ,("prnE;","\x2AB5") + ,("prnsim;","\x22E8") + ,("prod;","\x220F") + ,("Product;","\x220F") + ,("profalar;","\x232E") + ,("profline;","\x2312") + ,("profsurf;","\x2313") + ,("prop;","\x221D") + ,("Proportion;","\x2237") + ,("Proportional;","\x221D") + ,("propto;","\x221D") + ,("prsim;","\x227E") + ,("prurel;","\x22B0") + ,("Pscr;","\xD835\xDCAB") + ,("pscr;","\xD835\xDCC5") + ,("Psi;","\x03A8") + ,("psi;","\x03C8") + ,("puncsp;","\x2008") + ,("Qfr;","\xD835\xDD14") + ,("qfr;","\xD835\xDD2E") + ,("qint;","\x2A0C") + ,("Qopf;","\x211A") + ,("qopf;","\xD835\xDD62") + ,("qprime;","\x2057") + ,("Qscr;","\xD835\xDCAC") + ,("qscr;","\xD835\xDCC6") + ,("quaternions;","\x210D") + ,("quatint;","\x2A16") + ,("quest;","\x003F") + ,("questeq;","\x225F") + ,("QUOT","\x0022") + ,("quot","\x0022") + ,("QUOT;","\x0022") + ,("quot;","\x0022") + ,("rAarr;","\x21DB") + ,("race;","\x223D\x0331") + ,("Racute;","\x0154") + ,("racute;","\x0155") + ,("radic;","\x221A") + ,("raemptyv;","\x29B3") + ,("rang;","\x27E9") + ,("Rang;","\x27EB") + ,("rangd;","\x2992") + ,("range;","\x29A5") + ,("rangle;","\x27E9") + ,("raquo","\x00BB") + ,("raquo;","\x00BB") + ,("rarr;","\x2192") + ,("Rarr;","\x21A0") + ,("rArr;","\x21D2") + ,("rarrap;","\x2975") + ,("rarrb;","\x21E5") + ,("rarrbfs;","\x2920") + ,("rarrc;","\x2933") + ,("rarrfs;","\x291E") + ,("rarrhk;","\x21AA") + ,("rarrlp;","\x21AC") + ,("rarrpl;","\x2945") + ,("rarrsim;","\x2974") + ,("rarrtl;","\x21A3") + ,("Rarrtl;","\x2916") + ,("rarrw;","\x219D") + ,("ratail;","\x291A") + ,("rAtail;","\x291C") + ,("ratio;","\x2236") + ,("rationals;","\x211A") + ,("rbarr;","\x290D") + ,("rBarr;","\x290F") + ,("RBarr;","\x2910") + ,("rbbrk;","\x2773") + ,("rbrace;","\x007D") + ,("rbrack;","\x005D") + ,("rbrke;","\x298C") + ,("rbrksld;","\x298E") + ,("rbrkslu;","\x2990") + ,("Rcaron;","\x0158") + ,("rcaron;","\x0159") + ,("Rcedil;","\x0156") + ,("rcedil;","\x0157") + ,("rceil;","\x2309") + ,("rcub;","\x007D") + ,("Rcy;","\x0420") + ,("rcy;","\x0440") + ,("rdca;","\x2937") + ,("rdldhar;","\x2969") + ,("rdquo;","\x201D") + ,("rdquor;","\x201D") + ,("rdsh;","\x21B3") + ,("Re;","\x211C") + ,("real;","\x211C") + ,("realine;","\x211B") + ,("realpart;","\x211C") + ,("reals;","\x211D") + ,("rect;","\x25AD") + ,("REG","\x00AE") + ,("reg","\x00AE") + ,("REG;","\x00AE") + ,("reg;","\x00AE") + ,("ReverseElement;","\x220B") + ,("ReverseEquilibrium;","\x21CB") + ,("ReverseUpEquilibrium;","\x296F") + ,("rfisht;","\x297D") + ,("rfloor;","\x230B") + ,("Rfr;","\x211C") + ,("rfr;","\xD835\xDD2F") + ,("rHar;","\x2964") + ,("rhard;","\x21C1") + ,("rharu;","\x21C0") + ,("rharul;","\x296C") + ,("Rho;","\x03A1") + ,("rho;","\x03C1") + ,("rhov;","\x03F1") + ,("RightAngleBracket;","\x27E9") + ,("RightArrow;","\x2192") + ,("rightarrow;","\x2192") + ,("Rightarrow;","\x21D2") + ,("RightArrowBar;","\x21E5") + ,("RightArrowLeftArrow;","\x21C4") + ,("rightarrowtail;","\x21A3") + ,("RightCeiling;","\x2309") + ,("RightDoubleBracket;","\x27E7") + ,("RightDownTeeVector;","\x295D") + ,("RightDownVector;","\x21C2") + ,("RightDownVectorBar;","\x2955") + ,("RightFloor;","\x230B") + ,("rightharpoondown;","\x21C1") + ,("rightharpoonup;","\x21C0") + ,("rightleftarrows;","\x21C4") + ,("rightleftharpoons;","\x21CC") + ,("rightrightarrows;","\x21C9") + ,("rightsquigarrow;","\x219D") + ,("RightTee;","\x22A2") + ,("RightTeeArrow;","\x21A6") + ,("RightTeeVector;","\x295B") + ,("rightthreetimes;","\x22CC") + ,("RightTriangle;","\x22B3") + ,("RightTriangleBar;","\x29D0") + ,("RightTriangleEqual;","\x22B5") + ,("RightUpDownVector;","\x294F") + ,("RightUpTeeVector;","\x295C") + ,("RightUpVector;","\x21BE") + ,("RightUpVectorBar;","\x2954") + ,("RightVector;","\x21C0") + ,("RightVectorBar;","\x2953") + ,("ring;","\x02DA") + ,("risingdotseq;","\x2253") + ,("rlarr;","\x21C4") + ,("rlhar;","\x21CC") + ,("rlm;","\x200F") + ,("rmoust;","\x23B1") + ,("rmoustache;","\x23B1") + ,("rnmid;","\x2AEE") + ,("roang;","\x27ED") + ,("roarr;","\x21FE") + ,("robrk;","\x27E7") + ,("ropar;","\x2986") + ,("Ropf;","\x211D") + ,("ropf;","\xD835\xDD63") + ,("roplus;","\x2A2E") + ,("rotimes;","\x2A35") + ,("RoundImplies;","\x2970") + ,("rpar;","\x0029") + ,("rpargt;","\x2994") + ,("rppolint;","\x2A12") + ,("rrarr;","\x21C9") + ,("Rrightarrow;","\x21DB") + ,("rsaquo;","\x203A") + ,("Rscr;","\x211B") + ,("rscr;","\xD835\xDCC7") + ,("Rsh;","\x21B1") + ,("rsh;","\x21B1") + ,("rsqb;","\x005D") + ,("rsquo;","\x2019") + ,("rsquor;","\x2019") + ,("rthree;","\x22CC") + ,("rtimes;","\x22CA") + ,("rtri;","\x25B9") + ,("rtrie;","\x22B5") + ,("rtrif;","\x25B8") + ,("rtriltri;","\x29CE") + ,("RuleDelayed;","\x29F4") + ,("ruluhar;","\x2968") + ,("rx;","\x211E") + ,("Sacute;","\x015A") + ,("sacute;","\x015B") + ,("sbquo;","\x201A") + ,("sc;","\x227B") + ,("Sc;","\x2ABC") + ,("scap;","\x2AB8") + ,("Scaron;","\x0160") + ,("scaron;","\x0161") + ,("sccue;","\x227D") + ,("sce;","\x2AB0") + ,("scE;","\x2AB4") + ,("Scedil;","\x015E") + ,("scedil;","\x015F") + ,("Scirc;","\x015C") + ,("scirc;","\x015D") + ,("scnap;","\x2ABA") + ,("scnE;","\x2AB6") + ,("scnsim;","\x22E9") + ,("scpolint;","\x2A13") + ,("scsim;","\x227F") + ,("Scy;","\x0421") + ,("scy;","\x0441") + ,("sdot;","\x22C5") + ,("sdotb;","\x22A1") + ,("sdote;","\x2A66") + ,("searhk;","\x2925") + ,("searr;","\x2198") + ,("seArr;","\x21D8") + ,("searrow;","\x2198") + ,("sect","\x00A7") + ,("sect;","\x00A7") + ,("semi;","\x003B") + ,("seswar;","\x2929") + ,("setminus;","\x2216") + ,("setmn;","\x2216") + ,("sext;","\x2736") + ,("Sfr;","\xD835\xDD16") + ,("sfr;","\xD835\xDD30") + ,("sfrown;","\x2322") + ,("sharp;","\x266F") + ,("SHCHcy;","\x0429") + ,("shchcy;","\x0449") + ,("SHcy;","\x0428") + ,("shcy;","\x0448") + ,("ShortDownArrow;","\x2193") + ,("ShortLeftArrow;","\x2190") + ,("shortmid;","\x2223") + ,("shortparallel;","\x2225") + ,("ShortRightArrow;","\x2192") + ,("ShortUpArrow;","\x2191") + ,("shy","\x00AD") + ,("shy;","\x00AD") + ,("Sigma;","\x03A3") + ,("sigma;","\x03C3") + ,("sigmaf;","\x03C2") + ,("sigmav;","\x03C2") + ,("sim;","\x223C") + ,("simdot;","\x2A6A") + ,("sime;","\x2243") + ,("simeq;","\x2243") + ,("simg;","\x2A9E") + ,("simgE;","\x2AA0") + ,("siml;","\x2A9D") + ,("simlE;","\x2A9F") + ,("simne;","\x2246") + ,("simplus;","\x2A24") + ,("simrarr;","\x2972") + ,("slarr;","\x2190") + ,("SmallCircle;","\x2218") + ,("smallsetminus;","\x2216") + ,("smashp;","\x2A33") + ,("smeparsl;","\x29E4") + ,("smid;","\x2223") + ,("smile;","\x2323") + ,("smt;","\x2AAA") + ,("smte;","\x2AAC") + ,("smtes;","\x2AAC\xFE00") + ,("SOFTcy;","\x042C") + ,("softcy;","\x044C") + ,("sol;","\x002F") + ,("solb;","\x29C4") + ,("solbar;","\x233F") + ,("Sopf;","\xD835\xDD4A") + ,("sopf;","\xD835\xDD64") + ,("spades;","\x2660") + ,("spadesuit;","\x2660") + ,("spar;","\x2225") + ,("sqcap;","\x2293") + ,("sqcaps;","\x2293\xFE00") + ,("sqcup;","\x2294") + ,("sqcups;","\x2294\xFE00") + ,("Sqrt;","\x221A") + ,("sqsub;","\x228F") + ,("sqsube;","\x2291") + ,("sqsubset;","\x228F") + ,("sqsubseteq;","\x2291") + ,("sqsup;","\x2290") + ,("sqsupe;","\x2292") + ,("sqsupset;","\x2290") + ,("sqsupseteq;","\x2292") + ,("squ;","\x25A1") + ,("Square;","\x25A1") + ,("square;","\x25A1") + ,("SquareIntersection;","\x2293") + ,("SquareSubset;","\x228F") + ,("SquareSubsetEqual;","\x2291") + ,("SquareSuperset;","\x2290") + ,("SquareSupersetEqual;","\x2292") + ,("SquareUnion;","\x2294") + ,("squarf;","\x25AA") + ,("squf;","\x25AA") + ,("srarr;","\x2192") + ,("Sscr;","\xD835\xDCAE") + ,("sscr;","\xD835\xDCC8") + ,("ssetmn;","\x2216") + ,("ssmile;","\x2323") + ,("sstarf;","\x22C6") + ,("Star;","\x22C6") + ,("star;","\x2606") + ,("starf;","\x2605") + ,("straightepsilon;","\x03F5") + ,("straightphi;","\x03D5") + ,("strns;","\x00AF") + ,("sub;","\x2282") + ,("Sub;","\x22D0") + ,("subdot;","\x2ABD") + ,("sube;","\x2286") + ,("subE;","\x2AC5") + ,("subedot;","\x2AC3") + ,("submult;","\x2AC1") + ,("subne;","\x228A") + ,("subnE;","\x2ACB") + ,("subplus;","\x2ABF") + ,("subrarr;","\x2979") + ,("subset;","\x2282") + ,("Subset;","\x22D0") + ,("subseteq;","\x2286") + ,("subseteqq;","\x2AC5") + ,("SubsetEqual;","\x2286") + ,("subsetneq;","\x228A") + ,("subsetneqq;","\x2ACB") + ,("subsim;","\x2AC7") + ,("subsub;","\x2AD5") + ,("subsup;","\x2AD3") + ,("succ;","\x227B") + ,("succapprox;","\x2AB8") + ,("succcurlyeq;","\x227D") + ,("Succeeds;","\x227B") + ,("SucceedsEqual;","\x2AB0") + ,("SucceedsSlantEqual;","\x227D") + ,("SucceedsTilde;","\x227F") + ,("succeq;","\x2AB0") + ,("succnapprox;","\x2ABA") + ,("succneqq;","\x2AB6") + ,("succnsim;","\x22E9") + ,("succsim;","\x227F") + ,("SuchThat;","\x220B") + ,("Sum;","\x2211") + ,("sum;","\x2211") + ,("sung;","\x266A") + ,("sup1","\x00B9") + ,("sup1;","\x00B9") + ,("sup2","\x00B2") + ,("sup2;","\x00B2") + ,("sup3","\x00B3") + ,("sup3;","\x00B3") + ,("sup;","\x2283") + ,("Sup;","\x22D1") + ,("supdot;","\x2ABE") + ,("supdsub;","\x2AD8") + ,("supe;","\x2287") + ,("supE;","\x2AC6") + ,("supedot;","\x2AC4") + ,("Superset;","\x2283") + ,("SupersetEqual;","\x2287") + ,("suphsol;","\x27C9") + ,("suphsub;","\x2AD7") + ,("suplarr;","\x297B") + ,("supmult;","\x2AC2") + ,("supne;","\x228B") + ,("supnE;","\x2ACC") + ,("supplus;","\x2AC0") + ,("supset;","\x2283") + ,("Supset;","\x22D1") + ,("supseteq;","\x2287") + ,("supseteqq;","\x2AC6") + ,("supsetneq;","\x228B") + ,("supsetneqq;","\x2ACC") + ,("supsim;","\x2AC8") + ,("supsub;","\x2AD4") + ,("supsup;","\x2AD6") + ,("swarhk;","\x2926") + ,("swarr;","\x2199") + ,("swArr;","\x21D9") + ,("swarrow;","\x2199") + ,("swnwar;","\x292A") + ,("szlig","\x00DF") + ,("szlig;","\x00DF") + ,("Tab;","\x0009") + ,("target;","\x2316") + ,("Tau;","\x03A4") + ,("tau;","\x03C4") + ,("tbrk;","\x23B4") + ,("Tcaron;","\x0164") + ,("tcaron;","\x0165") + ,("Tcedil;","\x0162") + ,("tcedil;","\x0163") + ,("Tcy;","\x0422") + ,("tcy;","\x0442") + ,("tdot;","\x20DB") + ,("telrec;","\x2315") + ,("Tfr;","\xD835\xDD17") + ,("tfr;","\xD835\xDD31") + ,("there4;","\x2234") + ,("Therefore;","\x2234") + ,("therefore;","\x2234") + ,("Theta;","\x0398") + ,("theta;","\x03B8") + ,("thetasym;","\x03D1") + ,("thetav;","\x03D1") + ,("thickapprox;","\x2248") + ,("thicksim;","\x223C") + ,("ThickSpace;","\x205F\x200A") + ,("thinsp;","\x2009") + ,("ThinSpace;","\x2009") + ,("thkap;","\x2248") + ,("thksim;","\x223C") + ,("THORN","\x00DE") + ,("thorn","\x00FE") + ,("THORN;","\x00DE") + ,("thorn;","\x00FE") + ,("tilde;","\x02DC") + ,("Tilde;","\x223C") + ,("TildeEqual;","\x2243") + ,("TildeFullEqual;","\x2245") + ,("TildeTilde;","\x2248") + ,("times","\x00D7") + ,("times;","\x00D7") + ,("timesb;","\x22A0") + ,("timesbar;","\x2A31") + ,("timesd;","\x2A30") + ,("tint;","\x222D") + ,("toea;","\x2928") + ,("top;","\x22A4") + ,("topbot;","\x2336") + ,("topcir;","\x2AF1") + ,("Topf;","\xD835\xDD4B") + ,("topf;","\xD835\xDD65") + ,("topfork;","\x2ADA") + ,("tosa;","\x2929") + ,("tprime;","\x2034") + ,("TRADE;","\x2122") + ,("trade;","\x2122") + ,("triangle;","\x25B5") + ,("triangledown;","\x25BF") + ,("triangleleft;","\x25C3") + ,("trianglelefteq;","\x22B4") + ,("triangleq;","\x225C") + ,("triangleright;","\x25B9") + ,("trianglerighteq;","\x22B5") + ,("tridot;","\x25EC") + ,("trie;","\x225C") + ,("triminus;","\x2A3A") + ,("TripleDot;","\x20DB") + ,("triplus;","\x2A39") + ,("trisb;","\x29CD") + ,("tritime;","\x2A3B") + ,("trpezium;","\x23E2") + ,("Tscr;","\xD835\xDCAF") + ,("tscr;","\xD835\xDCC9") + ,("TScy;","\x0426") + ,("tscy;","\x0446") + ,("TSHcy;","\x040B") + ,("tshcy;","\x045B") + ,("Tstrok;","\x0166") + ,("tstrok;","\x0167") + ,("twixt;","\x226C") + ,("twoheadleftarrow;","\x219E") + ,("twoheadrightarrow;","\x21A0") + ,("Uacute","\x00DA") + ,("uacute","\x00FA") + ,("Uacute;","\x00DA") + ,("uacute;","\x00FA") + ,("uarr;","\x2191") + ,("Uarr;","\x219F") + ,("uArr;","\x21D1") + ,("Uarrocir;","\x2949") + ,("Ubrcy;","\x040E") + ,("ubrcy;","\x045E") + ,("Ubreve;","\x016C") + ,("ubreve;","\x016D") + ,("Ucirc","\x00DB") + ,("ucirc","\x00FB") + ,("Ucirc;","\x00DB") + ,("ucirc;","\x00FB") + ,("Ucy;","\x0423") + ,("ucy;","\x0443") + ,("udarr;","\x21C5") + ,("Udblac;","\x0170") + ,("udblac;","\x0171") + ,("udhar;","\x296E") + ,("ufisht;","\x297E") + ,("Ufr;","\xD835\xDD18") + ,("ufr;","\xD835\xDD32") + ,("Ugrave","\x00D9") + ,("ugrave","\x00F9") + ,("Ugrave;","\x00D9") + ,("ugrave;","\x00F9") + ,("uHar;","\x2963") + ,("uharl;","\x21BF") + ,("uharr;","\x21BE") + ,("uhblk;","\x2580") + ,("ulcorn;","\x231C") + ,("ulcorner;","\x231C") + ,("ulcrop;","\x230F") + ,("ultri;","\x25F8") + ,("Umacr;","\x016A") + ,("umacr;","\x016B") + ,("uml","\x00A8") + ,("uml;","\x00A8") + ,("UnderBar;","\x005F") + ,("UnderBrace;","\x23DF") + ,("UnderBracket;","\x23B5") + ,("UnderParenthesis;","\x23DD") + ,("Union;","\x22C3") + ,("UnionPlus;","\x228E") + ,("Uogon;","\x0172") + ,("uogon;","\x0173") + ,("Uopf;","\xD835\xDD4C") + ,("uopf;","\xD835\xDD66") + ,("UpArrow;","\x2191") + ,("uparrow;","\x2191") + ,("Uparrow;","\x21D1") + ,("UpArrowBar;","\x2912") + ,("UpArrowDownArrow;","\x21C5") + ,("UpDownArrow;","\x2195") + ,("updownarrow;","\x2195") + ,("Updownarrow;","\x21D5") + ,("UpEquilibrium;","\x296E") + ,("upharpoonleft;","\x21BF") + ,("upharpoonright;","\x21BE") + ,("uplus;","\x228E") + ,("UpperLeftArrow;","\x2196") + ,("UpperRightArrow;","\x2197") + ,("upsi;","\x03C5") + ,("Upsi;","\x03D2") + ,("upsih;","\x03D2") + ,("Upsilon;","\x03A5") + ,("upsilon;","\x03C5") + ,("UpTee;","\x22A5") + ,("UpTeeArrow;","\x21A5") + ,("upuparrows;","\x21C8") + ,("urcorn;","\x231D") + ,("urcorner;","\x231D") + ,("urcrop;","\x230E") + ,("Uring;","\x016E") + ,("uring;","\x016F") + ,("urtri;","\x25F9") + ,("Uscr;","\xD835\xDCB0") + ,("uscr;","\xD835\xDCCA") + ,("utdot;","\x22F0") + ,("Utilde;","\x0168") + ,("utilde;","\x0169") + ,("utri;","\x25B5") + ,("utrif;","\x25B4") + ,("uuarr;","\x21C8") + ,("Uuml","\x00DC") + ,("uuml","\x00FC") + ,("Uuml;","\x00DC") + ,("uuml;","\x00FC") + ,("uwangle;","\x29A7") + ,("vangrt;","\x299C") + ,("varepsilon;","\x03F5") + ,("varkappa;","\x03F0") + ,("varnothing;","\x2205") + ,("varphi;","\x03D5") + ,("varpi;","\x03D6") + ,("varpropto;","\x221D") + ,("varr;","\x2195") + ,("vArr;","\x21D5") + ,("varrho;","\x03F1") + ,("varsigma;","\x03C2") + ,("varsubsetneq;","\x228A\xFE00") + ,("varsubsetneqq;","\x2ACB\xFE00") + ,("varsupsetneq;","\x228B\xFE00") + ,("varsupsetneqq;","\x2ACC\xFE00") + ,("vartheta;","\x03D1") + ,("vartriangleleft;","\x22B2") + ,("vartriangleright;","\x22B3") + ,("vBar;","\x2AE8") + ,("Vbar;","\x2AEB") + ,("vBarv;","\x2AE9") + ,("Vcy;","\x0412") + ,("vcy;","\x0432") + ,("vdash;","\x22A2") + ,("vDash;","\x22A8") + ,("Vdash;","\x22A9") + ,("VDash;","\x22AB") + ,("Vdashl;","\x2AE6") + ,("vee;","\x2228") + ,("Vee;","\x22C1") + ,("veebar;","\x22BB") + ,("veeeq;","\x225A") + ,("vellip;","\x22EE") + ,("verbar;","\x007C") + ,("Verbar;","\x2016") + ,("vert;","\x007C") + ,("Vert;","\x2016") + ,("VerticalBar;","\x2223") + ,("VerticalLine;","\x007C") + ,("VerticalSeparator;","\x2758") + ,("VerticalTilde;","\x2240") + ,("VeryThinSpace;","\x200A") + ,("Vfr;","\xD835\xDD19") + ,("vfr;","\xD835\xDD33") + ,("vltri;","\x22B2") + ,("vnsub;","\x2282\x20D2") + ,("vnsup;","\x2283\x20D2") + ,("Vopf;","\xD835\xDD4D") + ,("vopf;","\xD835\xDD67") + ,("vprop;","\x221D") + ,("vrtri;","\x22B3") + ,("Vscr;","\xD835\xDCB1") + ,("vscr;","\xD835\xDCCB") + ,("vsubne;","\x228A\xFE00") + ,("vsubnE;","\x2ACB\xFE00") + ,("vsupne;","\x228B\xFE00") + ,("vsupnE;","\x2ACC\xFE00") + ,("Vvdash;","\x22AA") + ,("vzigzag;","\x299A") + ,("Wcirc;","\x0174") + ,("wcirc;","\x0175") + ,("wedbar;","\x2A5F") + ,("wedge;","\x2227") + ,("Wedge;","\x22C0") + ,("wedgeq;","\x2259") + ,("weierp;","\x2118") + ,("Wfr;","\xD835\xDD1A") + ,("wfr;","\xD835\xDD34") + ,("Wopf;","\xD835\xDD4E") + ,("wopf;","\xD835\xDD68") + ,("wp;","\x2118") + ,("wr;","\x2240") + ,("wreath;","\x2240") + ,("Wscr;","\xD835\xDCB2") + ,("wscr;","\xD835\xDCCC") + ,("xcap;","\x22C2") + ,("xcirc;","\x25EF") + ,("xcup;","\x22C3") + ,("xdtri;","\x25BD") + ,("Xfr;","\xD835\xDD1B") + ,("xfr;","\xD835\xDD35") + ,("xharr;","\x27F7") + ,("xhArr;","\x27FA") + ,("Xi;","\x039E") + ,("xi;","\x03BE") + ,("xlarr;","\x27F5") + ,("xlArr;","\x27F8") + ,("xmap;","\x27FC") + ,("xnis;","\x22FB") + ,("xodot;","\x2A00") + ,("Xopf;","\xD835\xDD4F") + ,("xopf;","\xD835\xDD69") + ,("xoplus;","\x2A01") + ,("xotime;","\x2A02") + ,("xrarr;","\x27F6") + ,("xrArr;","\x27F9") + ,("Xscr;","\xD835\xDCB3") + ,("xscr;","\xD835\xDCCD") + ,("xsqcup;","\x2A06") + ,("xuplus;","\x2A04") + ,("xutri;","\x25B3") + ,("xvee;","\x22C1") + ,("xwedge;","\x22C0") + ,("Yacute","\x00DD") + ,("yacute","\x00FD") + ,("Yacute;","\x00DD") + ,("yacute;","\x00FD") + ,("YAcy;","\x042F") + ,("yacy;","\x044F") + ,("Ycirc;","\x0176") + ,("ycirc;","\x0177") + ,("Ycy;","\x042B") + ,("ycy;","\x044B") + ,("yen","\x00A5") + ,("yen;","\x00A5") + ,("Yfr;","\xD835\xDD1C") + ,("yfr;","\xD835\xDD36") + ,("YIcy;","\x0407") + ,("yicy;","\x0457") + ,("Yopf;","\xD835\xDD50") + ,("yopf;","\xD835\xDD6A") + ,("Yscr;","\xD835\xDCB4") + ,("yscr;","\xD835\xDCCE") + ,("YUcy;","\x042E") + ,("yucy;","\x044E") + ,("yuml","\x00FF") + ,("yuml;","\x00FF") + ,("Yuml;","\x0178") + ,("Zacute;","\x0179") + ,("zacute;","\x017A") + ,("Zcaron;","\x017D") + ,("zcaron;","\x017E") + ,("Zcy;","\x0417") + ,("zcy;","\x0437") + ,("Zdot;","\x017B") + ,("zdot;","\x017C") + ,("zeetrf;","\x2128") + ,("ZeroWidthSpace;","\x200B") + ,("Zeta;","\x0396") + ,("zeta;","\x03B6") + ,("Zfr;","\x2128") + ,("zfr;","\xD835\xDD37") + ,("ZHcy;","\x0416") + ,("zhcy;","\x0436") + ,("zigrarr;","\x21DD") + ,("Zopf;","\x2124") + ,("zopf;","\xD835\xDD6B") + ,("Zscr;","\xD835\xDCB5") + ,("zscr;","\xD835\xDCCF") + ,("zwj;","\x200D") + ,("zwnj;","\x200C")] diff --git a/src/Zenacy/HTML/Internal/Filter.hs b/src/Zenacy/HTML/Internal/Filter.hs new file mode 100644 --- /dev/null +++ b/src/Zenacy/HTML/Internal/Filter.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Filters and transforms for HTML trees. +module Zenacy.HTML.Internal.Filter + ( htmlSpaceRemove + ) where + +import Zenacy.HTML.Internal.Core +import Zenacy.HTML.Internal.HTML +import Zenacy.HTML.Internal.Oper +import Data.Maybe + ( mapMaybe + ) + +-- | Removes whitespace and comments from an HTML structure. +-- Document elements are not accepted, and only non-empty text nodes +-- and element nodes are kept. @pre@, @code@, @samp@, and @kdb@ elements +-- are passed without modification, since whitespace is typically +-- significant in those elements. +htmlSpaceRemove :: HTMLNode -> Maybe HTMLNode +htmlSpaceRemove = go + where + go x = case x of + HTMLText {} + | htmlTextSpace x -> + Nothing + | otherwise -> + Just x + HTMLElement n s a c + | n == "pre" || n == "code" || n == "samp" || n == "kbd" -> + Just x + | otherwise -> + Just $ HTMLElement n s a $ mapMaybe go c + _otherwise -> + Nothing diff --git a/src/Zenacy/HTML/Internal/HTML.hs b/src/Zenacy/HTML/Internal/HTML.hs new file mode 100644 --- /dev/null +++ b/src/Zenacy/HTML/Internal/HTML.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Defines the top-level HTML types and parser functions. +module Zenacy.HTML.Internal.HTML + ( HTMLOptions(..) + , HTMLResult(..) + , HTMLError(..) + , HTMLNode(..) + , HTMLAttr(..) + , HTMLNamespace(..) + , HTMLAttrNamespace(..) + , htmlParse + , htmlParseEasy + , htmlFragment + , htmlDefaultDocument + , htmlDefaultDoctype + , htmlDefaultFragment + , htmlDefaultElement + , htmlDefaultTemplate + , htmlDefaultText + , htmlDefaultComment + , htmlAttr + , htmlElem + , htmlText + ) where + +import Zenacy.HTML.Internal.BS +import Zenacy.HTML.Internal.Core +import Zenacy.HTML.Internal.DOM +import Zenacy.HTML.Internal.Parser +import Zenacy.HTML.Internal.Types +import Data.Default + ( Default(..) + ) +import Data.Either + ( either + ) +import Data.Foldable + ( toList + ) +import Data.Maybe + ( fromJust + ) +import Data.Text + ( Text + ) +import qualified Data.Text as T + ( empty + ) +import qualified Data.Text.Encoding as T + ( encodeUtf8 + , decodeUtf8 + ) + +-- | Defines options for the HTML parser. +data HTMLOptions = HTMLOptions + { htmlOptionLogErrors :: !Bool + -- ^ Indicates that errors should be logged. + , htmlOptionIgnoreEntities :: !Bool + -- ^ Indicates that entities should not be decoded. + } deriving (Eq, Ord, Show) + +-- | Defines an HTML parser result. +data HTMLResult = HTMLResult + { htmlResultDocument :: !HTMLNode + -- ^ The parsed document structure. + , htmlResultErrors :: ![HTMLError] + -- ^ The errors logged while parsing if error logging was enabled. + } deriving (Eq, Ord, Show) + +-- | An HTML error type. +data HTMLError = HTMLError + { htmlErrorText :: !Text + -- ^ The error message. + } deriving (Show, Eq, Ord) + +-- | Defines the model type for an HTML document. +data HTMLNode + = HTMLDocument + { htmlDocumentName :: !Text -- ^ The document name. + , htmlDocumentChildren :: ![HTMLNode] -- ^ The document children. + } + | HTMLDoctype + { htmlDoctypeName :: !Text -- ^ The DOCTYPE name. + , htmlDoctypePublicID :: !(Maybe Text) -- ^ The public ID. + , htmlDoctypeSystemID :: !(Maybe Text) -- ^ The system ID. + } + | HTMLFragment + { htmlFragmentName :: !Text -- ^ The fragment name. + , htmlFragmentChildren :: ![HTMLNode] -- ^ The fragment children. + } + | HTMLElement + { htmlElementName :: !Text -- ^ The element name. + , htmlElementNamespace :: !HTMLNamespace -- ^ The element namespace. + , htmlElementAttributes :: ![HTMLAttr] -- ^ The element attributes. + , htmlElementChildren :: ![HTMLNode] -- ^ The element children. + } + | HTMLTemplate + { htmlTemplateNamespace :: !HTMLNamespace -- ^ The template namespace. + , htmlTemplateAttributes :: ![HTMLAttr] -- ^ The template attributes. + , htmlTemplateContents :: !HTMLNode -- ^ The template contents. + } + | HTMLText + { htmlTextData :: !Text -- ^ The text value. + } + | HTMLComment + { htmlCommentData :: !Text -- ^ The comment text. + } + deriving (Eq, Ord, Show) + +-- | An HTML element attribute type. +data HTMLAttr = HTMLAttr + { htmlAttrName :: Text + , htmlAttrVal :: Text + , htmlAttrNamespace :: HTMLAttrNamespace + } deriving (Eq, Ord, Show) + +-- | Defines default options. +instance Default HTMLOptions where + def = HTMLOptions + { htmlOptionLogErrors = False + , htmlOptionIgnoreEntities = False + } + +-- | Defines a default result. +instance Default HTMLResult where + def = HTMLResult + { htmlResultDocument = htmlDefaultDocument + , htmlResultErrors = [] + } + +-- | Defines a default error. +instance Default HTMLError where + def = HTMLError + { htmlErrorText = T.empty + } + +-- | Defines a default attribute. +instance Default HTMLAttr where + def = HTMLAttr + { htmlAttrName = T.empty + , htmlAttrVal = T.empty + , htmlAttrNamespace = HTMLAttrNamespaceNone + } + +-- | Parses an HTML document. +htmlParse :: HTMLOptions -> Text -> Either HTMLError HTMLResult +htmlParse HTMLOptions {..} x = + case d of + Right ParserResult {..} -> + Right def + { htmlResultDocument = domToHTML parserResultDOM + , htmlResultErrors = map f parserResultErrors + } + Left e -> + Left (f e) + where + d = parseDocument def + { parserOptionInput = T.encodeUtf8 x + , parserOptionLogErrors = htmlOptionLogErrors + , parserOptionIgnoreEntities = htmlOptionIgnoreEntities + } + f x = def { htmlErrorText = T.decodeUtf8 x } + +-- | Parses an HTML document the easy way. +htmlParseEasy :: Text -> HTMLNode +htmlParseEasy = + either (const htmlDefaultDocument) htmlResultDocument . htmlParse def + +-- | Parses an HTML fragment. +htmlFragment :: HTMLOptions -> Text -> Either HTMLError HTMLResult +htmlFragment HTMLOptions {..} x = Left def + { htmlErrorText = "fragment support not currently implemented" } + +-- | Defines a default document. +htmlDefaultDocument :: HTMLNode +htmlDefaultDocument = HTMLDocument + { htmlDocumentName = T.empty + , htmlDocumentChildren = [] + } + +-- | Defines a default document type. +htmlDefaultDoctype :: HTMLNode +htmlDefaultDoctype = HTMLDoctype + { htmlDoctypeName = T.empty + , htmlDoctypePublicID = Nothing + , htmlDoctypeSystemID = Nothing + } + +-- | Defines a default document fragment. +htmlDefaultFragment :: HTMLNode +htmlDefaultFragment = HTMLFragment + { htmlFragmentName = T.empty + , htmlFragmentChildren = [] + } + +-- | Defines a default element. +htmlDefaultElement :: HTMLNode +htmlDefaultElement = HTMLElement + { htmlElementName = T.empty + , htmlElementNamespace = HTMLNamespaceHTML + , htmlElementAttributes = [] + , htmlElementChildren = [] + } + +-- | Defines a default template. +htmlDefaultTemplate :: HTMLNode +htmlDefaultTemplate = HTMLTemplate + { htmlTemplateNamespace = HTMLNamespaceHTML + , htmlTemplateAttributes = [] + , htmlTemplateContents = htmlDefaultFragment + } + +-- | Defines a default text. +htmlDefaultText :: HTMLNode +htmlDefaultText = HTMLText + { htmlTextData = T.empty + } + +-- | Defines a default comment. +htmlDefaultComment :: HTMLNode +htmlDefaultComment = HTMLComment + { htmlCommentData = T.empty + } + +-- | Makes an attribute. +htmlAttr :: Text -> Text -> HTMLAttr +htmlAttr n v = HTMLAttr n v HTMLAttrNamespaceNone + +-- | Makes an element. +htmlElem :: Text -> [HTMLAttr] -> [HTMLNode] -> HTMLNode +htmlElem n a c = HTMLElement n HTMLNamespaceHTML a c + +-- | Makes a text node. +htmlText :: Text -> HTMLNode +htmlText = HTMLText + +-- | Converts a DOM document to an HTML document. +domToHTML :: DOM -> HTMLNode +domToHTML d = nodeToHTML d $ domDocument d + +-- | Converts a DOM node to an HTML node. +nodeToHTML :: DOM -> DOMNode -> HTMLNode +nodeToHTML d = go where + go DOMDocument {..} = HTMLDocument + { htmlDocumentName = t domDocumentName + , htmlDocumentChildren = f domDocumentChildren + } + go DOMDoctype {..} = HTMLDoctype + { htmlDoctypeName = t domDoctypeName + , htmlDoctypePublicID = t <$> domDoctypePublicID + , htmlDoctypeSystemID = t <$> domDoctypeSystemID + } + go DOMFragment {..} = HTMLFragment + { htmlFragmentName = t domFragmentName + , htmlFragmentChildren = f domFragmentChildren + } + go DOMElement {..} = HTMLElement + { htmlElementName = t domElementName + , htmlElementNamespace = domElementNamespace + , htmlElementAttributes = h domElementAttributes + , htmlElementChildren = f domElementChildren + } + go DOMTemplate {..} = HTMLTemplate + { htmlTemplateNamespace = domTemplateNamespace + , htmlTemplateAttributes = h domTemplateAttributes + , htmlTemplateContents = g domTemplateContents + } + go DOMText {..} = HTMLText + { htmlTextData = t domTextData + } + go DOMComment {..} = HTMLComment + { htmlCommentData = t domCommentData + } + f = map go . domMapID d . toList + g = go . fromJust . domGetNode d + h = map attr . toList + t = T.decodeUtf8 + attr (DOMAttr n v s) = HTMLAttr (t n) (t v) s diff --git a/src/Zenacy/HTML/Internal/Image.hs b/src/Zenacy/HTML/Internal/Image.hs new file mode 100644 --- /dev/null +++ b/src/Zenacy/HTML/Internal/Image.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Defines html image handling functions. +module Zenacy.HTML.Internal.Image + ( HTMLSrcset(..) + , HTMLSrcsetCandidate(..) + , HTMLSrcsetDescriptor(..) + , htmlSrcsetParse + , htmlSrcsetParseCandidate + , htmlSrcsetParseDescriptor + , htmlSrcsetRender + , htmlSrcsetRenderCandidate + , htmlSrcsetRenderDescriptor + , htmlSrcsetListURL + , htmlSrcsetMapURL + , htmlSrcsetImageMin + , htmlSrcsetImageMax + , htmlSrcsetDescriptorSize + , htmlSrcsetCandidatePair + , htmlSrcsetFilter + ) where + +import Zenacy.HTML.Internal.Core +import Control.Applicative + ( (<|>) + ) +import qualified Data.IntMap as IntMap + ( findMax + , findMin + , fromList + ) +import Data.Maybe + ( catMaybes + , fromJust + ) +import Data.Monoid + ( (<>) + ) +import Data.Text + ( Text + ) +import qualified Data.Text as T + ( empty + , intercalate + , null + , pack + , splitOn + , stripSuffix + , words + , unwords + ) + +-- | Defines a srcset attribute value. +data HTMLSrcset = HTMLSrcset + { htmlSrcsetCandidates :: ![HTMLSrcsetCandidate] + } deriving (Show, Eq, Ord) + +-- | Defines the image candidates. +data HTMLSrcsetCandidate = HTMLSrcsetCandidate + { htmlSrcsetURL :: !Text + , htmlSrcsetDescriptor :: !HTMLSrcsetDescriptor + } deriving (Show, Eq, Ord) + +-- | Defines the srcset descriptor. +data HTMLSrcsetDescriptor + = HTMLSrcsetWidth Int + | HTMLSrcsetPixel Int + | HTMLSrcsetNone + deriving (Show, Eq, Ord) + +-- | Parses a srcset attribute value. +htmlSrcsetParse :: Text -> HTMLSrcset +htmlSrcsetParse = + ( HTMLSrcset + . catMaybes + . map htmlSrcsetParseCandidate + . T.splitOn "," + ) + +-- | Parses a srcset candidate value. +htmlSrcsetParseCandidate :: Text -> Maybe HTMLSrcsetCandidate +htmlSrcsetParseCandidate x = + case T.words x of + (u:d:[]) -> Just $ HTMLSrcsetCandidate u $ htmlSrcsetParseDescriptor d + (u:[]) -> Just $ HTMLSrcsetCandidate u HTMLSrcsetNone + _otherwise -> Nothing + +-- | Parses a srcset descriptor value. +htmlSrcsetParseDescriptor :: Text -> HTMLSrcsetDescriptor +htmlSrcsetParseDescriptor x = fromJust $ + (HTMLSrcsetWidth <$> f "w") + <|> (HTMLSrcsetPixel <$> f "x") + <|> (Just HTMLSrcsetNone) + where + f s = T.stripSuffix s x >>= textReadDec + +-- | Renders a srcset. +htmlSrcsetRender :: HTMLSrcset -> Text +htmlSrcsetRender = + ( T.intercalate "," + . map htmlSrcsetRenderCandidate + . htmlSrcsetCandidates + ) + +-- | Renders a srcset candidate. +htmlSrcsetRenderCandidate :: HTMLSrcsetCandidate -> Text +htmlSrcsetRenderCandidate (HTMLSrcsetCandidate u d) = + T.unwords . filter (not . T.null) $ [ u, htmlSrcsetRenderDescriptor d ] + +-- | Renders a srcset descriptor. +htmlSrcsetRenderDescriptor :: HTMLSrcsetDescriptor -> Text +htmlSrcsetRenderDescriptor = \case + HTMLSrcsetWidth x -> T.pack $ show x <> "w" + HTMLSrcsetPixel x -> T.pack $ show x <> "x" + HTMLSrcsetNone -> T.empty + +-- | Returns the URLs for a srcset. +htmlSrcsetListURL :: HTMLSrcset -> [Text] +htmlSrcsetListURL (HTMLSrcset c) = + filter (not . T.null) $ map htmlSrcsetURL c + +-- | Maps a function over the srcset URLs. +htmlSrcsetMapURL :: (Text -> Text) -> HTMLSrcset -> HTMLSrcset +htmlSrcsetMapURL f (HTMLSrcset c) = HTMLSrcset $ map g c + where + g (HTMLSrcsetCandidate u d) = HTMLSrcsetCandidate (f u) d + +-- | Returns the smallest image in the srcset. +htmlSrcsetImageMin :: HTMLSrcset -> Text +htmlSrcsetImageMin (HTMLSrcset c) = + ( snd + . IntMap.findMin + . IntMap.fromList + . map htmlSrcsetCandidatePair + ) c + +-- | Returns the largest image in the srcset. +htmlSrcsetImageMax :: HTMLSrcset -> Text +htmlSrcsetImageMax (HTMLSrcset c) = + ( snd + . IntMap.findMax + . IntMap.fromList + . map htmlSrcsetCandidatePair + ) c + +-- | Gets the size of the descriptor. +htmlSrcsetDescriptorSize :: HTMLSrcsetDescriptor -> Int +htmlSrcsetDescriptorSize = \case + HTMLSrcsetWidth x -> x + HTMLSrcsetPixel x -> x + HTMLSrcsetNone -> 1 + +-- | Converts a candidate to a pair. +htmlSrcsetCandidatePair :: HTMLSrcsetCandidate -> (Int, Text) +htmlSrcsetCandidatePair (HTMLSrcsetCandidate u d) = + (htmlSrcsetDescriptorSize d, u) + +-- | Filter candidates from a srcset. +htmlSrcsetFilter :: (HTMLSrcsetCandidate -> Bool) -> HTMLSrcset -> HTMLSrcset +htmlSrcsetFilter f (HTMLSrcset c) = HTMLSrcset $ filter f c diff --git a/src/Zenacy/HTML/Internal/Lexer.hs b/src/Zenacy/HTML/Internal/Lexer.hs new file mode 100644 --- /dev/null +++ b/src/Zenacy/HTML/Internal/Lexer.hs @@ -0,0 +1,2315 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | The HTML Lexer. +module Zenacy.HTML.Internal.Lexer + ( Lexer(..) + , LexerOptions(..) + , LexerSkip(..) + , lexerNew + , lexerSetRCDATA + , lexerSetRAWTEXT + , lexerSetPLAINTEXT + , lexerSetScriptData + , lexerSkipNextLF + , lexerNext + ) where + +import Zenacy.HTML.Internal.BS +import Zenacy.HTML.Internal.Buffer +import Zenacy.HTML.Internal.Char +import Zenacy.HTML.Internal.Core +import Zenacy.HTML.Internal.Entity +import Zenacy.HTML.Internal.Token +import Control.Monad + ( forM + , forM_ + , mapM + , when + ) +import Control.Monad.Extra + ( whenM + , whenJust + ) +import Control.Monad.ST + ( ST + ) +import Data.STRef + ( STRef + , newSTRef + ) +import Data.DList + ( DList + ) +import qualified Data.DList as D + ( empty + , snoc + , toList + ) +import Data.Map + ( Map + ) +import qualified Data.Map as Map + ( fromList + , lookup + ) +import Data.Maybe + ( isJust + ) +import Data.Word + ( Word8 + ) +import Data.Default + ( Default(..) + ) +import Data.Vector.Storable.Mutable + ( MVector(..) + ) +import qualified Data.Vector.Storable.Mutable as U + ( new + , length + , read + , write + , grow + ) + +import Debug.Trace (trace) + + +-- | Lexer options type. +data LexerOptions = LexerOptions + { lexerOptionInput :: BS + -- ^ The input to the lexer. + , lexerOptionLogErrors :: Bool + -- ^ Indicates whether errors are logged. + , lexerOptionIgnoreEntities :: Bool + -- ^ Indicates that entities should not be tokenized. + } deriving (Show) + +-- | Defines the skip mode. +data LexerSkip + = LexerSkipNone + | LexerSkipLF + deriving (Eq, Ord, Show) + +-- | Defines the lexer state. +data Lexer s = Lexer + { lexerData :: BS + -- ^ The lexer data. + , lexerIgnore :: Bool + -- ^ Flag to ignore entity processing. + , lexerLog :: Bool + -- ^ Flag to log errors. + , lexerOffset :: STRef s Int + -- ^ The offset in the data for the next word to read. + , lexerToken :: STRef s (TokenBuffer s) + -- ^ The token buffer. + , lexerBuffer :: STRef s (Buffer s) + -- ^ The buffer is used to accumulate characters during + -- some types of character processing. + , lexerLast :: STRef s [Word8] + -- ^ The last start tag name to have been emitted. + , lexerState :: STRef s LexerState + -- ^ The current lexer state in some cases. + , lexerReturn :: STRef s LexerState + -- ^ The state to return to after character reference processing. + , lexerSkip :: STRef s LexerSkip + -- ^ The skip next linefeed flag. + , lexerErrors :: STRef s (DList BS) + -- ^ The lexer errors. + , lexerCode :: STRef s Int + -- ^ The character reference code. + } + +-- | Default instance for lexer options. +instance Default LexerOptions where + def = LexerOptions + { lexerOptionInput = bsEmpty + , lexerOptionLogErrors = False + , lexerOptionIgnoreEntities = False + } + +-- | Defines the lexer state. +data LexerState + = StateData + | StateRCDATA + | StateRAWTEXT + | StateScriptData + | StatePLAINTEXT + | StateTagOpen + | StateEndTagOpen + | StateTagName + | StateRCDATALessThan + | StateRCDATAEndTagOpen + | StateRCDATAEndTagName + | StateRAWTEXTLessThan + | StateRAWTEXTEndTagOpen + | StateRAWTEXTEndTagName + | StateScriptDataLessThan + | StateScriptDataEndTagOpen + | StateScriptDataEndTagName + | StateScriptDataEscapeStart + | StateScriptDataEscapeStartDash + | StateScriptDataEscaped + | StateScriptDataEscapedDash + | StateScriptDataEscapedDashDash + | StateScriptDataEscapedLessThan + | StateScriptDataEscapedEndTagOpen + | StateScriptDataEscapedEndTagName + | StateScriptDataDoubleEscapedStart + | StateScriptDataDoubleEscaped + | StateScriptDataDoubleEscapedDash + | StateScriptDataDoubleEscapedDashDash + | StateScriptDataDoubleEscapedLessThan + | StateScriptDataDoubleEscapeEnd + | StateBeforeAttrName + | StateAttrName + | StateAfterAttrName + | StateBeforeAttrValue + | StateAttrValueDoubleQuoted + | StateAttrValueSingleQuoted + | StateAttrValueUnquoted + | StateAfterAttrValue + | StateSelfClosingStartTag + | StateBogusComment + | StateMarkupDeclarationOpen + | StateCommentStart + | StateCommentStartDash + | StateComment + | StateCommentLessThan + | StateCommentLessThanBang + | StateCommentLessThanBangDash + | StateCommentLessThanBangDashDash + | StateCommentEndDash + | StateCommentEnd + | StateCommentEndBang + | StateDoctype + | StateBeforeDoctypeName + | StateDoctypeName + | StateAfterDoctypeName + | StateAfterDoctypePublicKeyword + | StateBeforeDoctypePublicId + | StateDoctypePublicIdDoubleQuoted + | StateDoctypePublicIdSingleQuoted + | StateAfterDoctypePublicId + | StateBetweenDoctypePublicAndSystem + | StateAfterDoctypeSystemKeyword + | StateBeforeDoctypeSystemId + | StateDoctypeSystemIdDoubleQuoted + | StateDoctypeSystemIdSingleQuoted + | StateAfterDoctypeSystemId + | StateBogusDoctype + | StateCDATASection + | StateCDATASectionBracket + | StateCDATASectionEnd + | StateCharacterReference + | StateNamedCharacterReference + | StateAmbiguousAmpersand + | StateNumericCharacterReference + | StateHexCharacterReferenceStart + | StateDecimalCharacterReferenceStart + | StateHexCharacterReference + | StateDecimalCharacterReference + | StateNumericCharacterReferenceEnd + deriving (Show, Eq, Ord) + +lexerDispatch :: LexerState -> Lexer s -> ST s () +lexerDispatch = \case + StateData -> + doData + StateRCDATA -> + doRCDATA + StateRAWTEXT -> + doRAWTEXT + StateScriptData -> + doScriptData + StatePLAINTEXT -> + doPLAINTEXT + StateTagOpen -> + doTagOpen + StateEndTagOpen -> + doEndTagOpen + StateTagName -> + doTagName + StateRCDATALessThan -> + doRCDATALessThan + StateRCDATAEndTagOpen -> + doRCDATAEndTagOpen + StateRCDATAEndTagName -> + doRCDATAEndTagName + StateRAWTEXTLessThan -> + doRAWTEXTLessThan + StateRAWTEXTEndTagOpen -> + doRAWTEXTEndTagOpen + StateRAWTEXTEndTagName -> + doRAWTEXTEndTagName + StateScriptDataLessThan -> + doScriptDataLessThan + StateScriptDataEndTagOpen -> + doScriptDataEndTagOpen + StateScriptDataEndTagName -> + doScriptDataEndTagName + StateScriptDataEscapeStart -> + doScriptDataEscapeStart + StateScriptDataEscapeStartDash -> + doScriptDataEscapeStartDash + StateScriptDataEscaped -> + doScriptDataEscaped + StateScriptDataEscapedDash -> + doScriptDataEscapedDash + StateScriptDataEscapedDashDash -> + doScriptDataEscapedDashDash + StateScriptDataEscapedLessThan -> + doScriptDataEscapedLessThan + StateScriptDataEscapedEndTagOpen -> + doScriptDataEscapedEndTagOpen + StateScriptDataEscapedEndTagName -> + doScriptDataEscapedEndTagName + StateScriptDataDoubleEscapedStart -> + doScriptDataDoubleEscapedStart + StateScriptDataDoubleEscaped -> + doScriptDataDoubleEscaped + StateScriptDataDoubleEscapedDash -> + doScriptDataDoubleEscapedDash + StateScriptDataDoubleEscapedDashDash -> + doScriptDataDoubleEscapedDashDash + StateScriptDataDoubleEscapedLessThan -> + doScriptDataDoubleEscapedLessThan + StateScriptDataDoubleEscapeEnd -> + doScriptDataDoubleEscapeEnd + StateBeforeAttrName -> + doBeforeAttrName + StateAttrName -> + doAttrName + StateAfterAttrName -> + doAfterAttrName + StateBeforeAttrValue -> + doBeforeAttrValue + StateAttrValueDoubleQuoted -> + doAttrValueDoubleQuoted + StateAttrValueSingleQuoted -> + doAttrValueSingleQuoted + StateAttrValueUnquoted -> + doAttrValueUnquoted + StateAfterAttrValue -> + doAfterAttrValue + StateSelfClosingStartTag -> + doSelfClosingStartTag + StateBogusComment -> + doBogusComment + StateMarkupDeclarationOpen -> + doMarkupDeclarationOpen + StateCommentStart -> + doCommentStart + StateCommentStartDash -> + doCommentStartDash + StateComment -> + doComment + StateCommentLessThan -> + doCommentLessThan + StateCommentLessThanBang -> + doCommentLessThanBang + StateCommentLessThanBangDash -> + doCommentLessThanBangDash + StateCommentLessThanBangDashDash -> + doCommentLessThanBangDashDash + StateCommentEndDash -> + doCommentEndDash + StateCommentEnd -> + doCommentEnd + StateCommentEndBang -> + doCommentEndBang + StateDoctype -> + doDoctype + StateBeforeDoctypeName -> + doBeforeDoctypeName + StateDoctypeName -> + doDoctypeName + StateAfterDoctypeName -> + doAfterDoctypeName + StateAfterDoctypePublicKeyword -> + doAfterDoctypePublicKeyword + StateBeforeDoctypePublicId -> + doBeforeDoctypePublicId + StateDoctypePublicIdDoubleQuoted -> + doDoctypePublicIdDoubleQuoted + StateDoctypePublicIdSingleQuoted -> + doDoctypePublicIdSingleQuoted + StateAfterDoctypePublicId -> + doAfterDoctypePublicId + StateBetweenDoctypePublicAndSystem -> + doBetweenDoctypePublicAndSystem + StateAfterDoctypeSystemKeyword -> + doAfterDoctypeSystemKeyword + StateBeforeDoctypeSystemId -> + doBeforeDoctypeSystemId + StateDoctypeSystemIdDoubleQuoted -> + doDoctypeSystemIdDoubleQuoted + StateDoctypeSystemIdSingleQuoted -> + doDoctypeSystemIdSingleQuoted + StateAfterDoctypeSystemId -> + doAfterDoctypeSystemId + StateBogusDoctype -> + doBogusDoctype + StateCDATASection -> + doCDATASection + StateCDATASectionBracket -> + doCDATASectionBracket + StateCDATASectionEnd -> + doCDATASectionEnd + StateCharacterReference -> + doCharacterReference + StateNamedCharacterReference -> + doNamedCharacterReference + StateAmbiguousAmpersand -> + doAmbiguousAmpersand + StateNumericCharacterReference -> + doNumericCharacterReference + StateHexCharacterReferenceStart -> + doHexCharacterReferenceStart + StateDecimalCharacterReferenceStart -> + doDecimalCharacterReferenceStart + StateHexCharacterReference -> + doHexCharacterReference + StateDecimalCharacterReference -> + doDecimalCharacterReference + StateNumericCharacterReferenceEnd -> + doNumericCharacterReferenceEnd + +-- | Makes a new lexer. +lexerNew :: LexerOptions -> ST s (Either BS (Lexer s)) +lexerNew o@LexerOptions{..} + | Just i <- bsElemIndex 0 lexerOptionInput = + pure $ Left $ bsConcat [ "input contains null at ", bcPack $ show i ] + | otherwise = + Right <$> lexerMake o + +-- | Makes a new lexer. +lexerMake :: LexerOptions -> ST s (Lexer s) +lexerMake LexerOptions{..} = do + offset <- newSTRef 0 + state <- newSTRef StateData + ret <- newSTRef StateData + token <- tokenBuffer + buffer <- bufferNew + last <- newSTRef [] + skip <- newSTRef LexerSkipNone + errors <- newSTRef D.empty + code <- newSTRef 0 + pure $ Lexer + { lexerData = lexerOptionInput + , lexerIgnore = lexerOptionIgnoreEntities + , lexerLog = lexerOptionLogErrors + , lexerOffset = offset + , lexerToken = token + , lexerBuffer = buffer + , lexerLast = last + , lexerState = state + , lexerReturn = ret + , lexerSkip = skip + , lexerErrors = errors + , lexerCode = code + } + +-- | Sets the RCDATA mode. +lexerSetRCDATA :: Lexer s -> ST s () +lexerSetRCDATA Lexer{..} = wref lexerState StateRCDATA + +-- | Sets the raw text mode. +lexerSetRAWTEXT :: Lexer s -> ST s () +lexerSetRAWTEXT Lexer{..} = wref lexerState StateRAWTEXT + +-- | Sets the plain text mode. +lexerSetPLAINTEXT :: Lexer s -> ST s () +lexerSetPLAINTEXT Lexer{..} = wref lexerState StatePLAINTEXT + +-- | Sets the script data mode. +lexerSetScriptData :: Lexer s -> ST s () +lexerSetScriptData Lexer{..} = wref lexerState StateScriptData + +-- | Sets the skip next linefeed flag. +lexerSkipNextLF :: Lexer s -> ST s () +lexerSkipNextLF Lexer{..} = wref lexerSkip LexerSkipLF + +-- | Gets the next token from a lexer. +lexerNext :: Lexer s -> ST s Token +lexerNext x @ Lexer {..} = + skip + where + skip = do + t <- next + case t of + TChar 0x10 -> + rref lexerSkip >>= \case + LexerSkipLF -> + wref lexerSkip LexerSkipNone >> skip + LexerSkipNone -> + pure t + _otherwise -> + pure t + + next = do + i <- tokenNext lexerToken + if i == 0 + then do + tokenReset lexerToken + s <- rref lexerState + lexerDispatch s x + i <- tokenFirst lexerToken + if i == 0 + then pure TEOF + else tokenPack i lexerToken + else do + tokenPack i lexerToken + +-- | Gets the next word from a lexer. +nextWord :: Lexer s -> ST s Word8 +nextWord x @ Lexer {..} = do + offset <- rref lexerOffset + if | offset < bsLen lexerData -> do + wref lexerOffset (offset + 1) + pure $ bsIndex lexerData offset + | otherwise -> + pure chrEOF + +-- | Gets the next word from a lexer without advancing. +peekWord :: Lexer s -> ST s Word8 +peekWord x @ Lexer {..} = do + offset <- rref lexerOffset + if | offset < bsLen lexerData -> + pure $ bsIndex lexerData offset + | otherwise -> + pure chrEOF + +-- | Moves the lexer back one word. +backWord :: Lexer s -> ST s () +backWord x @ Lexer {..} = uref lexerOffset (subtract 1) + +-- | Skips the specified number of words. +skipWord :: Lexer s -> Int -> ST s () +skipWord x @ Lexer {..} n = uref lexerOffset (+n) + +-- | Gets an indexing function from the current lexer offset. +dataIndexer :: Lexer s -> ST s (Int -> Word8) +dataIndexer x @ Lexer {..} = do + offset <- rref lexerOffset + pure $ \i -> bsIndex lexerData (offset + i) + +-- | Gets the remaining number of words. +dataRemain :: Lexer s -> ST s Int +dataRemain x @ Lexer {..} = do + offset <- rref lexerOffset + pure $ bsLen lexerData - offset + +-- | Emits the last token in the token buffer. +emit :: Lexer s -> ST s () +emit x @ Lexer {..} = do + tokenTail lexerToken >>= flip tokenTagStartName lexerToken >>= \case + Just a -> wref lexerLast a + Nothing -> pure () + +-- | Emits a character token. +emitChar :: Lexer s -> Word8 -> ST s () +emitChar x @ Lexer {..} w = do + tokenCharInit w lexerToken + emit x + +-- | Emits the characters in the buffer. +emitBuffer :: Lexer s -> ST s () +emitBuffer x @ Lexer {..} = do + bufferApply (emitChar x) lexerBuffer + bufferReset lexerBuffer + +-- | Sets the lexer state. +state :: Lexer s -> LexerState -> ST s () +state x @ Lexer {..} = wref lexerState + +-- | Sets the lexer return state. +returnSet :: Lexer s -> LexerState -> ST s () +returnSet x @ Lexer {..} = wref lexerReturn + +-- | Gets the lexer return state. +returnGet :: Lexer s -> ST s LexerState +returnGet x @ Lexer {..} = rref lexerReturn + +-- | Switches to the return state. +returnState :: Lexer s -> ST s () +returnState x = returnGet x >>= flip lexerDispatch x + +-- | Handles parse errors. +parseError :: Lexer s -> BS -> ST s () +parseError x @ Lexer {..} = + when lexerLog . (uref lexerErrors . flip D.snoc) + +-- | Determines if the current token is an appropriate end tag. +appropriateEndTag :: Lexer s -> ST s Bool +appropriateEndTag x @ Lexer {..} = do + tokenTail lexerToken >>= flip tokenTagEndName lexerToken >>= \case + Just a -> (==a) <$> rref lexerLast + Nothing -> pure False + +-- | Determines if an attribute value is currently being consumed. +consumingAttibute :: Lexer s -> ST s Bool +consumingAttibute x @ Lexer {..} = do + a <- returnGet x + pure $ any (==a) + [ StateAttrValueDoubleQuoted + , StateAttrValueSingleQuoted + , StateAttrValueUnquoted + ] + +-- | Flushes the code points stored in the buffer. +flushCodePoints :: Lexer s -> ST s () +flushCodePoints x @ Lexer {..} = do + a <- consumingAttibute x + if | a -> do + bufferApply (flip tokenAttrValAppend lexerToken) lexerBuffer + bufferReset lexerBuffer + | otherwise -> do + emitBuffer x + +-- 12.2.5.1 Data state +doData :: Lexer s -> ST s () +doData x @ Lexer {..} = do + c <- nextWord x + if | c == chrAmpersand -> do + returnSet x StateData + doCharacterReference x + | c == chrLess -> do + doTagOpen x + | c == chrEOF -> do + tokenEOFInit lexerToken + emit x + | otherwise -> do + emitChar x c + doData x + +-- 12.2.5.2 RCDATA state +doRCDATA :: Lexer s -> ST s () +doRCDATA x @ Lexer {..} = do + c <- nextWord x + if | c == chrAmpersand -> do + returnSet x StateRCDATA + doCharacterReference x + | c == chrLess -> do + doRCDATALessThan x + | c == chrEOF -> do + tokenEOFInit lexerToken + emit x + | otherwise -> do + emitChar x c + doRCDATA x + +-- 12.2.5.3 RAWTEXT state +doRAWTEXT :: Lexer s -> ST s () +doRAWTEXT x @ Lexer {..} = do + c <- nextWord x + if | c == chrLess -> do + doRAWTEXTLessThan x + | c == chrEOF -> do + tokenEOFInit lexerToken + emit x + | otherwise -> do + emitChar x c + doRAWTEXT x + +-- 12.2.5.4 Script data state +doScriptData :: Lexer s -> ST s () +doScriptData x @ Lexer {..} = do + c <- nextWord x + if | c == chrLess -> do + doScriptDataLessThan x + | c == chrEOF -> do + tokenEOFInit lexerToken + emit x + | otherwise -> do + emitChar x c + doScriptData x + +-- 12.2.5.5 PLAINTEXT state +doPLAINTEXT :: Lexer s -> ST s () +doPLAINTEXT x @ Lexer {..} = do + c <- nextWord x + if | c == chrEOF -> do + tokenEOFInit lexerToken + emit x + | otherwise -> do + emitChar x c + doPLAINTEXT x + +-- 12.2.5.6 Tag open state +doTagOpen :: Lexer s -> ST s () +doTagOpen x @ Lexer {..} = do + c <- nextWord x + if | c == chrExclamation -> do + doMarkupDeclarationOpen x + | c == chrSolidus -> do + doEndTagOpen x + | chrASCIIAlpha c -> do + tokenTagStartInit lexerToken + backWord x + doTagName x + | c == chrQuestion -> do + parseError x "unexpected-question-mark-instead-of-tag-name" + tokenCommentInit lexerToken + backWord x + doBogusComment x + | c == chrEOF -> do + parseError x "eof-before-tag-name" + tokenCharInit chrLess lexerToken + tokenEOFInit lexerToken + emit x + | otherwise -> do + parseError x "invalid-first-character-of-tag-name" + backWord x + doData x + +-- 12.2.5.7 End tag open state +doEndTagOpen :: Lexer s -> ST s () +doEndTagOpen x @ Lexer {..} = do + c <- nextWord x + if | chrASCIIAlpha c -> do + tokenTagEndInit lexerToken + backWord x + doTagName x + | c == chrGreater -> do + parseError x "missing-end-tag-name" + doData x + | c == chrEOF -> do + parseError x "eof-before-tag-name" + tokenCharInit chrLess lexerToken + tokenCharInit chrSolidus lexerToken + tokenEOFInit lexerToken + emit x + | otherwise -> do + parseError x "invalid-first-character-of-tag-name" + tokenCommentInit lexerToken + backWord x + doBogusComment x + +-- 12.2.5.8 Tag name state +doTagName :: Lexer s -> ST s () +doTagName x @ Lexer {..} = do + c <- nextWord x + if | c == chrTab || + c == chrLF || + c == chrFF || + c == chrSpace -> do + doBeforeAttrName x + | c == chrSolidus -> do + doSelfClosingStartTag x + | c == chrGreater -> do + state x StateData + emit x + | chrASCIIUpperAlpha c -> do + tokenTagNameAppend (chrToLower c) lexerToken + doTagName x + | c == chrEOF -> do + parseError x "eof-in-tag" + tokenEOFInit lexerToken + emit x + | otherwise -> do + tokenTagNameAppend c lexerToken + doTagName x + +-- 12.2.5.9 RCDATA less-than sign state +doRCDATALessThan :: Lexer s -> ST s () +doRCDATALessThan x @ Lexer {..} = do + c <- nextWord x + if | c == chrSolidus -> do + bufferReset lexerBuffer + doRCDATAEndTagOpen x + | otherwise -> do + tokenCharInit chrLess lexerToken + backWord x + doRCDATA x + +-- 12.2.5.10 RCDATA end tag open state +doRCDATAEndTagOpen :: Lexer s -> ST s () +doRCDATAEndTagOpen x @ Lexer {..} = do + c <- nextWord x + if | chrASCIIAlpha c -> do + tokenTagEndInit lexerToken + backWord x + doRCDATAEndTagName x + | otherwise -> do + tokenCharInit chrLess lexerToken + tokenCharInit chrSolidus lexerToken + backWord x + doRCDATA x + +-- 12.2.5.11 RCDATA end tag name state +doRCDATAEndTagName :: Lexer s -> ST s () +doRCDATAEndTagName x @ Lexer {..} = do + c <- nextWord x + a <- appropriateEndTag x + if | c == chrTab || + c == chrLF || + c == chrFF || + c == chrSpace -> do + if a + then do + doBeforeAttrName x + else do + anythingElse + | c == chrSolidus -> do + if a + then do + doSelfClosingStartTag x + else do + anythingElse + | c == chrGreater -> do + if a + then do + state x StateData + emit x + else do + anythingElse + | chrASCIIUpperAlpha c -> do + tokenTagNameAppend (chrToLower c) lexerToken + bufferAppend c lexerBuffer + doRCDATAEndTagName x + | chrASCIILowerAlpha c -> do + tokenTagNameAppend c lexerToken + bufferAppend c lexerBuffer + doRCDATAEndTagName x + | otherwise -> do + anythingElse + where + anythingElse = do + tokenDrop lexerToken + emitChar x chrLess + emitChar x chrSolidus + emitBuffer x + backWord x + doRCDATA x + +-- 12.2.5.12 RAWTEXT less-than sign state +doRAWTEXTLessThan :: Lexer s -> ST s () +doRAWTEXTLessThan x @ Lexer {..} = do + c <- nextWord x + if | c == chrSolidus -> do + bufferReset lexerBuffer + doRAWTEXTEndTagOpen x + | otherwise -> do + tokenCharInit chrLess lexerToken + backWord x + doRAWTEXT x + +-- 12.2.5.13 RAWTEXT end tag open state +doRAWTEXTEndTagOpen :: Lexer s -> ST s () +doRAWTEXTEndTagOpen x @ Lexer {..} = do + c <- nextWord x + if | chrASCIIAlpha c -> do + tokenTagEndInit lexerToken + backWord x + doRAWTEXTEndTagName x + | otherwise -> do + emitChar x chrLess + emitChar x chrSolidus + backWord x + doRAWTEXT x + +-- 12.2.5.14 RAWTEXT end tag name state +doRAWTEXTEndTagName :: Lexer s -> ST s () +doRAWTEXTEndTagName x @ Lexer {..} = do + c <- nextWord x + a <- appropriateEndTag x + if | c == chrTab || + c == chrLF || + c == chrFF || + c == chrSpace -> do + if a + then do + doBeforeAttrName x + else do + anythingElse + | c == chrSolidus -> do + if a + then do + doSelfClosingStartTag x + else do + anythingElse + | c == chrGreater -> do + if a + then do + state x StateData + emit x + else do + anythingElse + | chrASCIIUpperAlpha c -> do + tokenTagNameAppend (chrToLower c) lexerToken + bufferAppend c lexerBuffer + doRAWTEXTEndTagName x + | chrASCIILowerAlpha c -> do + tokenTagNameAppend c lexerToken + bufferAppend c lexerBuffer + doRAWTEXTEndTagName x + | otherwise -> do + anythingElse + where + anythingElse = do + tokenDrop lexerToken + emitChar x chrLess + emitChar x chrSolidus + emitBuffer x + backWord x + doRAWTEXT x + +-- 12.2.5.15 Script data less-than sign state +doScriptDataLessThan :: Lexer s -> ST s () +doScriptDataLessThan x @ Lexer {..} = do + c <- nextWord x + if | c == chrSolidus -> do + bufferReset lexerBuffer + doScriptDataEndTagOpen x + | c == chrExclamation -> do + tokenCharInit chrLess lexerToken + tokenCharInit chrExclamation lexerToken + doScriptDataEscapeStart x + | otherwise -> do + tokenCharInit chrLess lexerToken + backWord x + doScriptData x + +-- 12.2.5.16 Script data end tag open state +doScriptDataEndTagOpen :: Lexer s -> ST s () +doScriptDataEndTagOpen x @ Lexer {..} = do + c <- nextWord x + if | chrASCIIAlpha c -> do + tokenTagEndInit lexerToken + backWord x + doScriptDataEndTagName x + | otherwise -> do + emitChar x chrLess + emitChar x chrSolidus + backWord x + doScriptData x + +-- 12.2.5.17 Script data end tag name state +doScriptDataEndTagName :: Lexer s -> ST s () +doScriptDataEndTagName x @ Lexer {..} = do + c <- nextWord x + a <- appropriateEndTag x + if | c == chrTab || + c == chrLF || + c == chrFF || + c == chrSpace -> do + if a + then do + doBeforeAttrName x + else do + anythingElse + | c == chrSolidus -> do + if a + then do + doSelfClosingStartTag x + else do + anythingElse + | c == chrGreater -> do + if a + then do + state x StateData + emit x + else do + anythingElse + | chrASCIIUpperAlpha c -> do + tokenTagNameAppend (chrToLower c) lexerToken + bufferAppend c lexerBuffer + doScriptDataEndTagName x + | chrASCIILowerAlpha c -> do + tokenTagNameAppend c lexerToken + bufferAppend c lexerBuffer + doScriptDataEndTagName x + | otherwise -> do + anythingElse + where + anythingElse = do + tokenDrop lexerToken + emitChar x chrLess + emitChar x chrSolidus + emitBuffer x + backWord x + doScriptData x + +-- 12.2.5.18 Script data escape start state +doScriptDataEscapeStart :: Lexer s -> ST s () +doScriptDataEscapeStart x @ Lexer {..} = do + c <- nextWord x + if | c == chrHyphen -> do + emitChar x chrHyphen + doScriptDataEscapeStartDash x + | otherwise -> do + backWord x + doScriptData x + +-- 12.2.5.19 Script data escape start dash state +doScriptDataEscapeStartDash :: Lexer s -> ST s () +doScriptDataEscapeStartDash x @ Lexer {..} = do + c <- nextWord x + if | c == chrHyphen -> do + emitChar x chrHyphen + doScriptDataEscapedDashDash x + | otherwise -> do + backWord x + doScriptData x + +-- 12.2.5.20 Script data escaped state +doScriptDataEscaped :: Lexer s -> ST s () +doScriptDataEscaped x @ Lexer {..} = do + c <- nextWord x + if | c == chrHyphen -> do + emitChar x chrHyphen + doScriptDataEscapedDash x + | c == chrLess -> do + doScriptDataEscapedLessThan x + | c == chrEOF -> do + parseError x "eof-in-script-html-comment-like-text" + tokenEOFInit lexerToken + emit x + | otherwise -> do + emitChar x c + doScriptDataEscaped x + +-- 12.2.5.21 Script data escaped dash state +doScriptDataEscapedDash :: Lexer s -> ST s () +doScriptDataEscapedDash x @ Lexer {..} = do + c <- nextWord x + if | c == chrHyphen -> do + emitChar x chrHyphen + doScriptDataEscapedDashDash x + | c == chrLess -> do + doScriptDataEscapedLessThan x + | c == chrEOF -> do + parseError x "eof-in-script-html-comment-like-text" + tokenEOFInit lexerToken + emit x + | otherwise -> do + emitChar x c + doScriptDataEscaped x + +-- 12.2.5.22 Script data escaped dash dash state +doScriptDataEscapedDashDash :: Lexer s -> ST s () +doScriptDataEscapedDashDash x @ Lexer {..} = do + c <- nextWord x + if | c == chrHyphen -> do + emitChar x c + doScriptDataEscapedDashDash x + | c == chrLess -> do + doScriptDataEscapedLessThan x + | c == chrGreater -> do + emitChar x c + doScriptData x + | c == chrEOF -> do + parseError x "eof-in-script-html-comment-like-text" + tokenEOFInit lexerToken + emit x + | otherwise -> do + emitChar x c + doScriptDataEscaped x + +-- 12.2.5.23 Script data escaped less-than sign state +doScriptDataEscapedLessThan :: Lexer s -> ST s () +doScriptDataEscapedLessThan x @ Lexer {..} = do + c <- nextWord x + if | c == chrSolidus -> do + bufferReset lexerBuffer + doScriptDataEscapedEndTagOpen x + | chrASCIIAlpha c -> do + bufferReset lexerBuffer + emitChar x chrLess + backWord x + doScriptDataDoubleEscapedStart x + | otherwise -> do + emitChar x chrLess + backWord x + doScriptDataEscaped x + +-- 12.2.5.24 Script data escaped end tag open state +doScriptDataEscapedEndTagOpen :: Lexer s -> ST s () +doScriptDataEscapedEndTagOpen x @ Lexer {..} = do + c <- nextWord x + if | chrASCIIAlpha c -> do + tokenTagEndInit lexerToken + backWord x + doScriptDataEscapedEndTagName x + | otherwise -> do + emitChar x chrLess + emitChar x chrSolidus + backWord x + doScriptDataEscaped x + +-- 12.2.5.25 Script data escaped end tag name state +doScriptDataEscapedEndTagName :: Lexer s -> ST s () +doScriptDataEscapedEndTagName x @ Lexer {..} = do + c <- nextWord x + a <- appropriateEndTag x + if | c == chrTab || + c == chrLF || + c == chrFF || + c == chrSpace -> do + if a + then do + doBeforeAttrName x + else do + anythingElse + | c == chrSolidus -> do + if a + then do + doSelfClosingStartTag x + else do + anythingElse + | c == chrGreater -> do + if a + then do + state x StateData + emit x + else do + anythingElse + | chrASCIIUpperAlpha c -> do + tokenTagNameAppend (chrToLower c) lexerToken + bufferAppend c lexerBuffer + doScriptDataEscapedEndTagName x + | chrASCIILowerAlpha c -> do + tokenTagNameAppend c lexerToken + bufferAppend c lexerBuffer + doScriptDataEscapedEndTagName x + | otherwise -> do + anythingElse + where + anythingElse = do + tokenDrop lexerToken + emitChar x chrLess + emitChar x chrSolidus + emitBuffer x + backWord x + state x StateScriptDataEscaped + emit x + +-- 12.2.5.26 Script data double escape start state +doScriptDataDoubleEscapedStart :: Lexer s -> ST s () +doScriptDataDoubleEscapedStart x @ Lexer {..} = do + c <- nextWord x + if | c == chrTab || + c == chrLF || + c == chrFF || + c == chrSpace || + c == chrSolidus || + c == chrGreater -> do + bufferContains (bsUnpack "script") lexerBuffer >>= \case + True -> do + doScriptDataDoubleEscaped x + False -> do + tokenCharInit c lexerToken + state x StateScriptDataEscaped + emit x + | chrASCIIUpperAlpha c -> do + bufferAppend (chrToLower c) lexerBuffer + tokenCharInit c lexerToken + state x StateScriptDataDoubleEscapedStart + emit x + | chrASCIILowerAlpha c -> do + bufferAppend c lexerBuffer + tokenCharInit c lexerToken + state x StateScriptDataDoubleEscapedStart + emit x + | otherwise -> do + backWord x + doScriptDataEscaped x + +-- 12.2.5.27 Script data double escaped state +doScriptDataDoubleEscaped :: Lexer s -> ST s () +doScriptDataDoubleEscaped x @ Lexer {..} = do + c <- nextWord x + if | c == chrHyphen -> do + tokenCharInit c lexerToken + state x StateScriptDataDoubleEscapedDash + emit x + | c == chrLess -> do + tokenCharInit c lexerToken + state x StateScriptDataDoubleEscapedLessThan + emit x + | c == chrEOF -> do + parseError x "eof-in-script-html-comment-like-text" + tokenEOFInit lexerToken + emit x + | otherwise -> do + tokenCharInit c lexerToken + emit x + +-- 12.2.5.28 Script data double escaped dash state +doScriptDataDoubleEscapedDash :: Lexer s -> ST s () +doScriptDataDoubleEscapedDash x @ Lexer {..} = do + c <- nextWord x + if | c == chrHyphen -> do + tokenCharInit c lexerToken + state x StateScriptDataDoubleEscapedDashDash + emit x + | c == chrLess -> do + tokenCharInit c lexerToken + state x StateScriptDataDoubleEscapedLessThan + emit x + | c == chrEOF -> do + parseError x "eof-in-script-html-comment-like-text" + tokenEOFInit lexerToken + emit x + | otherwise -> do + tokenCharInit c lexerToken + state x StateScriptDataDoubleEscaped + emit x + +-- 12.2.5.29 Script data double escaped dash dash state +doScriptDataDoubleEscapedDashDash :: Lexer s -> ST s () +doScriptDataDoubleEscapedDashDash x @ Lexer {..} = do + c <- nextWord x + if | c == chrHyphen -> do + emitChar x c + doScriptDataDoubleEscapedDashDash x + | c == chrLess -> do + tokenCharInit c lexerToken + state x StateScriptDataDoubleEscapedLessThan + emit x + | c == chrGreater -> do + tokenCharInit c lexerToken + state x StateScriptData + emit x + | c == chrEOF -> do + parseError x "eof-in-script-html-comment-like-text" + tokenEOFInit lexerToken + emit x + | otherwise -> do + tokenCharInit c lexerToken + state x StateScriptDataDoubleEscaped + emit x + +-- 12.2.5.30 Script data double escaped less-than sign state +doScriptDataDoubleEscapedLessThan :: Lexer s -> ST s () +doScriptDataDoubleEscapedLessThan x @ Lexer {..} = do + c <- nextWord x + if | c == chrSolidus -> do + bufferReset lexerBuffer + tokenCharInit c lexerToken + state x StateScriptDataDoubleEscapeEnd + emit x + | otherwise -> do + backWord x + doScriptDataDoubleEscaped x + +-- 12.2.5.31 Script data double escape end state +doScriptDataDoubleEscapeEnd :: Lexer s -> ST s () +doScriptDataDoubleEscapeEnd x @ Lexer {..} = do + c <- nextWord x + if | c == chrTab || + c == chrLF || + c == chrFF || + c == chrSpace || + c == chrSolidus || + c == chrGreater -> do + bufferContains (bsUnpack "script") lexerBuffer >>= \case + True -> do + doScriptDataEscaped x + False -> do + tokenCharInit c lexerToken + state x StateScriptDataDoubleEscaped + emit x + | chrASCIIUpperAlpha c -> do + bufferAppend (chrToLower c) lexerBuffer + emitChar x c + doScriptDataDoubleEscapeEnd x + | chrASCIILowerAlpha c -> do + bufferAppend c lexerBuffer + emitChar x c + doScriptDataDoubleEscapeEnd x + | otherwise -> do + backWord x + doScriptDataDoubleEscaped x + +-- 12.2.5.32 Before attribute name state +doBeforeAttrName :: Lexer s -> ST s () +doBeforeAttrName x @ Lexer {..} = do + c <- nextWord x + if | c == chrTab || + c == chrLF || + c == chrFF || + c == chrSpace -> do + doBeforeAttrName x + | c == chrSolidus || + c == chrGreater || + c == chrEOF -> do + backWord x + doAfterAttrName x + | c == chrEqual -> do + parseError x "unexpected-equals-sign-before-attribute-name" + tokenAttrInit lexerToken + tokenAttrNameAppend c lexerToken + doAttrName x + | otherwise -> do + tokenAttrInit lexerToken + backWord x + doAttrName x + +-- 12.2.5.33 Attribute name state +doAttrName :: Lexer s -> ST s () +doAttrName x @ Lexer {..} = do + c <- nextWord x + if | c == chrTab || + c == chrLF || + c == chrFF || + c == chrSpace || + c == chrSolidus || + c == chrGreater || + c == chrEOF -> do + checkAttr + backWord x + doAfterAttrName x + | c == chrEqual -> do + checkAttr + doBeforeAttrValue x + | chrASCIIUpperAlpha c -> do + tokenAttrNameAppend (chrToLower c) lexerToken + doAttrName x + | c == chrQuote || + c == chrApostrophe || + c == chrLess -> do + parseError x "unexpected-character-in-attribute-name" + tokenAttrNameAppend c lexerToken + doAttrName x + | otherwise -> do + tokenAttrNameAppend c lexerToken + doAttrName x + where + checkAttr = do + i <- tokenTail lexerToken + whenM (tokenAttrNamePrune i lexerToken) $ do + parseError x "duplicate-attribute" + +-- 12.2.5.34 After attribute name state +doAfterAttrName :: Lexer s -> ST s () +doAfterAttrName x @ Lexer {..} = do + c <- nextWord x + if | c == chrTab || + c == chrLF || + c == chrFF || + c == chrSpace -> do + doAfterAttrName x + | c == chrSolidus -> do + doSelfClosingStartTag x + | c == chrEqual -> do + doBeforeAttrValue x + | c == chrGreater -> do + state x StateData + emit x + | c == chrEOF -> do + parseError x "eof-in-tag" + tokenEOFInit lexerToken + emit x + | otherwise -> do + tokenAttrInit lexerToken + backWord x + doAttrName x + +-- 12.2.5.35 Before attribute value state +doBeforeAttrValue :: Lexer s -> ST s () +doBeforeAttrValue x @ Lexer {..} = do + c <- nextWord x + if | c == chrTab || + c == chrLF || + c == chrFF || + c == chrSpace -> do + doBeforeAttrValue x + | c == chrQuote -> do + doAttrValueDoubleQuoted x + | c == chrApostrophe -> do + doAttrValueSingleQuoted x + | c == chrGreater -> do + parseError x "missing-attribute-value" + state x StateData + emit x + | otherwise -> do + backWord x + doAttrValueUnquoted x + +-- 12.2.5.36 Attribute value (double-quoted) state +doAttrValueDoubleQuoted :: Lexer s -> ST s () +doAttrValueDoubleQuoted x @ Lexer {..} = do + c <- nextWord x + if | c == chrQuote -> do + doAfterAttrValue x + | c == chrAmpersand -> do + returnSet x StateAttrValueDoubleQuoted + doCharacterReference x + | c == chrEOF -> do + parseError x "eof-in-tag" + tokenEOFInit lexerToken + emit x + | otherwise -> do + tokenAttrValAppend c lexerToken + doAttrValueDoubleQuoted x + +-- 12.2.5.37 Attribute value (single-quoted) state +doAttrValueSingleQuoted :: Lexer s -> ST s () +doAttrValueSingleQuoted x @ Lexer {..} = do + c <- nextWord x + if | c == chrApostrophe -> do + doAfterAttrValue x + | c == chrAmpersand -> do + returnSet x StateAttrValueSingleQuoted + doCharacterReference x + | c == chrEOF -> do + parseError x "eof-in-tag" + tokenEOFInit lexerToken + emit x + | otherwise -> do + tokenAttrValAppend c lexerToken + doAttrValueSingleQuoted x + +-- 12.2.5.38 Attribute value (unquoted) state +doAttrValueUnquoted :: Lexer s -> ST s () +doAttrValueUnquoted x @ Lexer {..} = do + c <- nextWord x + if | c == chrTab || + c == chrLF || + c == chrFF || + c == chrSpace -> do + doBeforeAttrName x + | c == chrAmpersand -> do + returnSet x StateAttrValueUnquoted + doCharacterReference x + | c == chrGreater -> do + state x StateData + emit x + | c == chrQuote || + c == chrApostrophe || + c == chrLess || + c == chrEqual || + c == chrGrave -> do + parseError x "unexpected-character-in-unquoted-attribute-value" + tokenAttrValAppend c lexerToken + doAttrValueUnquoted x + | c == chrEOF -> do + parseError x "eof-in-tag" + tokenEOFInit lexerToken + emit x + | otherwise -> do + tokenAttrValAppend c lexerToken + doAttrValueUnquoted x + +-- 12.2.5.39 After attribute value (quoted) state +doAfterAttrValue :: Lexer s -> ST s () +doAfterAttrValue x @ Lexer {..} = do + c <- nextWord x + if | c == chrTab || + c == chrLF || + c == chrFF || + c == chrSpace -> do + doBeforeAttrName x + | c == chrSolidus -> do + doSelfClosingStartTag x + | c == chrGreater -> do + state x StateData + emit x + | c == chrEOF -> do + parseError x "eof-in-tag" + tokenEOFInit lexerToken + emit x + | otherwise -> do + parseError x "missing-whitespace-between-attributes" + backWord x + doBeforeAttrName x + +-- 12.2.5.40 Self-closing start tag state +doSelfClosingStartTag :: Lexer s -> ST s () +doSelfClosingStartTag x @ Lexer {..} = do + c <- nextWord x + if | c == chrGreater -> do + tokenTagStartSetSelfClosing lexerToken + state x StateData + emit x + | c == chrEOF -> do + parseError x "eof-in-tag" + tokenEOFInit lexerToken + emit x + | otherwise -> do + parseError x "unexpected-solidus-in-tag" + backWord x + doBeforeAttrName x + +-- 12.2.5.41 Bogus comment state +doBogusComment :: Lexer s -> ST s () +doBogusComment x @ Lexer {..} = do + c <- nextWord x + if | c == chrGreater -> do + state x StateData + emit x + | c == chrEOF -> do + tokenEOFInit lexerToken + emit x + | otherwise -> do + tokenCommentAppend c lexerToken + doBogusComment x + +-- 12.2.5.42 Markup declaration open state +doMarkupDeclarationOpen :: Lexer s -> ST s () +doMarkupDeclarationOpen x @ Lexer {..} = do + f <- dataIndexer x + n <- dataRemain x + if | n > 1 && + f 0 == chrHyphen && + f 1 == chrHyphen -> do + skipWord x 2 + tokenCommentInit lexerToken + doCommentStart x + | n > 6 && + (f 0 == 0x44 || f 0 == 0x64) && -- D or d + (f 1 == 0x4F || f 1 == 0x6F) && -- O or o + (f 2 == 0x43 || f 2 == 0x63) && -- C or c + (f 3 == 0x54 || f 3 == 0x74) && -- T or t + (f 4 == 0x59 || f 4 == 0x79) && -- Y or y + (f 5 == 0x50 || f 5 == 0x70) && -- P or p + (f 6 == 0x45 || f 6 == 0x65) -> do -- E or e + skipWord x 7 + doDoctype x + | n > 6 && + f 0 == 0x5B && -- [ + f 1 == 0x43 && -- C + f 2 == 0x44 && -- D + f 3 == 0x41 && -- A + f 4 == 0x54 && -- T + f 5 == 0x41 && -- A + f 6 == 0x5B -> do -- [ + skipWord x 7 + -- The standard says to check if the parser has an adjusted current node + -- that is not in the HTML namespace, and if so then CDATA sections are + -- allowed. For now we assume that condition is true and we do not + -- check with the parser to verify. CDATA sections in HTML are probably + -- not common and in most cases they are going to be in the correct + -- locations anyway. + if True -- TODO + then do + state x StateCDATASection + doCDATASection x + else do + parseError x "cdata-in-html-content" + tokenCommentInit lexerToken + mapM_ (flip tokenCommentAppend lexerToken) + [ 0x5B, 0x43, 0x44, 0x41, 0x54, 0x41, 0x5B ] + doBogusComment x + | otherwise -> do + parseError x "incorrectly-opened-comment" + tokenCommentInit lexerToken + doBogusComment x + +-- 12.2.5.43 Comment start state +doCommentStart :: Lexer s -> ST s () +doCommentStart x @ Lexer {..} = do + c <- nextWord x + if | c == chrHyphen -> do + doCommentStartDash x + | c == chrGreater -> do + parseError x "abrupt-closing-of-empty-comment" + state x StateData + emit x + | otherwise -> do + backWord x + doComment x + +-- 12.2.5.44 Comment start dash state +doCommentStartDash :: Lexer s -> ST s () +doCommentStartDash x @ Lexer {..} = do + c <- nextWord x + if | c == chrHyphen -> do + doCommentEnd x + | c == chrGreater -> do + parseError x "abrupt-closing-of-empty-comment" + state x StateData + emit x + | c == chrEOF -> do + parseError x "eof-in-comment" + tokenEOFInit lexerToken + emit x + | otherwise -> do + tokenCommentAppend chrHyphen lexerToken + backWord x + doComment x + +-- 12.2.5.45 Comment state +doComment :: Lexer s -> ST s () +doComment x @ Lexer {..} = do + c <- nextWord x + if | c == chrLess -> do + tokenCommentAppend c lexerToken + doCommentLessThan x + | c == chrHyphen -> do + doCommentEndDash x + | c == chrEOF -> do + parseError x "eof-in-comment" + tokenEOFInit lexerToken + emit x + | otherwise -> do + tokenCommentAppend c lexerToken + doComment x + +-- 12.2.5.46 Comment less-than sign state +doCommentLessThan :: Lexer s -> ST s () +doCommentLessThan x @ Lexer {..} = do + c <- nextWord x + if | c == chrExclamation -> do + tokenCommentAppend c lexerToken + doCommentLessThanBang x + | c == chrLess -> do + tokenCommentAppend c lexerToken + doCommentLessThan x + | otherwise -> do + backWord x + doComment x + +-- 12.2.5.47 Comment less-than sign bang state +doCommentLessThanBang :: Lexer s -> ST s () +doCommentLessThanBang x @ Lexer {..} = do + c <- nextWord x + if | c == chrHyphen -> do + doCommentLessThanBangDash x + | otherwise -> do + backWord x + doComment x + +-- 12.2.5.48 Comment less-than sign bang dash state +doCommentLessThanBangDash :: Lexer s -> ST s () +doCommentLessThanBangDash x @ Lexer {..} = do + c <- nextWord x + if | c == chrHyphen -> do + doCommentLessThanBangDashDash x + | otherwise -> do + backWord x + doCommentEndDash x + +-- 12.2.5.49 Comment less-than sign bang dash dash state +doCommentLessThanBangDashDash :: Lexer s -> ST s () +doCommentLessThanBangDashDash x @ Lexer {..} = do + c <- nextWord x + if | c == chrHyphen || + c == chrEOF -> do + backWord x + doCommentEnd x + | otherwise -> do + parseError x "nested-comment" + backWord x + doCommentEnd x + +-- 12.2.5.50 Comment end dash state +doCommentEndDash :: Lexer s -> ST s () +doCommentEndDash x @ Lexer {..} = do + c <- nextWord x + if | c == chrHyphen -> do + doCommentEnd x + | c == chrEOF -> do + parseError x "eof-in-comment" + tokenEOFInit lexerToken + emit x + | otherwise -> do + tokenCommentAppend chrHyphen lexerToken + backWord x + doComment x + +-- 12.2.5.51 Comment end state +doCommentEnd :: Lexer s -> ST s () +doCommentEnd x @ Lexer {..} = do + c <- nextWord x + if | c == chrGreater -> do + state x StateData + emit x + | c == chrExclamation -> do + doCommentEndBang x + | c == chrHyphen -> do + tokenCommentAppend chrHyphen lexerToken + doCommentEnd x + | c == chrEOF -> do + parseError x "eof-in-comment" + tokenEOFInit lexerToken + emit x + | otherwise -> do + tokenCommentAppend chrHyphen lexerToken + tokenCommentAppend chrHyphen lexerToken + backWord x + doComment x + +-- 12.2.5.52 Comment end bang state +doCommentEndBang :: Lexer s -> ST s () +doCommentEndBang x @ Lexer {..} = do + c <- nextWord x + if | c == chrGreater -> do + state x StateData + emit x + | c == chrHyphen -> do + tokenCommentAppend chrHyphen lexerToken + tokenCommentAppend chrHyphen lexerToken + tokenCommentAppend chrExclamation lexerToken + doCommentEndDash x + | c == chrGreater -> do + parseError x "incorrectly-closed-comment" + state x StateData + emit x + | c == chrEOF -> do + parseError x "eof-in-comment" + tokenEOFInit lexerToken + emit x + | otherwise -> do + tokenCommentAppend chrHyphen lexerToken + tokenCommentAppend chrHyphen lexerToken + tokenCommentAppend chrExclamation lexerToken + backWord x + doComment x + +-- 12.2.5.53 DOCTYPE state +doDoctype :: Lexer s -> ST s () +doDoctype x @ Lexer {..} = do + c <- nextWord x + if | c == chrTab || + c == chrLF || + c == chrFF || + c == chrSpace -> do + doBeforeDoctypeName x + | c == chrGreater -> do + backWord x + doBeforeDoctypeName x + | c == chrEOF -> do + parseError x "eof-in-doctype" + tokenDoctypeInit lexerToken + tokenDoctypeSetForceQuirks lexerToken + tokenEOFInit lexerToken + emit x + | otherwise -> do + parseError x "missing-whitespace-before-doctype-name" + backWord x + doBeforeDoctypeName x + +-- 12.2.5.54 Before DOCTYPE name state +doBeforeDoctypeName :: Lexer s -> ST s () +doBeforeDoctypeName x @ Lexer {..} = do + c <- nextWord x + if | c == chrTab || + c == chrLF || + c == chrFF || + c == chrSpace -> do + doBeforeDoctypeName x + | chrASCIIUpperAlpha c -> do + tokenDoctypeInit lexerToken + tokenDoctypeNameAppend (chrToLower c) lexerToken + doDoctypeName x + | c == chrGreater -> do + parseError x "missing-doctype-name" + tokenDoctypeInit lexerToken + tokenDoctypeSetForceQuirks lexerToken + state x StateData + emit x + | c == chrEOF -> do + parseError x "eof-in-doctype" + tokenDoctypeInit lexerToken + tokenDoctypeSetForceQuirks lexerToken + tokenEOFInit lexerToken + emit x + | otherwise -> do + tokenDoctypeInit lexerToken + tokenDoctypeNameAppend c lexerToken + doDoctypeName x + +-- 12.2.5.55 DOCTYPE name state +doDoctypeName :: Lexer s -> ST s () +doDoctypeName x @ Lexer {..} = do + c <- nextWord x + if | c == chrTab || + c == chrLF || + c == chrFF || + c == chrSpace -> do + doAfterDoctypeName x + | c == chrGreater -> do + state x StateData + emit x + | chrASCIIUpperAlpha c -> do + tokenDoctypeNameAppend (chrToLower c) lexerToken + doDoctypeName x + | c == chrEOF -> do + parseError x "eof-in-doctype" + tokenDoctypeSetForceQuirks lexerToken + tokenEOFInit lexerToken + emit x + | otherwise -> do + tokenDoctypeNameAppend c lexerToken + doDoctypeName x + +-- 12.2.5.56 After DOCTYPE name state +doAfterDoctypeName :: Lexer s -> ST s () +doAfterDoctypeName x @ Lexer {..} = do + c <- nextWord x + -- Get data indexer after the character. + f <- dataIndexer x + if | c == chrTab || + c == chrLF || + c == chrFF || + c == chrSpace -> do + doAfterDoctypeName x + | c == chrGreater -> do + state x StateData + emit x + | c == chrEOF -> do + parseError x "eof-in-doctype" + tokenDoctypeSetForceQuirks lexerToken + tokenEOFInit lexerToken + emit x + | (c == 0x50 || c == 0x70) && -- P or p + (f 0 == 0x55 || f 0 == 0x75) && -- U or u + (f 1 == 0x42 || f 1 == 0x62) && -- B or b + (f 2 == 0x4C || f 2 == 0x6C) && -- L or l + (f 3 == 0x49 || f 3 == 0x69) && -- I or i + (f 4 == 0x43 || f 4 == 0x63) -> do -- C or c + skipWord x 5 + doAfterDoctypePublicKeyword x + | (c == 0x53 || c == 0x73) && -- S or s + (f 0 == 0x59 || f 0 == 0x79) && -- Y or y + (f 1 == 0x53 || f 1 == 0x73) && -- S or s + (f 2 == 0x54 || f 2 == 0x74) && -- T or t + (f 3 == 0x45 || f 3 == 0x65) && -- E or e + (f 4 == 0x4D || f 4 == 0x6D) -> do -- M or m + skipWord x 5 + doAfterDoctypeSystemKeyword x + | otherwise -> do + parseError x "invalid-character-sequence-after-doctype-name" + tokenDoctypeSetForceQuirks lexerToken + doBogusDoctype x + +-- 12.2.5.57 After DOCTYPE public keyword state +doAfterDoctypePublicKeyword :: Lexer s -> ST s () +doAfterDoctypePublicKeyword x @ Lexer {..} = do + c <- nextWord x + if | c == chrTab || + c == chrLF || + c == chrFF || + c == chrSpace -> do + doBeforeDoctypePublicId x + | c == chrQuote -> do + parseError x "missing-whitespace-after-doctype-public-keyword" + tokenDoctypePublicIdInit lexerToken + doDoctypePublicIdDoubleQuoted x + | c == chrApostrophe -> do + parseError x "missing-whitespace-after-doctype-public-keyword" + tokenDoctypePublicIdInit lexerToken + doDoctypePublicIdSingleQuoted x + | c == chrGreater -> do + parseError x "missing-doctype-public-identifier" + tokenDoctypeSetForceQuirks lexerToken + state x StateData + emit x + | c == chrEOF -> do + parseError x "eof-in-doctype" + tokenDoctypeSetForceQuirks lexerToken + tokenEOFInit lexerToken + emit x + | otherwise -> do + parseError x "missing-quote-before-doctype-public-identifier" + tokenDoctypeSetForceQuirks lexerToken + doBogusDoctype x + +-- 12.2.5.58 Before DOCTYPE public identifier state +doBeforeDoctypePublicId :: Lexer s -> ST s () +doBeforeDoctypePublicId x @ Lexer {..} = do + c <- nextWord x + if | c == chrTab || + c == chrLF || + c == chrFF || + c == chrSpace -> do + doBeforeDoctypePublicId x + | c == chrQuote -> do + tokenDoctypePublicIdInit lexerToken + doDoctypePublicIdDoubleQuoted x + | c == chrApostrophe -> do + tokenDoctypePublicIdInit lexerToken + doDoctypePublicIdSingleQuoted x + | c == chrGreater -> do + parseError x "missing-doctype-public-identifier" + tokenDoctypeSetForceQuirks lexerToken + state x StateData + emit x + | c == chrEOF -> do + parseError x "eof-in-doctype" + tokenDoctypeSetForceQuirks lexerToken + tokenEOFInit lexerToken + emit x + | otherwise -> do + parseError x "missing-quote-before-doctype-public-identifier" + tokenDoctypeSetForceQuirks lexerToken + doBogusDoctype x + +-- 12.2.5.59 DOCTYPE public identifier (double-quoted) state +doDoctypePublicIdDoubleQuoted :: Lexer s -> ST s () +doDoctypePublicIdDoubleQuoted x @ Lexer {..} = do + c <- nextWord x + if | c == chrQuote -> do + doAfterDoctypePublicId x + | c == chrGreater -> do + parseError x "abrupt-doctype-public-identifier" + tokenDoctypeSetForceQuirks lexerToken + state x StateData + emit x + | c == chrEOF -> do + parseError x "eof-in-doctype" + tokenDoctypeSetForceQuirks lexerToken + tokenEOFInit lexerToken + emit x + | otherwise -> do + tokenDoctypePublicIdAppend c lexerToken + doDoctypePublicIdDoubleQuoted x + +-- 12.2.5.60 DOCTYPE public identifier (single-quoted) state +doDoctypePublicIdSingleQuoted :: Lexer s -> ST s () +doDoctypePublicIdSingleQuoted x @ Lexer {..} = do + c <- nextWord x + if | c == chrApostrophe -> do + doAfterDoctypePublicId x + | c == chrGreater -> do + parseError x "abrupt-doctype-public-identifier" + tokenDoctypeSetForceQuirks lexerToken + state x StateData + emit x + | c == chrEOF -> do + parseError x "eof-in-doctype" + tokenDoctypeSetForceQuirks lexerToken + tokenEOFInit lexerToken + emit x + | otherwise -> do + tokenDoctypePublicIdAppend c lexerToken + doDoctypePublicIdSingleQuoted x + +-- 12.2.5.61 After DOCTYPE public identifier state +doAfterDoctypePublicId :: Lexer s -> ST s () +doAfterDoctypePublicId x @ Lexer {..} = do + c <- nextWord x + if | c == chrTab || + c == chrLF || + c == chrFF || + c == chrSpace -> do + doBetweenDoctypePublicAndSystem x + | c == chrGreater -> do + state x StateData + emit x + | c == chrQuote -> do + parseError x "missing-whitespace-between-doctype-public-and-system-identifiers" + tokenDoctypeSystemIdInit lexerToken + doDoctypeSystemIdDoubleQuoted x + | c == chrApostrophe -> do + parseError x "missing-whitespace-between-doctype-public-and-system-identifiers" + tokenDoctypeSystemIdInit lexerToken + doDoctypeSystemIdSingleQuoted x + | c == chrEOF -> do + parseError x "eof-in-doctype" + tokenDoctypeSetForceQuirks lexerToken + tokenEOFInit lexerToken + emit x + | otherwise -> do + parseError x "missing-quote-before-doctype-system-identifier" + tokenDoctypeSetForceQuirks lexerToken + doBogusDoctype x + +-- 12.2.5.62 Between DOCTYPE public and system identifiers state +doBetweenDoctypePublicAndSystem :: Lexer s -> ST s () +doBetweenDoctypePublicAndSystem x @ Lexer {..} = do + c <- nextWord x + if | c == chrTab || + c == chrLF || + c == chrFF || + c == chrSpace -> do + doBetweenDoctypePublicAndSystem x + | c == chrGreater -> do + state x StateData + emit x + | c == chrQuote -> do + tokenDoctypeSystemIdInit lexerToken + doDoctypeSystemIdDoubleQuoted x + | c == chrApostrophe -> do + tokenDoctypeSystemIdInit lexerToken + doDoctypeSystemIdSingleQuoted x + | c == chrEOF -> do + parseError x "eof-in-doctype" + tokenDoctypeSetForceQuirks lexerToken + tokenEOFInit lexerToken + emit x + | otherwise -> do + parseError x "missing-quote-before-doctype-system-identifier" + tokenDoctypeSetForceQuirks lexerToken + doBogusDoctype x + +-- 12.2.5.63 After DOCTYPE system keyword state +doAfterDoctypeSystemKeyword :: Lexer s -> ST s () +doAfterDoctypeSystemKeyword x @ Lexer {..} = do + c <- nextWord x + if | c == chrTab || + c == chrLF || + c == chrFF || + c == chrSpace -> do + doBeforeDoctypeSystemId x + | c == chrQuote -> do + parseError x "missing-whitespace-after-doctype-system-keyword" + tokenDoctypeSystemIdInit lexerToken + doDoctypeSystemIdDoubleQuoted x + | c == chrApostrophe -> do + parseError x "missing-whitespace-after-doctype-system-keyword" + tokenDoctypeSystemIdInit lexerToken + doDoctypeSystemIdSingleQuoted x + | c == chrGreater -> do + parseError x "missing-doctype-system-identifier" + tokenDoctypeSetForceQuirks lexerToken + state x StateData + emit x + | c == chrEOF -> do + parseError x "eof-in-doctype" + tokenDoctypeSetForceQuirks lexerToken + tokenEOFInit lexerToken + emit x + | otherwise -> do + parseError x "missing-quote-before-doctype-system-identifier" + tokenDoctypeSetForceQuirks lexerToken + doBogusDoctype x + +-- 12.2.5.64 Before DOCTYPE system identifier state +doBeforeDoctypeSystemId :: Lexer s -> ST s () +doBeforeDoctypeSystemId x @ Lexer {..} = do + c <- nextWord x + if | c == chrTab || + c == chrLF || + c == chrFF || + c == chrSpace -> do + doBeforeDoctypeSystemId x + | c == chrQuote -> do + tokenDoctypeSystemIdInit lexerToken + doDoctypeSystemIdDoubleQuoted x + | c == chrApostrophe -> do + tokenDoctypeSystemIdInit lexerToken + doDoctypeSystemIdSingleQuoted x + | c == chrGreater -> do + parseError x "missing-doctype-system-identifier" + tokenDoctypeSetForceQuirks lexerToken + state x StateData + emit x + | c == chrEOF -> do + parseError x "eof-in-doctype" + tokenDoctypeSetForceQuirks lexerToken + tokenEOFInit lexerToken + emit x + | otherwise -> do + parseError x "missing-quote-before-doctype-system-identifier" + tokenDoctypeSetForceQuirks lexerToken + doBogusDoctype x + +-- 12.2.5.65 DOCTYPE system identifier (double-quoted) state +doDoctypeSystemIdDoubleQuoted :: Lexer s -> ST s () +doDoctypeSystemIdDoubleQuoted x @ Lexer {..} = do + c <- nextWord x + if | c == chrQuote -> do + doAfterDoctypeSystemId x + | c == chrGreater -> do + parseError x "abrupt-doctype-system-identifier" + tokenDoctypeSetForceQuirks lexerToken + state x StateData + emit x + | c == chrEOF -> do + parseError x "eof-in-doctype" + tokenDoctypeSetForceQuirks lexerToken + tokenEOFInit lexerToken + emit x + | otherwise -> do + tokenDoctypeSystemIdAppend c lexerToken + doDoctypeSystemIdDoubleQuoted x + +-- 12.2.5.66 DOCTYPE system identifier (single-quoted) state +doDoctypeSystemIdSingleQuoted :: Lexer s -> ST s () +doDoctypeSystemIdSingleQuoted x @ Lexer {..} = do + c <- nextWord x + if | c == chrApostrophe -> do + doAfterDoctypeSystemId x + | c == chrGreater -> do + parseError x "abrupt-doctype-system-identifier" + tokenDoctypeSetForceQuirks lexerToken + state x StateData + emit x + | c == chrEOF -> do + parseError x "eof-in-doctype" + tokenDoctypeSetForceQuirks lexerToken + tokenEOFInit lexerToken + emit x + | otherwise -> do + tokenDoctypeSystemIdAppend c lexerToken + doDoctypeSystemIdSingleQuoted x + +-- 12.2.5.67 After DOCTYPE system identifier state +doAfterDoctypeSystemId :: Lexer s -> ST s () +doAfterDoctypeSystemId x @ Lexer {..} = do + c <- nextWord x + if | c == chrTab || + c == chrLF || + c == chrFF || + c == chrSpace -> do + doAfterDoctypeSystemId x + | c == chrGreater -> do + state x StateData + emit x + | c == chrEOF -> do + parseError x "eof-in-doctype" + tokenDoctypeSetForceQuirks lexerToken + tokenEOFInit lexerToken + emit x + | otherwise -> do + parseError x "unexpected-character-after-doctype-system-identifier" + doBogusDoctype x + +-- 12.2.5.68 Bogus DOCTYPE state +doBogusDoctype :: Lexer s -> ST s () +doBogusDoctype x @ Lexer {..} = do + c <- nextWord x + if | c == chrGreater -> do + state x StateData + emit x + | c == chrEOF -> do + tokenEOFInit lexerToken + emit x + | otherwise -> do + doBogusDoctype x + +-- 12.2.5.69 CDATA section state +doCDATASection :: Lexer s -> ST s () +doCDATASection x @ Lexer {..} = do + c <- nextWord x + if | c == chrBracketRight -> do + doCDATASectionBracket x + | c == chrEOF -> do + parseError x "eof-in-cdata" + tokenEOFInit lexerToken + emit x + | otherwise -> do + emitChar x c + doCDATASection x + +-- 12.2.5.70 CDATA section bracket state +doCDATASectionBracket :: Lexer s -> ST s () +doCDATASectionBracket x @ Lexer {..} = do + c <- nextWord x + if | c == chrBracketRight -> do + doCDATASectionEnd x + | otherwise -> do + tokenCharInit chrBracketRight lexerToken + backWord x + doCDATASection x + +-- 12.2.5.71 CDATA section end state +doCDATASectionEnd :: Lexer s -> ST s () +doCDATASectionEnd x @ Lexer {..} = do + c <- nextWord x + if | c == chrBracketRight -> do + emitChar x c + doCDATASectionEnd x + | c == chrGreater -> do + doData x + | otherwise -> do + emitChar x chrBracketRight + emitChar x chrBracketRight + backWord x + doCDATASection x + +-- 12.2.5.72 Character reference state +doCharacterReference :: Lexer s -> ST s () +doCharacterReference x @ Lexer {..} = do + bufferReset lexerBuffer + bufferAppend chrAmpersand lexerBuffer + c <- nextWord x + if | lexerIgnore -> do + flushCodePoints x + backWord x + returnState x + | chrASCIIAlphanumeric c -> do + backWord x + doNamedCharacterReference x + | c == chrNumberSign -> do + bufferAppend c lexerBuffer + doNumericCharacterReference x + | otherwise -> do + flushCodePoints x + backWord x + returnState x + +-- 12.2.5.73 Named character reference state +doNamedCharacterReference :: Lexer s -> ST s () +doNamedCharacterReference x @ Lexer {..} = do + o <- rref lexerOffset + case entityMatch (bsDrop o lexerData) of + Just (p, v, _) -> do + skipWord x $ bsLen p + forM_ (bsUnpack p) $ + flip bufferAppend lexerBuffer + attr <- consumingAttibute x + semi <- pure $ bsLast p == Just chrSemicolon + c <- peekWord x + if | attr + , not semi + , c == chrSemicolon || chrASCIIAlphanumeric c -> do + flushCodePoints x + returnState x + | otherwise -> do + when (not semi) $ + parseError x "missing-semicolon-after-character-reference" + bufferReset lexerBuffer + forM_ (bsUnpack v) $ + flip bufferAppend lexerBuffer + flushCodePoints x + returnState x + Nothing -> do + flushCodePoints x + doAmbiguousAmpersand x + +-- 12.2.5.74 Ambiguous ampersand state +doAmbiguousAmpersand :: Lexer s -> ST s () +doAmbiguousAmpersand x @ Lexer {..} = do + c <- nextWord x + if | chrASCIIAlphanumeric c -> do + consumingAttibute x >>= \case + True -> tokenAttrValAppend c lexerToken + False -> emitChar x c + doAmbiguousAmpersand x + | c == chrSemicolon -> do + parseError x "unknown-named-character-reference" + backWord x + returnState x + | otherwise -> do + backWord x + returnState x + +-- 12.2.5.75 Numeric character reference state +doNumericCharacterReference :: Lexer s -> ST s () +doNumericCharacterReference x @ Lexer {..} = do + wref lexerCode 0 + c <- nextWord x + if | c == chrUpperX || c == chrLowerX -> do + bufferAppend c lexerBuffer + doHexCharacterReferenceStart x + | otherwise -> do + backWord x + doDecimalCharacterReference x + +-- 12.2.5.76 Hexademical character reference start state +doHexCharacterReferenceStart :: Lexer s -> ST s () +doHexCharacterReferenceStart x @ Lexer {..} = do + c <- nextWord x + if | chrASCIIHexDigit c -> do + backWord x + doHexCharacterReference x + | otherwise -> do + parseError x "absence-of-digits-in-numeric-character-reference" + flushCodePoints x + backWord x + returnState x + +-- 12.2.5.77 Decimal character reference start state +doDecimalCharacterReferenceStart :: Lexer s -> ST s () +doDecimalCharacterReferenceStart x @ Lexer {..} = do + c <- nextWord x + if | chrASCIIDigit c -> do + backWord x + doDecimalCharacterReference x + | otherwise -> do + parseError x "absence-of-digits-in-numeric-character-reference" + flushCodePoints x + backWord x + returnState x + +-- 12.2.5.78 Hexademical character reference state +doHexCharacterReference :: Lexer s -> ST s () +doHexCharacterReference x @ Lexer {..} = do + c <- nextWord x + if | chrASCIIDigit c -> do + uref lexerCode $ \y -> 16 * y + (fromIntegral c - 0x30) + doHexCharacterReference x + | chrASCIIUpperHexDigit c -> do + uref lexerCode $ \y -> 16 * y + (fromIntegral c - 0x37) + doHexCharacterReference x + | chrASCIILowerHexDigit c -> do + uref lexerCode $ \y -> 16 * y + (fromIntegral c - 0x57) + doHexCharacterReference x + | c == chrSemicolon -> do + doNumericCharacterReferenceEnd x + | otherwise -> do + parseError x "missing-semicolon-after-character-reference" + backWord x + doNumericCharacterReferenceEnd x + +-- 12.2.5.79 Decimal character reference state +doDecimalCharacterReference :: Lexer s -> ST s () +doDecimalCharacterReference x @ Lexer {..} = do + c <- nextWord x + if | chrASCIIDigit c -> do + uref lexerCode $ \y -> 10 * y + (fromIntegral c - 0x30) + doDecimalCharacterReference x + | c == chrSemicolon -> do + doNumericCharacterReferenceEnd x + | otherwise -> do + parseError x "missing-semicolon-after-character-reference" + backWord x + doNumericCharacterReferenceEnd x + +-- 12.2.5.80 Numeric character reference end state +doNumericCharacterReferenceEnd :: Lexer s -> ST s () +doNumericCharacterReferenceEnd x @ Lexer {..} = do + c <- rref lexerCode + let n = fromIntegral c + if | c == 0 -> do + parseError x "null-character-reference" + wref lexerCode 0xFFFD + | c > 0x10FFFF -> do + parseError x "character-reference-outside-unicode-range" + wref lexerCode 0xFFFD + | chrSurrogate c -> do + parseError x "surrogate-character-reference" + wref lexerCode 0xFFFD + | chrNonCharacter c -> do + parseError x "noncharacter-character-reference" + | c == 0x0D || (chrWord8 c && chrControl n && not (chrWhitespace n)) -> do + parseError x "control-character-reference" + whenJust (Map.lookup c codeMap) $ wref lexerCode + | otherwise -> + pure () + bufferReset lexerBuffer + forM_ (chrUTF8 c) $ flip bufferAppend lexerBuffer + flushCodePoints x + returnState x + +-- | Character code map. +codeMap :: Map Int Int +codeMap = Map.fromList + [ (0x80, 0x20AC) + , (0x82, 0x201A) + , (0x83, 0x0192) + , (0x84, 0x201E) + , (0x85, 0x2026) + , (0x86, 0x2020) + , (0x87, 0x2021) + , (0x88, 0x02C6) + , (0x89, 0x2030) + , (0x8A, 0x0160) + , (0x8B, 0x2039) + , (0x8C, 0x0152) + , (0x8E, 0x017D) + , (0x91, 0x2018) + , (0x92, 0x2019) + , (0x93, 0x201C) + , (0x94, 0x201D) + , (0x95, 0x2022) + , (0x96, 0x2013) + , (0x97, 0x2014) + , (0x98, 0x02DC) + , (0x99, 0x2122) + , (0x9A, 0x0161) + , (0x9B, 0x203A) + , (0x9C, 0x0153) + , (0x9E, 0x017E) + , (0x9F, 0x0178) + ] diff --git a/src/Zenacy/HTML/Internal/Oper.hs b/src/Zenacy/HTML/Internal/Oper.hs new file mode 100644 --- /dev/null +++ b/src/Zenacy/HTML/Internal/Oper.hs @@ -0,0 +1,533 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Defines operations on html data types. +module Zenacy.HTML.Internal.Oper + ( htmlNodeIsElem + , htmlNodeIsText + , htmlNodeContent + , htmlNodeContentSet + , htmlNodeShow + , htmlNodeFind + , htmlNodeCount + , htmlNodeCountM + , htmlTextSpace + , htmlTextAppend + , htmlTextPrepend + , htmlAttrHasName + , htmlAttrRename + , htmlElemAttr + , htmlElemAttrCount + , htmlElemAttrFind + , htmlElemAttrFindName + , htmlElemAttrApply + , htmlElemAttrFilter + , htmlElemAttrMap + , htmlElemHasAttr + , htmlElemHasAttrName + , htmlElemHasAttrVal + , htmlElemHasAttrValInfix + , htmlElemAddAttr + , htmlElemSetAttr + , htmlElemGetAttr + , htmlElemAttrRemove + , htmlElemRemoveAllAttr + , htmlElemAttrRename + , htmlElemID + , htmlElemIDSet + , htmlElemHasID + , htmlElemFindID + , htmlElemClass + , htmlElemClassSet + , htmlElemClasses + , htmlElemClassesSet + , htmlElemClassesAdd + , htmlElemClassesRemove + , htmlElemClassesContains + , htmlElemStyle + , htmlElemStyles + , htmlElemStyleParseURL + , htmlElemContent + , htmlElemContentSet + , htmlElemHasContent + , htmlElemNodeFirst + , htmlElemNodeLast + , htmlElemNodeCount + , htmlElemName + , htmlElemHasName + , htmlElemRename + , htmlElemFindElem + , htmlElemFindElemNamed + , htmlElemHasElem + , htmlElemHasElemNamed + , htmlElemContentApply + , htmlElemContentMap + , htmlElemContentFilter + , htmlElemSearch + , htmlElemText + , htmlDocHtml + , htmlDocBody + , htmlDocHead + , htmlDocTitle + , htmlMapElem + , htmlMapElemM + , htmlElemCollapse + , htmlElemCollapseM + ) where + +import Zenacy.HTML.Internal.Core +import Zenacy.HTML.Internal.HTML +import Control.Monad + ( (>=>) + ) +import Control.Monad.Extra as X + ( whenJust + , whenJustM + , concatMapM + , ifM + ) +-- import Control.Monad.Identity +-- ( runIdentity +-- ) +import Data.Char + ( isSpace + ) +import Data.Functor.Identity + ( runIdentity + ) +import Data.List + ( find + ) +import Data.List.Extra + ( firstJust + ) +import Data.Map + ( Map + ) +import qualified Data.Map as Map + ( empty + , fromList + , lookup + ) +import Data.Maybe + ( listToMaybe + , isJust + ) +import Data.Monoid + ( (<>) + ) +import Data.Set + ( Set + ) +import qualified Data.Set as Set + ( delete + , empty + , fromList + , insert + , member + , notMember + , toList + , union + , unions + ) +import Data.Text + ( Text + ) +import qualified Data.Text as T + ( all + , append + , breakOn + , concat + , drop + , dropAround + , empty + , isInfixOf + , isPrefixOf + , null + , split + , splitOn + , strip + , words + , unwords + ) +import Data.Tuple.Extra + ( first + , second + ) + +-- | Determines if a node is an element node. +htmlNodeIsElem :: HTMLNode -> Bool +htmlNodeIsElem HTMLElement {} = True +htmlNodeIsElem _ = False + +-- | Determines if a node is a text node. +htmlNodeIsText :: HTMLNode -> Bool +htmlNodeIsText HTMLText {} = True +htmlNodeIsText _ = False + +-- | Gets the content of a node. +htmlNodeContent :: HTMLNode -> [HTMLNode] +htmlNodeContent (HTMLDocument _ c) = c +htmlNodeContent (HTMLFragment _ c) = c +htmlNodeContent (HTMLElement _ _ _ c) = c +htmlNodeContent _ = [] + +-- | Sets the content of a node. +htmlNodeContentSet :: [HTMLNode] -> HTMLNode -> HTMLNode +htmlNodeContentSet x (HTMLDocument n c) = HTMLDocument n x +htmlNodeContentSet x (HTMLFragment n c) = HTMLFragment n x +htmlNodeContentSet x (HTMLElement n s a c) = HTMLElement n s a x +htmlNodeContentSet x y = y + +-- | Shows the node without its content. +htmlNodeShow :: HTMLNode -> String +htmlNodeShow = show . htmlNodeContentSet [] + +-- | Finds a child node using a predicate. +htmlNodeFind :: (HTMLNode -> Bool) -> HTMLNode -> Maybe HTMLNode +htmlNodeFind p x = find p $ htmlNodeContent x + +-- | Counts the number of nodes matching a predicate. +htmlNodeCount :: (HTMLNode -> Bool) -> HTMLNode -> Int +htmlNodeCount f = runIdentity . htmlNodeCountM (pure . f) + +-- | Counts the number of nodes matching a predicate. +htmlNodeCountM :: Monad m => (HTMLNode -> m Bool) -> HTMLNode -> m Int +htmlNodeCountM f x = do + n <- sum <$> mapM (htmlNodeCountM f) (htmlNodeContent x) + ifM (f x) (pure $ 1 + n) (pure n) + +-- | Determines if a node is a text node containing only whitespace. +htmlTextSpace :: HTMLNode -> Bool +htmlTextSpace (HTMLText x) = T.all isSpace x +htmlTextSpace _ = False + +-- | Appends text to a text node. +htmlTextAppend :: Text -> HTMLNode -> HTMLNode +htmlTextAppend a (HTMLText x) = HTMLText $ T.append x a +htmlTextAppend a x = x + +-- | Prepends text to a text node. +htmlTextPrepend :: Text -> HTMLNode -> HTMLNode +htmlTextPrepend a (HTMLText x) = HTMLText $ T.append a x +htmlTextPrepend a x = x + +-- | A predicate for checking attribute names. +htmlAttrHasName :: Text -> HTMLAttr -> Bool +htmlAttrHasName x a = x == htmlAttrName a + +-- | Renames an attribute. +htmlAttrRename :: Text -> HTMLAttr -> HTMLAttr +htmlAttrRename x (HTMLAttr n v s) = HTMLAttr x v s + +-- | Gets the attributes for an element. +htmlElemAttr :: HTMLNode -> [HTMLAttr] +htmlElemAttr (HTMLElement _ _ a _) = a +htmlElemAttr _ = [] + +-- | Gets the number of attributes for an element. +htmlElemAttrCount :: HTMLNode -> Int +htmlElemAttrCount = length . htmlElemAttr + +-- | Finds an attribute for an element. +htmlElemAttrFind :: (HTMLAttr -> Bool) -> HTMLNode -> Maybe HTMLAttr +htmlElemAttrFind f (HTMLElement _ _ a _) = find f a +htmlElemAttrFind _ _ = Nothing + +-- | Finds an attribute by name for an element. +htmlElemAttrFindName :: Text -> HTMLNode -> Maybe HTMLAttr +htmlElemAttrFindName x = htmlElemAttrFind $ htmlAttrHasName x + +-- | Applies a function to the attributes for an element. +htmlElemAttrApply :: ([HTMLAttr] -> [HTMLAttr]) -> HTMLNode -> HTMLNode +htmlElemAttrApply f (HTMLElement n s a c) = HTMLElement n s (f a) c +htmlElemAttrApply _ x = x + +-- | Filters the attributes for an element. +htmlElemAttrFilter :: (HTMLAttr -> Bool) -> HTMLNode -> HTMLNode +htmlElemAttrFilter f = htmlElemAttrApply $ filter f + +-- | Maps an endofunctor over an element attributes. +htmlElemAttrMap :: (HTMLAttr -> HTMLAttr) -> HTMLNode -> HTMLNode +htmlElemAttrMap f = htmlElemAttrApply $ map f + +-- | Determines if the element has attributes. +htmlElemHasAttr :: HTMLNode -> Bool +htmlElemHasAttr x = htmlElemAttrCount x > 0 + +-- | Determines if an element has an attribute. +htmlElemHasAttrName :: Text -> HTMLNode -> Bool +htmlElemHasAttrName x = isJust . htmlElemAttrFindName x + +-- | Determines if an element has an attribute value. +htmlElemHasAttrVal :: Text -> Text -> HTMLNode -> Bool +htmlElemHasAttrVal x y z = + maybe False (\a -> y == htmlAttrVal a) $ htmlElemAttrFindName x z + +-- | Determines if an element has part of an attribute value. +htmlElemHasAttrValInfix :: Text -> Text -> HTMLNode -> Bool +htmlElemHasAttrValInfix x y z = + maybe False (\a -> y `T.isInfixOf` htmlAttrVal a) $ htmlElemAttrFindName x z + +-- | Adds an attribute to an element. +htmlElemAddAttr :: HTMLAttr -> HTMLNode -> HTMLNode +htmlElemAddAttr x (HTMLElement n s a c) = HTMLElement n s (a <> [x]) c +htmlElemAddAttr x y = y + +-- | Sets an attribute value. +htmlElemSetAttr :: Text -> Text -> HTMLNode -> HTMLNode +htmlElemSetAttr x v n = + if htmlElemHasAttrName x n + then htmlElemAttrMap f n + else htmlElemAddAttr (htmlAttr x v) n + where + f a@(HTMLAttr an av as) = + if an == x then (HTMLAttr an v as) else a + +-- | Gets an attribute value. +htmlElemGetAttr :: Text -> HTMLNode -> Maybe Text +htmlElemGetAttr x n = htmlAttrVal <$> htmlElemAttrFindName x n + +-- | Removes an attribute from an element. +htmlElemAttrRemove :: Text -> HTMLNode -> HTMLNode +htmlElemAttrRemove x (HTMLElement n s a c) = HTMLElement n s a' c + where a' = filter (\y -> htmlAttrName y /= x) a +htmlElemAttrRemove x y = y + +-- | Removes all attributes from an element. +htmlElemRemoveAllAttr :: HTMLNode -> HTMLNode +htmlElemRemoveAllAttr (HTMLElement n s a c) = HTMLElement n s [] c +htmlElemRemoveAllAttr x = x + +-- | Renames an attribute for an element. +htmlElemAttrRename :: Text -> Text -> HTMLNode -> HTMLNode +htmlElemAttrRename old new = htmlElemAttrMap rename + where + rename x = + if htmlAttrHasName old x + then htmlAttrRename new x + else x + +-- | Gets the id attribute for an element. +htmlElemID :: HTMLNode -> Maybe Text +htmlElemID = htmlElemGetAttr "id" + +-- | Sets the id attribute for an element. +htmlElemIDSet :: Text -> HTMLNode -> HTMLNode +htmlElemIDSet = htmlElemSetAttr "id" + +-- | Determines if an element has an id. +htmlElemHasID :: Text -> HTMLNode -> Bool +htmlElemHasID x y = htmlElemID y == Just x + +-- | Searches for an element with an id. +htmlElemFindID :: Text -> HTMLNode -> Maybe HTMLNode +htmlElemFindID x = htmlElemSearch $ htmlElemHasID x + +-- | Gets the id attribute for an element. +htmlElemClass :: HTMLNode -> Maybe Text +htmlElemClass = htmlElemGetAttr "class" + +-- | Sets the class attribute for an element. +htmlElemClassSet :: Text -> HTMLNode -> HTMLNode +htmlElemClassSet = htmlElemSetAttr "class" + +-- | Gets the element classes. +htmlElemClasses :: HTMLNode -> Set Text +htmlElemClasses = maybe Set.empty (Set.fromList . T.words) . htmlElemClass + +-- | Sets the element classes. +htmlElemClassesSet :: Set Text -> HTMLNode -> HTMLNode +htmlElemClassesSet s = htmlElemClassSet (T.unwords $ Set.toList s) + +-- | Adds the class to the element's classes. +htmlElemClassesAdd :: Text -> HTMLNode -> HTMLNode +htmlElemClassesAdd c x = + htmlElemClassesSet (Set.insert c $ htmlElemClasses x) x + +-- | Removes a class from the element's classes. +htmlElemClassesRemove :: Text -> HTMLNode -> HTMLNode +htmlElemClassesRemove c x = + htmlElemClassesSet (Set.delete c $ htmlElemClasses x) x + +-- | Determines if the element contains a class. +htmlElemClassesContains :: Text -> HTMLNode -> Bool +htmlElemClassesContains c = Set.member c . htmlElemClasses + +-- | Gets the style attribute for an element. +htmlElemStyle :: HTMLNode -> Maybe Text +htmlElemStyle = htmlElemGetAttr "style" + +-- | Gets the styles for an element. +htmlElemStyles :: HTMLNode -> Map Text Text +htmlElemStyles = + maybe Map.empty parse . htmlElemStyle + where + parse = + ( Map.fromList + . map + ( first T.strip + . second T.strip + . second (T.drop 1) + . T.breakOn ":" + ) + . filter (not . T.null) + . map T.strip + . T.splitOn ";" + ) + +-- | Parses and returns a url style value. +htmlElemStyleParseURL :: Text -> Maybe Text +htmlElemStyleParseURL x + | "url" `T.isPrefixOf` x = + ( T.strip + . T.dropAround (=='\'') + -- Only a stylesheet can have a double quote, but we check for it anyway. + . T.dropAround (=='\"') + . T.strip + ) <$> textExtract "(" ")" x + | otherwise = Nothing + +-- | Gets the children for the element if the node is an element. +htmlElemContent :: HTMLNode -> [HTMLNode] +htmlElemContent (HTMLElement _ _ _ c) = c +htmlElemContent _ = [] + +-- | Sets the content for an element. +htmlElemContentSet :: [HTMLNode] -> HTMLNode -> HTMLNode +htmlElemContentSet x (HTMLElement n s a c) = HTMLElement n s a x +htmlElemContentSet x y = y + +-- | Determines if the element has children. +htmlElemHasContent :: HTMLNode -> Bool +htmlElemHasContent (HTMLElement _ _ _ []) = False +htmlElemHasContent (HTMLElement _ _ _ (x:xs)) = True +htmlElemHasContent _ = False + +-- | Gets the first child for an element. +htmlElemNodeFirst :: HTMLNode -> Maybe HTMLNode +htmlElemNodeFirst = listToMaybe . htmlElemContent + +-- | Gets the last child for an element. +htmlElemNodeLast :: HTMLNode -> Maybe HTMLNode +htmlElemNodeLast = listToMaybe . reverse . htmlElemContent + +-- | Gets the number of children for an element. +htmlElemNodeCount :: HTMLNode -> Int +htmlElemNodeCount = length . htmlElemContent + +-- | Gets the name of an element. +htmlElemName :: HTMLNode -> Text +htmlElemName (HTMLElement n _ _ _) = n +htmlElemName _ = T.empty + +-- | Checks if the name of an element matches a specified name. +htmlElemHasName :: Text -> HTMLNode -> Bool +htmlElemHasName x y = htmlElemName y == x + +-- | Sets the name of an element. +htmlElemRename :: Text -> HTMLNode -> HTMLNode +htmlElemRename n (HTMLElement _ s a c) = HTMLElement n s a c +htmlElemRename n x = x + +-- | Finds a child element using a predicate. +htmlElemFindElem :: (HTMLNode -> Bool) -> HTMLNode -> Maybe HTMLNode +htmlElemFindElem p (HTMLElement _ _ _ c) = find p c +htmlElemFindElem _ _ = Nothing + +-- | Finds a child element with a specified name. +htmlElemFindElemNamed :: Text -> HTMLNode -> Maybe HTMLNode +htmlElemFindElemNamed x = htmlElemFindElem $ htmlElemHasName x + +-- | Determines if an element has a child. +htmlElemHasElem :: (HTMLNode -> Bool) -> HTMLNode -> Bool +htmlElemHasElem p = isJust . htmlElemFindElem p + +-- | Determines if an element has a child. +htmlElemHasElemNamed :: Text -> HTMLNode -> Bool +htmlElemHasElemNamed x = isJust . htmlElemFindElemNamed x + +-- | Modifies an elements children by applying a function. +htmlElemContentApply :: ([HTMLNode] -> [HTMLNode]) -> HTMLNode -> HTMLNode +htmlElemContentApply f (HTMLElement n s a c) = HTMLElement n s a $ f c +htmlElemContentApply _ x = x + +-- | Modifies an elements children by mapping a function over them. +htmlElemContentMap :: (HTMLNode -> HTMLNode) -> HTMLNode -> HTMLNode +htmlElemContentMap f = htmlElemContentApply $ map f + +-- | Modifies an elements children by filtering them. +htmlElemContentFilter :: (HTMLNode -> Bool) -> HTMLNode -> HTMLNode +htmlElemContentFilter f = htmlElemContentApply $ filter f + +-- | Finds an element using a depth-first search. +htmlElemSearch :: (HTMLNode -> Bool) -> HTMLNode -> Maybe HTMLNode +htmlElemSearch f x = case x of + HTMLElement _ _ _ c -> + if f x then Just x else firstJust (htmlElemSearch f) c + _otherwise -> Nothing + +-- | Gets the text content for an element. +htmlElemText :: HTMLNode -> Maybe Text +htmlElemText (HTMLElement n s a c) = + case filter htmlNodeIsText c of + a@(x:xs) -> Just . T.concat . map htmlTextData $ a + [] -> Nothing +htmlElemText _ = Nothing + +-- | Finds the html element given a document. +htmlDocHtml :: HTMLNode -> Maybe HTMLNode +htmlDocHtml = htmlNodeFind $ htmlElemHasName "html" + +-- | Finds the body element given a document. +htmlDocBody :: HTMLNode -> Maybe HTMLNode +htmlDocBody = htmlDocHtml >=> htmlElemFindElemNamed "body" + +-- | Finds the head element given a document. +htmlDocHead :: HTMLNode -> Maybe HTMLNode +htmlDocHead = htmlDocHtml >=> htmlElemFindElemNamed "head" + +-- | Finds the title for a document. +htmlDocTitle :: HTMLNode -> Maybe Text +htmlDocTitle = htmlDocHead + >=> htmlElemFindElemNamed "title" + >=> htmlElemText + +-- | Maps a function over all the elements defined by a node. +htmlMapElem :: (HTMLNode -> HTMLNode) -> HTMLNode -> HTMLNode +htmlMapElem f = runIdentity . htmlMapElemM (pure . f) + +-- | Maps a function over all the elements defined by a node. +htmlMapElemM :: Monad m => (HTMLNode -> m HTMLNode) -> HTMLNode -> m HTMLNode + +-- htmlMapElemM f x@(HTMLElement {}) = do +-- HTMLElement n s a c <- f x +-- HTMLElement n s a <$> mapM (htmlMapElemM f) c +-- htmlMapElemM f x = pure x + +htmlMapElemM f x = + case x of + HTMLElement {} -> do + a <- f x + case a of + HTMLElement n s a c -> + HTMLElement n s a <$> mapM (htmlMapElemM f) c + _otherwise -> + pure a + _otherwise -> + pure x + +-- | Collapses a tree of elements based on a predicate. +htmlElemCollapse :: (HTMLNode -> Bool) -> HTMLNode -> [HTMLNode] +htmlElemCollapse f = runIdentity . htmlElemCollapseM (pure . f) + +-- | Collapses a tree of elements based on a predicate. +htmlElemCollapseM :: Monad m => (HTMLNode -> m Bool) -> HTMLNode -> m [HTMLNode] +htmlElemCollapseM f x@(HTMLElement n s a c) = do + c' <- concatMapM (htmlElemCollapseM f) c + ifM (f x) (pure c') $ pure [ HTMLElement n s a c' ] +htmlElemCollapseM _ x = pure [x] diff --git a/src/Zenacy/HTML/Internal/Parser.hs b/src/Zenacy/HTML/Internal/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Zenacy/HTML/Internal/Parser.hs @@ -0,0 +1,3290 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | The HTML parser. +module Zenacy.HTML.Internal.Parser + ( Parser(..) + , ParserOptions(..) + , ParserResult(..) + , parseDocument + , parseFragment + ) where + +import Zenacy.HTML.Internal.BS +import Zenacy.HTML.Internal.Buffer +import Zenacy.HTML.Internal.Char +import Zenacy.HTML.Internal.Core +import Zenacy.HTML.Internal.DOM +import Zenacy.HTML.Internal.Lexer +import Zenacy.HTML.Internal.Token +import Zenacy.HTML.Internal.Types + +import Control.Applicative + ( liftA + ) +import Control.Monad + ( when + , unless + , void + ) +import Control.Monad.Extra + ( (||^) + , (&&^) + , anyM + , notM + , whenM + , whenJustM + , unlessM + ) +import Control.Monad.ST + ( ST + , runST + ) +import Data.Default + ( Default(..) + ) +import Data.DList + ( DList + ) +import qualified Data.DList as D + ( append + , empty + , snoc + , toList + ) +import Data.IntMap + ( IntMap + ) +import qualified Data.IntMap as IntMap + ( findWithDefault + , lookup + , insert + , map + , mapWithKey + ) +import Data.List + ( find + ) +import Data.Map + ( Map + ) +import qualified Data.Map as Map + ( fromList + , lookup + ) +import Data.Maybe + ( fromJust + , isJust + , isNothing + , listToMaybe + , mapMaybe + ) +import Data.Monoid + ( (<>) + ) +import Data.Sequence + ( Seq + ) +import qualified Data.Sequence as Seq + ( fromList + ) +import Data.Set + ( Set + ) +import qualified Data.Set as Set + ( fromList + , member + , notMember + , union + , unions + ) +import Data.STRef + ( STRef + , newSTRef + , readSTRef + , writeSTRef + ) +import Data.Word + ( Word8 + ) + +-- | Parser processing state. +data Parser s = Parser + { parserLexer :: STRef s (Lexer s) + -- ^ The lexer for token generation. + , parserDOM :: STRef s DOM + -- ^ The parser DOM. + , parserElementStack :: STRef s [DOMID] + -- ^ The element stack (section 12.2.3.2). + , parserActiveFormatList :: STRef s [ParserFormatItem] + -- ^ The list of action formatting elements (section 12.2.3.3). + , parserInsertionMode :: STRef s ParserMode + -- ^ The current insertion mode. + , parserOriginalMode :: STRef s ParserMode + -- ^ The original insertion mode. + , parserTemplateMode :: STRef s [ParserMode] + -- ^ The template insertion mode. + , parserContextElement :: STRef s (Maybe DOMID) + -- ^ The context element. + , parserHeadElement :: STRef s (Maybe DOMID) + -- ^ The head element pointer (section 12.2.3.4). + , parserFormElement :: STRef s (Maybe DOMID) + -- ^ The form element pointer (section 12.2.3.4). + , parserSelfClosingFlag :: STRef s Bool + -- ^ The self closing acknowledges flag. + , parserFragmentMode :: STRef s Bool + -- ^ The flag indicating parser is in fragment mode. + , parserFosterParenting :: STRef s Bool + -- ^ The foster parenting flag. + , parserFrameSetOK :: STRef s Bool + -- ^ The frame-set ok flag (section 12.2.3.5). + , parserDone :: STRef s Bool + -- ^ The parser done flag. + , parserTableChars :: STRef s [Token] + -- ^ The pending table characters. + , parserAdoptionAgency :: STRef s (ParserAdoptionAgency s) + -- ^ The adoption agency state. + , parserErrors :: STRef s (DList BS) + -- ^ The parser errors. + , parserIFrameSrcDoc :: STRef s Bool + -- ^ Indicates that the documnet is an iframe srcdoc. + , parserTextMap :: STRef s (IntMap (STRef s (Buffer s))) + -- ^ Map of buffers for holding dom strings. + , parserLogErrors :: Bool + -- ^ Flag to log errors. + } + +-- | Defines the parser mode. +data ParserMode + = ModeInitial + | ModeBeforeHtml + | ModeBeforeHead + | ModeInHead + | ModeInHeadNoscript + | ModeAfterHead + | ModeInBody + | ModeText + | ModeInTable + | ModeInTableText + | ModeInCaption + | ModeInColumnGroup + | ModeInTableBody + | ModeInRow + | ModeInCell + | ModeInSelect + | ModeInSelectInTable + | ModeInTemplate + | ModeAfterBody + | ModeInFrameset + | ModeAfterFrameset + | ModeAfterAfterBody + | ModeAfterAfterFrameset + deriving (Eq, Ord, Show) + +-- | Parser options type. +data ParserOptions = ParserOptions + { parserOptionInput :: BS + -- ^ The input to the lexer. + , parserOptionLogErrors :: Bool + -- ^ Indicates whether warnings are logged. + , parserOptionIgnoreEntities :: Bool + -- ^ Indicates that entities should not be tokenized. + } deriving (Eq, Ord, Show) + +-- | Parser result type. +data ParserResult = ParserResult + { parserResultDOM :: DOM + , parserResultErrors :: [BS] + } deriving (Eq, Ord, Show) + +-- | Defines an item in the list of active formatting elements. +data ParserFormatItem + = ParserFormatElement DOMID Token + | ParserFormatMarker + deriving (Eq, Ord, Show) + +-- | Defines element categories. +data ParserElementCategory + = ElementCategorySpecial + | ElementCategoryFormatting + | ElementCategoryOrdinary + deriving (Eq, Ord, Show) + +-- | Defines detailed information for stack elements. +data ElementDetails = ElementDetails + { elementDetailsIndex :: Int + , elementDetailsID :: DOMID + , elementDetailsNode :: DOMNode + , elementDetailsType :: DOMType + } deriving (Eq, Ord, Show) + +-- | Default instance for parser options. +instance Default ParserOptions where + def = ParserOptions + { parserOptionInput = bsEmpty + , parserOptionLogErrors = False + , parserOptionIgnoreEntities = False + } + +-- | Default instance for parser results. +instance Default ParserResult where + def = ParserResult + { parserResultDOM = def + , parserResultErrors = [] + } + +-- | Parses an HTML document. +parseDocument :: ParserOptions -> Either BS ParserResult +parseDocument x = + runST $ do + parserNew x >>= \case + Right p -> Right <$> parserRun p + Left e -> Left <$> pure e + +-- | Parses an HTML fragment. +parseFragment :: ParserOptions -> Either BS ParserResult +parseFragment x = Left "fragment support not yet implemented" + +-- | Makes a new lexer. +parserNew :: ParserOptions -> ST s (Either BS (Parser s)) +parserNew o@ParserOptions{..} = do + a <- lexerNew def + { lexerOptionInput = parserOptionInput + , lexerOptionLogErrors = parserOptionLogErrors + , lexerOptionIgnoreEntities = parserOptionIgnoreEntities + } + case a of + Right lex -> Right <$> parserMake o lex + Left err -> Left <$> pure err + +-- | Makes a new lexer. +parserMake :: ParserOptions -> Lexer s -> ST s (Parser s) +parserMake ParserOptions{..} lexer = do + lexerRef <- newSTRef lexer + dom <- newSTRef def + stack <- newSTRef [] + fmtList <- newSTRef [] + insMode <- newSTRef ModeInitial + orgMode <- newSTRef ModeInitial + tmpMode <- newSTRef [] + ctxElem <- newSTRef Nothing + headElem <- newSTRef Nothing + formElem <- newSTRef Nothing + closing <- newSTRef False + fragMode <- newSTRef False + foster <- newSTRef False + frameSet <- newSTRef True + done <- newSTRef False + table <- newSTRef [] + aa <- defaultAA + aaRef <- newSTRef aa + warn <- newSTRef def + iframe <- newSTRef False + textMap <- newSTRef def + pure $ Parser + { parserLexer = lexerRef + , parserDOM = dom + , parserElementStack = stack + , parserActiveFormatList = fmtList + , parserInsertionMode = insMode + , parserOriginalMode = orgMode + , parserTemplateMode = tmpMode + , parserContextElement = ctxElem + , parserHeadElement = headElem + , parserFormElement = formElem + , parserSelfClosingFlag = closing + , parserFragmentMode = fragMode + , parserFosterParenting = foster + , parserFrameSetOK = frameSet + , parserDone = done + , parserTableChars = table + , parserAdoptionAgency = aaRef + , parserErrors = warn + , parserIFrameSrcDoc = iframe + , parserTextMap = textMap + , parserLogErrors = parserOptionLogErrors + } + +-- | The parser main loop. +parserRun :: Parser s -> ST s ParserResult +parserRun p @ Parser {..} = do + rref parserDone >>= \case + True -> do + Lexer{..} <- rref parserLexer + e <- D.append <$> rref lexerErrors <*> rref parserErrors + d <- textMapDOM p + pure $ ParserResult d $ D.toList e + False -> do + t <- rref parserLexer >>= lexerNext + selfClosingInit p t + dispatchTreeConstruction p t + whenM (selfClosingFlag p) $ + parseError p (Just t) "self closing not acknowledged for token" + parserRun p + +-- | Handles tree construction dispatch. +dispatchTreeConstruction :: Parser s -> Token -> ST s () +dispatchTreeConstruction p @ Parser {..} t = do + e <- elementStackEmpty p + a <- adjustedCurrentNode p + b <- pure $ case a of + Just n -> domNodeIsHTML n + || isMathMLIntegrationPoint n + && isTokenStartNotNamed t ["mglyph", "malignmark"] + || isMathMLIntegrationPoint n && tokenIsChar t + || isMathMLElementNamed n "annotation-xml" + && isTokenStartNamed t ["svg"] + || isHtmlIntgrationPoint n && tokenIsStart t + || isHtmlIntgrationPoint n && tokenIsChar t + Nothing -> False + if e || b || tokenIsEOF t + then doHtmlContent p t + else doForeignContent p t + where + tokenIsChar TChar {} = True + tokenIsChar _ = False + tokenIsStart TStart {} = True + tokenIsStart _ = False + tokenIsEOF TEOF = True + tokenIsEOF _ = False + +-- | Processes a token as HTML content. +doHtmlContent :: Parser s -> Token -> ST s () +doHtmlContent p @ Parser {..} t = do + m <- rref parserInsertionMode + parserInserter m p t + +-- | Reprocesses a token. +reprocess :: Parser s -> Token -> ST s () +reprocess = doHtmlContent + +-- | Gets the inserter for a parser mode. +parserInserter :: ParserMode -> Parser s -> Token -> ST s () +parserInserter = \case + ModeInitial -> doModeInitial + ModeBeforeHtml -> doModeBeforeHtml + ModeBeforeHead -> doModeBeforeHead + ModeInHead -> doModeInHead + ModeInHeadNoscript -> doModeInHeadNoscript + ModeAfterHead -> doModeAfterHead + ModeInBody -> doModeInBody + ModeText -> doModeText + ModeInTable -> doModeInTable + ModeInTableText -> doModeInTableText + ModeInCaption -> doModeInCaption + ModeInColumnGroup -> doModeInColumnGroup + ModeInTableBody -> doModeInTableBody + ModeInRow -> doModeInRow + ModeInCell -> doModeInCell + ModeInSelect -> doModeInSelect + ModeInSelectInTable -> doModeInSelectInTable + ModeInTemplate -> doModeInTemplate + ModeAfterBody -> doModeAfterBody + ModeInFrameset -> doModeInFrameset + ModeAfterFrameset -> doModeAfterFrameset + ModeAfterAfterBody -> doModeAfterAfterBody + ModeAfterAfterFrameset -> doModeAfterAfterFrameset + +-- | Handles parse errors. +parseError :: Parser s -> Maybe Token -> BS -> ST s () +parseError p @ Parser {..} t s = + when parserLogErrors $ + uref parserErrors $ flip D.snoc e + where + e = s <> case t of + Just (TDoctype {..}) -> ",doctype" + Just (TStart {..}) -> ",tag-start," <> tStartName + Just (TEnd {..}) -> ",tag-end," <> tEndName + Just (TComment {..}) -> ",comment" + Just (TChar {..}) -> ",chr," <> bsOnly tCharData + Just TEOF -> ",eof" + Nothing -> bsEmpty + +-- | Detmermines if a token is a start token with a specified name. +isTokenStartNamed :: Token -> [BS] -> Bool +isTokenStartNamed TStart {..} names = tStartName `elem` names +isTokenStartNamed _ _ = False + +-- | Detmermines if a token is a start token without a specified name. +isTokenStartNotNamed :: Token -> [BS] -> Bool +isTokenStartNotNamed TStart {..} names = not $ tStartName `elem` names +isTokenStartNotNamed _ _ = False + +-- | Detmermines if a token is an end token with a specified name. +isTokenEndNamed :: Token -> [BS] -> Bool +isTokenEndNamed TEnd {..} names = tEndName `elem` names +isTokenEndNamed _ _ = False + +-- | Detmermines if a token is an end token without a specified name. +isTokenEndNotNamed :: Token -> [BS] -> Bool +isTokenEndNotNamed TEnd {..} names = not $ tEndName `elem` names +isTokenEndNotNamed _ _ = False + +-- | Determines if a node name matches a name. +elementName :: BS -> DOMNode -> Bool +elementName x y = domNodeElementName y == x + +-- | Determines if a node name does not match a name. +elementNameNot :: BS -> DOMNode -> Bool +elementNameNot x = not . elementName x + +-- | Determines if a node name is in a set of names. +elementNameIn :: [BS] -> DOMNode -> Bool +elementNameIn x y = domNodeElementName y `elem` x + +-- | Determines if a node name is not in a set of names. +elementNameNotIn :: [BS] -> DOMNode -> Bool +elementNameNotIn x = not . elementNameIn x + +-- | Gets the current element stack. +elementStack :: Parser s -> ST s [DOMID] +elementStack Parser {..} = readSTRef parserElementStack + +-- | Detmermines if the element stack is empty. +elementStackEmpty :: Parser s -> ST s Bool +elementStackEmpty p @ Parser {..} = null <$> elementStack p + +-- | Returns the size of the element stack. +elementStackSize :: Parser s -> ST s Int +elementStackSize p @ Parser {..} = length <$> elementStack p + +-- | Modifies the element stack by applying a function. +elementStackModify :: Parser s -> ([DOMID] -> [DOMID]) -> ST s () +elementStackModify p @ Parser {..} f = uref parserElementStack f + +-- | Pushes an element on the element stack. +elementStackPush :: Parser s -> DOMID -> ST s () +elementStackPush p @ Parser {..} x = elementStackModify p $ (x:) + +-- | Pops an element off of the element stack. +elementStackPop :: Parser s -> ST s () +elementStackPop p @ Parser {..} = elementStackModify p $ drop 1 + +-- | Pops nodes from the element stack while a predicate is true. +elementStackPopWhile :: Parser s -> (DOMNode -> Bool) -> ST s () +elementStackPopWhile p @ Parser {..} f = + currentNode p >>= \case + Just a | f a -> elementStackPop p >> elementStackPopWhile p f + _ -> pure () + +-- | Pops a nodes from the element stack if a predicate is true. +elementStackPopIf :: Parser s -> (DOMNode -> Bool) -> ST s () +elementStackPopIf p @ Parser {..} f = + currentNode p >>= \case + Just a | f a -> elementStackPop p + _ -> pure () + +-- | Pops elements from the stack until a specified element has been popped. +elementStackPopUntil :: Parser s -> (DOMType -> Bool) -> ST s () +elementStackPopUntil p @ Parser {..} f = do + elementStackPopWhile p (not . g) + elementStackPopIf p g + where + g = f . domNodeType + +-- | Pops elements from the stack until a specified ID has been popped. +elementStackPopUntilID :: Parser s -> DOMID -> ST s () +elementStackPopUntilID p x = elementStackModify p $ drop 1 . dropWhile (/=x) + +-- | Pops elements from the stack until a specified element has been popped. +elementStackPopUntilType :: Parser s -> DOMType -> ST s () +elementStackPopUntilType p x = elementStackPopUntil p (==x) + +-- | Pops elements from the stack until a specified element has been popped. +elementStackPopUntilTypeIn :: Parser s -> [DOMType] -> ST s () +elementStackPopUntilTypeIn p x = elementStackPopUntil p $ flip elem x + +-- | Gets the current element stack as a list of nodes. +elementStackNodes :: Parser s -> ST s [DOMNode] +elementStackNodes p = domMapID <$> getDOM p <*> elementStack p + +-- | Gets the current element stack as a list of types. +elementStackTypes :: Parser s -> ST s [DOMType] +elementStackTypes p = map domNodeType <$> elementStackNodes p + +-- | Applies a predicate to the element stack and returns whether +-- any element in the stack results in a true predicate. +elementStackAny :: Parser s -> (DOMNode -> Bool) -> ST s Bool +elementStackAny p f = any f <$> elementStackNodes p + +-- | Applies a predicate to the element stack and returns whether +-- all elements in the stack result in a true predicate. +elementStackAll :: Parser s -> (DOMNode -> Bool) -> ST s Bool +elementStackAll p f = all f <$> elementStackNodes p + +-- | Determines if the second element on the stack is a body element. +elementStackHasBody :: Parser s -> ST s Bool +elementStackHasBody p = + liftA reverse (elementStackTypes p) >>= pure . \case + (_:x:_) -> x == domMakeTypeHTML "body" + _otherwise -> False + +-- | Determines if the element stack has a template element. +elementStackHasTemplate :: Parser s -> ST s Bool +elementStackHasTemplate p = elementStackAny p domNodeIsTemplate + +-- | Determines if the element stack does not have any template elements. +elementStackMissingTemplate :: Parser s -> ST s Bool +elementStackMissingTemplate p = elementStackAll p $ not . domNodeIsTemplate + +-- | Removes a node ID from the element stack. +elementStackRemove :: Parser s -> DOMID -> ST s () +elementStackRemove p x = elementStackModify p $ filter (/=x) + +-- | Replaces an ID in the element stack with another ID. +elementStackReplace :: Parser s -> DOMID -> DOMID -> ST s () +elementStackReplace p x y = + elementStackModify p $ map (\i -> if i == x then y else i) + +-- | Finds the successor for an entry in the element stack. +elementStackSucc :: Parser s -> DOMID -> ST s (Maybe DOMID) +elementStackSucc p x = findSucc (==x) <$> elementStack p + +-- | Inserts a node before another node in the element stack. +elementStackInsertBefore :: Parser s -> DOMID -> DOMID -> ST s () +elementStackInsertBefore p x y = elementStackModify p $ insertBefore (==x) y + +-- | Gets the element stack details. +elementStackDetails :: Parser s -> ST s [ElementDetails] +elementStackDetails p = g <$> getDOM p <*> elementStack p + where + g d x = mapMaybe (f d) $ zip [1..] x + f d (i, x) = + case domGetNode d x of + Nothing -> Nothing + Just a -> Just $ ElementDetails i x a $ domNodeType a + +-- | Finds element stack details. +elementStackFind :: Parser s -> (ElementDetails -> Bool) -> ST s (Maybe ElementDetails) +elementStackFind p f = liftA (find f) $ elementStackDetails p + +-- | Special element types. +elementTypesSpecial :: Set DOMType +elementTypesSpecial = Set.unions + [ Set.fromList $ domTypesHTML + [ "address", "applet", "area", "article", "aside", + "base", "basefont", "bgsound", "blockquote", "body", + "br", "button", "caption", "center", "col", "colgroup", + "dd", "details", "dir", "div", "dl", "dt", "embed", + "fieldset", "figcaption", "figure", "footer", "form", + "frame", "frameset", "h1", "h2", "h3", "h4", "h5", "h6", + "head", "header", "hgroup", "hr", "html", "iframe", + "img", "input", "isindex", "li", "link", "listing", + "main", "marquee", "menu", "menuitem", "meta", "nav", + "noembed", "noframes", "noscript", "object", "ol", + "p", "param", "plaintext", "pre", "script", "section", + "select", "source", "style", "summary", "table", + "tbody", "td", "template", "textarea", "tfoot", + "th", "thead", "title", "tr", "track", "ul", "wbr" ] + , Set.fromList $ domTypesMathML + [ "mi", "mo", "mn", "ms", "mtext", "annotation-xml" ] + , Set.fromList $ domTypesSVG + [ "foreignObject", "desc", "title" ] + ] + +-- | Formatting element types. +elementTypesFormatting :: Set DOMType +elementTypesFormatting = + Set.fromList $ domTypesHTML + [ "a", "b", "big", "code", "em", "font", "i", "nobr", + "s", "small", "strike", "strong", "tt", "u"] + +-- | Returns the element category for an element type. +elementCategory :: DOMType -> ParserElementCategory +elementCategory x + | Set.member x elementTypesSpecial = ElementCategorySpecial + | Set.member x elementTypesFormatting = ElementCategoryFormatting + | otherwise = ElementCategoryOrdinary + +-- | Detmermines if an element is in the special category. +elementIsSpecial :: DOMType -> Bool +elementIsSpecial x = elementCategory x == ElementCategorySpecial + +-- | Determines if an element is in specific scope. +-- Algorithm from section 12.2.3.2 is specification. +elementInSpecificScope :: Parser s -> Bool -> Set DOMType -> DOMType -> ST s Bool +elementInSpecificScope p include types target = + f <$> elementStackTypes p + where + f :: [DOMType] -> Bool + f [] = False + f (x:xs) + | x == target = True + | include == True && Set.member x types == True = False + | include == False && Set.member x types == False = False + | otherwise = f xs + +-- | Default element scopes. +elementScopes :: Set DOMType +elementScopes = Set.unions + [ Set.fromList $ domTypesHTML + [ "applet", "caption", "html", "table", "td", "th" + , "marquee", "object", "template" ] + , Set.fromList $ domTypesMathML + [ "mi", "mo", "mn", "ms", "mtext", "annotation-xml" ] + , Set.fromList $ domTypesSVG + [ "foreignObject", "desc", "title" ] + ] + +-- | Determines if an element is in scope. +elementInScope :: Parser s -> DOMType -> ST s Bool +elementInScope p = elementInSpecificScope p True elementScopes + +-- | Determines if an element is in list scope. +elementInListScope :: Parser s -> DOMType -> ST s Bool +elementInListScope p = + elementInSpecificScope p True $ + Set.union elementScopes $ Set.fromList $ + domTypesHTML [ "ol", "ul" ] + +-- | Determines if an element is in button scope. +elementInButtonScope :: Parser s -> DOMType -> ST s Bool +elementInButtonScope p = + elementInSpecificScope p True $ + Set.union elementScopes $ Set.fromList [ domMakeTypeHTML "button" ] + +-- | Determines if an element is in table scope. +elementInTableScope :: Parser s -> DOMType -> ST s Bool +elementInTableScope p = + elementInSpecificScope p True $ + Set.fromList $ domTypesHTML [ "html", "table", "template" ] + +-- | Determines if an element is in select scope. +elementInSelectScope :: Parser s -> DOMType -> ST s Bool +elementInSelectScope p = + elementInSpecificScope p False $ + Set.fromList $ domTypesHTML [ "optgroup", "option" ] + +-- | Creates a new ID for a node. +newID :: Parser s -> DOMNode -> ST s DOMID +newID p x = do + (d, i) <- flip domNewID x <$> getDOM p + setDOM p d + pure i + +-- | Converts a node ID to a node. +getNode :: Parser s -> DOMID -> ST s (Maybe DOMNode) +getNode p @ Parser {..} x = flip domGetNode x <$> getDOM p + +-- -- | Gets the element name for a node ID. +nodeElementName :: Parser s -> DOMID -> ST s BS +nodeElementName p @ Parser {..} x = do + d <- getDOM p + pure $ case domGetNode d x of + Just a -> domNodeElementName a + Nothing -> bsEmpty + +-- | Gets the last node ID. +lastNodeID :: Parser s -> ST s (Maybe DOMID) +lastNodeID p @ Parser {..} = listToMaybe . reverse <$> elementStack p + +-- | Gets the current node ID. +currentNodeID :: Parser s -> ST s (Maybe DOMID) +currentNodeID p @ Parser {..} = listToMaybe <$> elementStack p + +-- | Gets the current node. +currentNode :: Parser s -> ST s (Maybe DOMNode) +currentNode p = currentNodeID p >>= maybe (pure Nothing) (getNode p) + +-- | Determines if the current node has a specified type. +currentNodeHasType :: Parser s -> DOMType -> ST s Bool +currentNodeHasType p x = + currentNode p >>= pure . \case + Just a -> domNodeType a == x + Nothing -> False + +-- | Determines if the current node has a specified type. +currentNodeHasHTMLType :: Parser s -> BS -> ST s Bool +currentNodeHasHTMLType p = currentNodeHasType p . domMakeTypeHTML + +-- | Determines if the current node has a specified type. +currentNodeHasTypeIn :: Parser s -> [DOMType] -> ST s Bool +currentNodeHasTypeIn p x = + currentNode p >>= pure . \case + Just a -> domNodeType a `elem` x + Nothing -> False + +-- | Determines if the current node has a specified type. +currentNodeHasHTMLTypeIn :: Parser s -> [BS] -> ST s Bool +currentNodeHasHTMLTypeIn p = currentNodeHasTypeIn p . domTypesHTML + +-- | Gets the adjusted current node ID. +adjustedCurrentNodeID :: Parser s -> ST s (Maybe DOMID) +adjustedCurrentNodeID p @ Parser {..} = do + f <- rref parserFragmentMode + n <- elementStackSize p + if f && n == 1 + then rref parserContextElement + else currentNodeID p + +-- | Gets the adjusted current node. +adjustedCurrentNode :: Parser s -> ST s (Maybe DOMNode) +adjustedCurrentNode p = + adjustedCurrentNodeID p >>= maybe (pure Nothing) (getNode p) + +-- | Determines if a node is a named MathML element. +isMathMLElementNamed :: DOMNode -> BS -> Bool +isMathMLElementNamed x n = domNodeIsMathML x && domElementName x == n + +-- | Determines if a node is a MathML integration point. +isMathMLIntegrationPoint :: DOMNode -> Bool +isMathMLIntegrationPoint x + | domNodeIsElement x = + domNodeIsMathML x && Set.member (domElementName x) s + | otherwise = + False + where + s = Set.fromList [ "mi", "mo", "mn", "ms", "mtext" ] + +-- | Determines if a node is a MathML integration point. +isHtmlIntgrationPoint :: DOMNode -> Bool +isHtmlIntgrationPoint x + | domNodeIsElement x = s || m + | otherwise = False + where + s = domNodeIsSVG x + && Set.member (domElementName x) s0 + m = domNodeIsMathML x + && domElementName x == "annotation-xml" + && case domElementFindAttr x "encoding" of + Just (DOMAttr n v s) -> + Set.member (bsLower v) s1 + _otherwise -> False + s0 = Set.fromList [ "foreignObject", "desc", "title" ] + s1 = Set.fromList [ "text/html", "application/xhtml+xml" ] + +-- | Gets the DOM. +getDOM :: Parser s -> ST s DOM +getDOM Parser {..} = rref parserDOM + +-- | Sets the DOM. +setDOM :: Parser s -> DOM -> ST s () +setDOM Parser {..} = wref parserDOM + +-- | Modifies the DOM. +modifyDOM :: Parser s -> (DOM -> DOM) -> ST s () +modifyDOM p @ Parser {..} = uref parserDOM + +-- | Sets the insertion mode. +setMode :: Parser s -> ParserMode -> ST s () +setMode Parser {..} = wref parserInsertionMode + +-- | Saves the mode as the original mode. +saveMode :: Parser s -> ST s () +saveMode Parser {..} = rref parserInsertionMode >>= wref parserOriginalMode + +-- | Restore the insertion mode from the saved original mode. +restoreMode :: Parser s -> ST s () +restoreMode Parser {..} = do + rref parserOriginalMode >>= wref parserInsertionMode + wref parserOriginalMode ModeInitial + +-- | Sets the current head element. +setHeadID :: Parser s -> Maybe DOMID -> ST s () +setHeadID Parser {..} = wref parserHeadElement + +-- | Gets the current head element. +getHeadID :: Parser s -> ST s (Maybe DOMID) +getHeadID Parser {..} = rref parserHeadElement + +-- | Gets the current head element. +getHeadElement :: Parser s -> ST s (Maybe DOMNode) +getHeadElement p = getHeadID p >>= maybe (pure Nothing) (getNode p) + +-- | Saves the current node as the head element. +saveHead :: Parser s -> ST s () +saveHead p = currentNodeID p >>= setHeadID p + +-- | Sets the current form element. +setFormID :: Parser s -> Maybe DOMID -> ST s () +setFormID Parser {..} = wref parserFormElement + +-- | Gets the current form element ID. +getFormID :: Parser s -> ST s (Maybe DOMID) +getFormID Parser {..} = rref parserFormElement + +-- | Gets the current form element. +getFormElement :: Parser s -> ST s (Maybe DOMNode) +getFormElement p = getFormID p >>= maybe (pure Nothing) (getNode p) + +-- | Gets the current form element type. +getFormType :: Parser s -> ST s (Maybe DOMType) +getFormType p @ Parser {..} = + getFormElement p >>= pure . maybe Nothing (Just . domNodeType) + +-- | Saves the current node as the form element. +saveForm :: Parser s -> ST s () +saveForm p = currentNodeID p >>= setFormID p + +-- | Determines if the form element reference is defined. +formNotNull :: Parser s -> ST s Bool +formNotNull p = isJust <$> getFormID p + +-- | Initializes the self closing flag. +selfClosingInit :: Parser s -> Token -> ST s () +selfClosingInit p @ Parser {..} t = + wref parserSelfClosingFlag $ + case t of + TStart {..} -> tStartClosed + _otherwise -> False + +-- | Acknowledges the parser self closing flag. +selfClosingAcknowledge :: Parser s -> ST s () +selfClosingAcknowledge Parser {..} = wref parserSelfClosingFlag False + +-- | Gets the self closing flag. +selfClosingFlag :: Parser s -> ST s Bool +selfClosingFlag Parser {..} = rref parserSelfClosingFlag + +-- | Gets the foster parenting flag. +fosterParenting :: Parser s -> ST s Bool +fosterParenting Parser {..} = rref parserFosterParenting + +-- | Sets the foster parenting flag. +fosterParentingSet :: Parser s -> ST s () +fosterParentingSet Parser {..} = wref parserFosterParenting True + +-- | Clear the foster parenting flag. +fosterParentingClear :: Parser s -> ST s () +fosterParentingClear Parser {..} = wref parserFosterParenting False + +-- | Sets the frameset flag to not OK. +frameSetNotOK :: Parser s -> ST s () +frameSetNotOK Parser {..} = wref parserFrameSetOK False + +-- | Gets the iframe srcdoc flag. +iframeSrcDoc :: Parser s -> ST s Bool +iframeSrcDoc Parser {..} = rref parserIFrameSrcDoc + +-- | Sets the done flag. +parserSetDone :: Parser s -> ST s () +parserSetDone Parser {..} = wref parserDone True + +-- | Gets the active format list. +activeFormatList :: Parser s -> ST s [ParserFormatItem] +activeFormatList Parser {..} = rref parserActiveFormatList + +-- | Gets the names of the active format elements. +activeFormatNames :: Parser s -> ST s [BS] +activeFormatNames p = do + d <- getDOM p + map (f d) <$> activeFormatList p + where f d ParserFormatMarker = "marker" + f d (ParserFormatElement i t) = + domElementName $ fromJust $ domGetNode d i + +-- | Adds a marker to the list of active format elements. +activeFormatAddMarker :: Parser s -> ST s () +activeFormatAddMarker Parser {..} = + uref parserActiveFormatList (ParserFormatMarker:) + +-- | Adds an element to the list of active format elements. +activeFormatAddElement :: Parser s -> Token -> DOMID -> ST s () +activeFormatAddElement p @ Parser {..} t x = do + d <- getDOM p + a <- activeFormatList p + let match (ParserFormatElement y _) = domMatch d x y + b = takeWhile (not . formatItemIsMarker) a + n = (foldr (\i z -> z + if match i then 1 else 0) 0 b) :: Int + a' = if n < 3 then a else removeFirst match a + e' = ParserFormatElement x t : a' + wref parserActiveFormatList e' + +-- | Adds the current node to the list of active format elements. +activeFormatAddCurrentNode :: Parser s -> Token -> ST s () +activeFormatAddCurrentNode p @ Parser {..} t = + whenJustM (currentNodeID p) $ activeFormatAddElement p t + +-- | Determines if any format elements up to a marker satisfy a predicate. +activeFormatAny :: Parser s -> (DOMNode -> Bool) -> ST s Bool +activeFormatAny p @ Parser {..} f = do + d <- getDOM p + a <- activeFormatList p + pure $ + ( any f + . domMapID d + . map (\(ParserFormatElement x _) -> x) + . takeWhile (not . formatItemIsMarker) + ) a + +-- | Determines if the active format list contains an element. +activeFormatContains :: Parser s -> DOMID -> ST s Bool +activeFormatContains p x = any (formatItemHasID x) <$> activeFormatList p + +-- | Finds a format item with a specified tag name. +activeFormatFindTag :: Parser s -> BS -> ST s (Maybe ParserFormatItem) +activeFormatFindTag p @ Parser {..} x = do + d <- getDOM p + a <- activeFormatList p + pure $ + ( find (formatItemHasTag d x) + . takeWhile (not . formatItemIsMarker) + ) a + +-- | Finds the token for a node ID. +activeFormatFindToken :: Parser s -> DOMID -> ST s (Maybe Token) +activeFormatFindToken p @ Parser {..} x = + activeFormatList p >>= f + where + f [] = pure Nothing + f ((ParserFormatMarker):xs) = f xs + f ((ParserFormatElement i t):xs) + | x == i = pure $ Just t + | otherwise = f xs + +-- | Reconstructs the list of active format elements. +activeFormatReconstruct :: Parser s -> ST s () +activeFormatReconstruct p = do + e <- elementStack p + a <- activeFormatList p + case a of + [] -> pure () + (x:xs) + | isOpen e x -> pure () + | otherwise -> do + let b = reverse . takeWhile (not . isOpen e) $ a + a' = drop (length b) a + reopen p b a' + +-- | Determines is a format item is open. +isOpen :: [DOMID] -> ParserFormatItem -> Bool +isOpen x = \case + ParserFormatMarker -> True + ParserFormatElement i _ -> i `elem` x + +-- | Reopens a format item. +reopen :: Parser s -> [ParserFormatItem] -> [ParserFormatItem] -> ST s () +reopen p @ Parser {..} b a = + case b of + [] -> + wref parserActiveFormatList a + ((ParserFormatMarker):xs) -> + reopen p xs a + ((ParserFormatElement _ t):xs) -> do + insertHtmlElement p t + i <- fromJust <$> currentNodeID p + reopen p xs $ ParserFormatElement i t : a + +-- | Clears the list of active format elements up to last marker. +activeFormatClear :: Parser s -> ST s () +activeFormatClear p = + activeFormatModify p $ drop 1 . dropWhile (not . formatItemIsMarker) + +-- | Removes a node from the active format element list. +activeFormatRemove :: Parser s -> DOMID -> ST s () +activeFormatRemove p x = + activeFormatModify p $ filter $ not . formatItemHasID x + +-- | Replaces an ID in the active format list. +activeFormatReplace :: Parser s -> DOMID -> DOMID -> ST s () +activeFormatReplace p x y = + activeFormatModify p $ map f + where + f z@(ParserFormatMarker) = z + f z@(ParserFormatElement i t) + | i == x = ParserFormatElement y t + | otherwise = z + +-- | Modifies the active format list. +activeFormatModify :: Parser s -> ([ParserFormatItem] -> [ParserFormatItem]) -> ST s () +activeFormatModify Parser {..} = uref parserActiveFormatList + +-- | Gets the active format successor for an ID. +activeFormatSucc :: Parser s -> DOMID -> ST s (Maybe DOMID) +activeFormatSucc p x = + f <$> activeFormatList p + where + f a = case findSucc (formatItemHasID x) a of + Just (ParserFormatElement i _) -> Just i + _otherwise -> Nothing + +-- | Inserts an element in the active format list. +activeFormatInsertElement :: Parser s -> DOMID -> Token -> Maybe DOMID -> ST s () +activeFormatInsertElement p x t y = + case y of + Just a -> activeFormatModify p $ insertBefore (formatItemHasID a) e + Nothing -> activeFormatModify p (<>[e]) + where + e = ParserFormatElement x t + +-- | Determines if a format item is a marker. +formatItemIsMarker :: ParserFormatItem -> Bool +formatItemIsMarker ParserFormatMarker = True +formatItemIsMarker (ParserFormatElement _ _) = False + +-- | Determines if a format item has the specified ID. +formatItemHasID :: DOMID -> ParserFormatItem -> Bool +formatItemHasID x ParserFormatMarker = False +formatItemHasID x (ParserFormatElement i _) = i == x + +-- | Determines if a format item has a certain tag name. +formatItemHasTag :: DOM -> BS -> ParserFormatItem -> Bool +formatItemHasTag d n ParserFormatMarker = False +formatItemHasTag d n (ParserFormatElement i _) = + case domGetNode d i of + Just x -> domNodeElementName x == n + Nothing -> False + +-- | Gets the current template insertion mode. +templateModeCurrent :: Parser s -> ST s (Maybe ParserMode) +templateModeCurrent p @ Parser {..} = listToMaybe <$> rref parserTemplateMode + +-- | Pushes an insertion mode onto the stack of template insertion modes. +templateModePush :: Parser s -> ParserMode -> ST s () +templateModePush p @ Parser {..} x = uref parserTemplateMode (x:) + +-- | Pops an insertion mode off of the stack of template insertion modes. +templateModePop :: Parser s -> ST s () +templateModePop p @ Parser {..} = + rref parserTemplateMode >>= \case + (x:xs) -> wref parserTemplateMode xs + [] -> parseError p Nothing "attempt to pop empty template mode stack" + +-- | Gets the current number of template modes. +templateModeCount :: Parser s -> ST s Int +templateModeCount p @ Parser {..} = length <$> rref parserTemplateMode + +-- | Gets the appropriate insertion location. +appropriateInsertionLocation :: Parser s -> Maybe DOMID -> ST s DOMPos +appropriateInsertionLocation p @ Parser {..} override = do + -- (1) Check for override target. + target <- case override of + Just a -> pure a + Nothing -> maybe domRoot id <$> currentNodeID p + getNode p target >>= \case + Nothing -> + pure $ DOMPos domRoot Nothing + Just n -> do + f <- fosterParenting p + -- (2) Determine the adjusted insertion location. + adjusted <- + if f && domNodeElementName n `elem` + [ "table", "tbody", "tfoot", "thead", "tr" ] + then do + -- (2.1) Get last template in element stack. + lastTemplate <- elementStackFind p $ \x -> + elementDetailsType x == domMakeTypeHTML "template" + -- (2.2) Get last table in element stack. + lastTable <- elementStackFind p $ \x -> + elementDetailsType x == domMakeTypeHTML "table" + let Just (ElementDetails i1 x1 n1 _) = lastTemplate + Just (ElementDetails i2 x2 n2 _) = lastTable + -- (2.3) Check for template and no table. + if | isJust lastTemplate && (isNothing lastTable || (i1 < i2)) -> + pure $ DOMPos (domTemplateContents n1) Nothing + -- (2.4) If no last table then use first element. + | isNothing lastTable -> do + j <- fromJust <$> lastNodeID p + pure $ DOMPos j Nothing + -- (2.5) Check last table parent node. + | domNodeParent n2 /= domNull -> + pure $ DOMPos (domNodeParent n2) $ Just x2 + | otherwise -> do + -- (2.6) Previous element is above last table. + prev <- fromJust <$> elementStackSucc p x2 + -- (2.7) Location is after previous element last child. + pure $ DOMPos prev Nothing + else + pure $ DOMPos target Nothing + getNode p (domPosParent adjusted) >>= \case + Just DOMTemplate{..} -> + -- (3) Use template contents instead. + pure $ DOMPos domTemplateContents Nothing + _ -> + -- (4) Return adjusted insertion location. + pure adjusted + +-- | Gets the appropriate insertion location. +insertionLocation :: Parser s -> ST s DOMPos +insertionLocation p = appropriateInsertionLocation p Nothing + +-- | Creates an element for a token. +-- The standard describes a much more involved process than +-- what is used here (refer to 12.2.5.1). +createElementForToken :: Parser s -> Token -> HTMLNamespace -> ST s DOMID +createElementForToken p t s + | tStartName t == "template" = do + i <- newID p $ domDefaultFragment + j <- newID p $ domDefaultTemplate + { domTemplateNamespace = s + , domTemplateContents = i + } + modifyDOM p $ domSetParent i j + pure j + | otherwise = do + i <- newID p $ domDefaultElement + { domElementName = tStartName t + , domElementAttributes = Seq.fromList $ map f (tStartAttr t) + , domElementNamespace = s + } + pure i + where + f (TAttr n v s) = DOMAttr n v s + +-- | Inserts a foreign element into the document. +insertForeignElement :: Parser s -> HTMLNamespace -> Token -> ST s () +insertForeignElement p n = + withStartToken $ \t -> do + i <- createElementForToken p t n + x <- insertionLocation p + modifyDOM p $ domInsert x i + elementStackPush p i + +-- | Inserts an HTML element into the document. +insertHtmlElement :: Parser s -> Token -> ST s () +insertHtmlElement p = insertForeignElement p HTMLNamespaceHTML + +-- | Inserts a MathML element into the document. +insertMathMLElement :: Parser s -> Token -> ST s () +insertMathMLElement p = insertForeignElement p HTMLNamespaceMathML + +-- | Inserts an SVG element into the document. +insertSvgElement :: Parser s -> Token -> ST s () +insertSvgElement p = insertForeignElement p HTMLNamespaceSVG + +-- | Inserts an HTML element into the document. +insertHtmlElementNamed :: Parser s -> BS -> ST s () +insertHtmlElementNamed p x = insertHtmlElement p $ TStart x False [] + +-- | Adjusts the MathML attributes for a token. +adjustAttrMathML :: Token -> Token +adjustAttrMathML t = + case t of + TStart {} -> t { tStartAttr = map f $ tStartAttr t } + _otherwise -> t + where + f (TAttr n v s) = TAttr (g n) v s + g x = if x == "definitionurl" then "definitionUrl" else x + +-- | Adjusts the SVG attributes for a token. +adjustAttrSVG :: Token -> Token +adjustAttrSVG t = + t { tStartAttr = map f $ tStartAttr t } + where + f t@(TAttr n v s) = + case Map.lookup n svgAttributeMap of + Just n' -> TAttr n' v s + Nothing -> t + +-- | Adjusts the foreign attributes for a token. +adjustAttrForeign :: Token -> Token +adjustAttrForeign t = + t { tStartAttr = map f $ tStartAttr t } + where + f t@(TAttr n v s) = + case Map.lookup n foreignAttributeMap of + Just (n', s') -> TAttr n' v s' + Nothing -> t + +-- | Adjusts the element name for an SVG element. +adjustElemSVG :: Token -> Token +adjustElemSVG t = + case Map.lookup (tStartName t) svgElementMap of + Just x -> t { tStartName = x } + Nothing -> t + +-- | Adjustable SVG attribute map. +svgAttributeMap :: Map BS BS +svgAttributeMap = Map.fromList + [ ("attributename", "attributeName") + , ("attributetype", "attributeType") + , ("basefrequency", "baseFrequency") + , ("baseprofile", "baseProfile") + , ("calcmode", "calcMode") + , ("clippathunits", "clipPathUnits") + , ("diffuseconstant", "diffuseConstant") + , ("edgemode", "edgeMode") + , ("filterunits", "filterUnits") + , ("glyphref", "glyphRef") + , ("gradienttransform", "gradientTransform") + , ("gradientunits", "gradientUnits") + , ("kernelmatrix", "kernelMatrix") + , ("kernelunitlength", "kernelUnitLength") + , ("keypoints", "keyPoints") + , ("keysplines", "keySplines") + , ("keytimes", "keyTimes") + , ("lengthadjust", "lengthAdjust") + , ("limitingconeangle", "limitingConeAngle") + , ("markerheight", "markerHeight") + , ("markerunits", "markerUnits") + , ("markerwidth", "markerWidth") + , ("maskcontentunits", "maskContentUnits") + , ("maskunits", "maskUnits") + , ("numoctaves", "numOctaves") + , ("pathlength", "pathLength") + , ("patterncontentunits", "patternContentUnits") + , ("patterntransform", "patternTransform") + , ("patternunits", "patternUnits") + , ("pointsatx", "pointsAtX") + , ("pointsaty", "pointsAtY") + , ("pointsatz", "pointsAtZ") + , ("preservealpha", "preserveAlpha") + , ("preserveaspectratio", "preserveAspectRatio") + , ("primitiveunits", "primitiveUnits") + , ("refx", "refX") + , ("refy", "refY") + , ("repeatcount", "repeatCount") + , ("repeatdur", "repeatDur") + , ("requiredextensions", "requiredExtensions") + , ("requiredfeatures", "requiredFeatures") + , ("specularconstant", "specularConstant") + , ("specularexponent", "specularExponent") + , ("spreadmethod", "spreadMethod") + , ("startoffset", "startOffset") + , ("stddeviation", "stdDeviation") + , ("stitchtiles", "stitchTiles") + , ("surfacescale", "surfaceScale") + , ("systemlanguage", "systemLanguage") + , ("tablevalues", "tableValues") + , ("targetx", "targetX") + , ("targety", "targetY") + , ("textlength", "textLength") + , ("viewbox", "viewBox") + , ("viewtarget", "viewTarget") + , ("xchannelselector", "xChannelSelector") + , ("ychannelselector", "yChannelSelector") + , ("zoomandpan", "zoomAndPan") + ] + +-- | Adjustable SVG element map. +svgElementMap :: Map BS BS +svgElementMap = Map.fromList + [ ("altglyph", "altGlyph") + , ("altglyphdef", "altGlyphDef") + , ("altglyphitem", "altGlyphItem") + , ("animatecolor", "animateColor") + , ("animatemotion", "animateMotion") + , ("animatetransform", "animateTransform") + , ("clippath", "clipPath") + , ("feblend", "feBlend") + , ("fecolormatrix", "feColorMatrix") + , ("fecomponenttransfer", "feComponentTransfer") + , ("fecomposite", "feComposite") + , ("feconvolvematrix", "feConvolveMatrix") + , ("fediffuselighting", "feDiffuseLighting") + , ("fedisplacementmap", "feDisplacementMap") + , ("fedistantlight", "feDistantLight") + , ("fedropshadow", "feDropShadow") + , ("feflood", "feFlood") + , ("fefunca", "feFuncA") + , ("fefuncb", "feFuncB") + , ("fefuncg", "feFuncG") + , ("fefuncr", "feFuncR") + , ("fegaussianblur", "feGaussianBlur") + , ("feimage", "feImage") + , ("femerge", "feMerge") + , ("femergenode", "feMergeNode") + , ("femorphology", "feMorphology") + , ("feoffset", "feOffset") + , ("fepointlight", "fePointLight") + , ("fespecularlighting", "feSpecularLighting") + , ("fespotlight", "feSpotLight") + , ("fetile", "feTile") + , ("feturbulence", "feTurbulence") + , ("foreignobject", "foreignObject") + , ("glyphref", "glyphRef") + , ("lineargradient", "linearGradient") + , ("radialgradient", "radialGradient") + , ("textpath", "textPath") + ] + +-- | Map of foreign attribute adjustments. +foreignAttributeMap :: Map BS (BS, HTMLAttrNamespace) +foreignAttributeMap = Map.fromList + [ ("xlink:actuate", ("actuate", HTMLAttrNamespaceXLink)) + , ("xlink:arcrole", ("arcrole", HTMLAttrNamespaceXLink)) + , ("xlink:href", ("href", HTMLAttrNamespaceXLink)) + , ("xlink:role", ("role", HTMLAttrNamespaceXLink)) + , ("xlink:show", ("show", HTMLAttrNamespaceXLink)) + , ("xlink:title", ("title", HTMLAttrNamespaceXLink)) + , ("xlink:type", ("type", HTMLAttrNamespaceXLink)) + , ("xml:lang", ("lang", HTMLAttrNamespaceXML)) + , ("xml:space", ("space", HTMLAttrNamespaceXML)) + , ("xmlns", ("xmlns", HTMLAttrNamespaceXMLNS)) + , ("xmlns:xlink", ("xlink", HTMLAttrNamespaceXMLNS)) + ] + +-- | Inserts a node as a child of another node. +insertNode :: Parser s -> DOMPos -> DOMID -> ST s () +insertNode p @ Parser {..} i x = modifyDOM p $ domInsert i x + +-- | Inserts a new node as a child of another node. +insertNewNode :: Parser s -> DOMPos -> DOMNode -> ST s DOMID +insertNewNode p @ Parser {..} i x = do + d <- getDOM p + let (d', j) = domInsertNew i x d + setDOM p d' + pure j + +-- | Inserts a node as a child of the document. +insertDocumentNode :: Parser s -> DOMID -> ST s () +insertDocumentNode p @ Parser {..} = insertNode p domRootPos + +-- | Inserts a new node as a child of the document. +insertNewDocumentNode :: Parser s -> DOMNode -> ST s () +insertNewDocumentNode p @ Parser {..} = void . insertNewNode p domRootPos + +-- | Makes a comment node. +commentMake :: Parser s -> Token -> ST s DOMNode +commentMake p @ Parser {..} t = + pure $ domDefaultComment { domCommentData = tCommentData t } + +-- | Makes a document type node. +doctypeMake :: Parser s -> Token -> ST s DOMNode +doctypeMake p @ Parser {..} TDoctype {..} = + pure $ domDefaultDoctype + { domDoctypeName = tDoctypeName + , domDoctypePublicID = tDoctypePublic + , domDoctypeSystemID = tDoctypeSystem + } + +-- | Inserts a new comment in the document. +insertComment :: Parser s -> Token -> ST s () +insertComment p @ Parser {..} t = + insertionLocation p >>= \x -> + commentMake p t >>= void . insertNewNode p x + +-- | Inserts a new comment as child of the document node. +insertDocComment :: Parser s -> Token -> ST s () +insertDocComment p @ Parser {..} t = + commentMake p t >>= void . insertNewNode p domRootPos + +-- | Inserts a new character in the document. +insertChar :: Parser s -> Token -> ST s () +insertChar p @ Parser {..} = + withCharToken $ \w -> do + pos <- insertionLocation p + let i = domPosParent pos + when (i /= domRoot) $ do + d <- getDOM p + case domLastChild d i of + Nothing -> do + j <- insertNewNode p pos domDefaultText + textMapAppend p j w + Just x -> + case domGetNode d x of + Just n@DOMText{..} -> + textMapAppend p domTextID w + Just n -> do + j <- insertNewNode p pos domDefaultText + textMapAppend p j w + Nothing -> + parseError p Nothing $ "insert char bad id: " <> bcPack (show x) + +-- | Appends a word to a text node buffer. +textMapAppend :: Parser s -> DOMID -> Word8 -> ST s () +textMapAppend Parser {..} i w = do + m <- rref parserTextMap + case IntMap.lookup i m of + Just b -> + bufferAppend w b + Nothing -> do + b <- bufferNew + bufferAppend w b + wref parserTextMap $ IntMap.insert i b m + +-- | Finds a buffered string in the text map. +textMapLookup :: Parser s -> DOMID -> ST s BS +textMapLookup Parser {..} i = do + m <- rref parserTextMap + case IntMap.lookup i m of + Just b -> bufferPack b + Nothing -> pure bsEmpty + +-- | Returns a dom with the text nodes populated with text values. +textMapDOM :: Parser s -> ST s DOM +textMapDOM p @ Parser {..} = do + DOM{..} <- getDOM p + m <- rref parserTextMap >>= mapM bufferPack + let f x = IntMap.findWithDefault bsEmpty x m + a = flip IntMap.mapWithKey domNodes $ \i n -> + case n of + DOMText{} -> n { domTextData = f i } + _otherwise -> n + pure $ DOM a domNextID + +-- | Invokes processing for a start tag token token. +withStartToken :: (Token -> ST s ()) -> Token -> ST s () +withStartToken f = \case + t@TStart {} -> f t + _otherwise -> pure () + +-- -- | Invokes processing for a character token. +withCharToken :: (Word8 -> ST s ()) -> Token -> ST s () +withCharToken f = \case + TChar w -> f w + _otherwise -> pure () + +-- | Updates the parser lexer using a combinator. +parserLexerUpdate :: Parser s -> (Lexer s -> ST s ()) -> ST s () +parserLexerUpdate Parser {..} f = rref parserLexer >>= f + +-- | Sets the lexer to skip next linefeed. +parserSkipNextLF :: Parser s -> ST s () +parserSkipNextLF p = parserLexerUpdate p lexerSkipNextLF + +-- | Sets the lexer to RCDATA mode. +parserSetRCDATA :: Parser s -> ST s () +parserSetRCDATA p = parserLexerUpdate p lexerSetRCDATA + +-- | Sets the lexer to raw text mode. +parserSetRAWTEXT :: Parser s -> ST s () +parserSetRAWTEXT p = parserLexerUpdate p lexerSetRAWTEXT + +-- | Sets the lexer to plaintext mode. +parserSetPLAINTEXT :: Parser s -> ST s () +parserSetPLAINTEXT p = parserLexerUpdate p lexerSetPLAINTEXT + +-- | Sets the lexer to script data mode. +parserSetScriptData :: Parser s -> ST s () +parserSetScriptData p = parserLexerUpdate p lexerSetScriptData + +-- | Inserts an RCDATA text element. +insertElementRCDATA :: Parser s -> Token -> ST s () +insertElementRCDATA p t = do + insertHtmlElement p t + parserSetRCDATA p + saveMode p + setMode p ModeText + +-- | Inserts a raw text element. +insertElementRAWTEXT :: Parser s -> Token -> ST s () +insertElementRAWTEXT p t = do + insertHtmlElement p t + parserSetRAWTEXT p + saveMode p + setMode p ModeText + +-- | Generates the implied end tags. +generateImpliedEndTags :: Parser s -> ST s () +generateImpliedEndTags p = generateImpliedEndTagsExcept p bsEmpty + +-- | Generates the implied end tags with an exception. +generateImpliedEndTagsExcept :: Parser s -> BS -> ST s () +generateImpliedEndTagsExcept p x = + elementStackPopWhile p $ elementNameIn $ + filter (/=x) [ "dd", "dt", "li", "menuitem", "optgroup", + "option", "p", "rb", "rp", "rt", "rtc" ] + +-- | Generates the implied end tags. +generateImpliedEndTagsThoroughly :: Parser s -> ST s () +generateImpliedEndTagsThoroughly p = + elementStackPopWhile p $ elementNameIn + [ "caption", "colgroup", "dd", "dt", "li", "optgroup", + "option", "p", "rb", "rp", "rt", "rtc", + "tbody", "td", "tfoot", "th", "thead", "tr" ] + +-- | Resets the insertion mode appropriately. +resetInsertionMode :: Parser s -> ST s () +resetInsertionMode p @ Parser {..} = + elementStackNodes p >>= f + where + f [] = pure () + f (x:xs) = do + x' <- node + case (domNodeElementName x', lastNode) of + ("select", _) -> g (x':xs) + ("td", False) -> setMode p ModeInCell + ("th", False) -> setMode p ModeInCell + ("tr", _) -> setMode p ModeInRow + ("tbody", _) -> setMode p ModeInTableBody + ("thead", _) -> setMode p ModeInTableBody + ("tfoot", _) -> setMode p ModeInTableBody + ("caption", _) -> setMode p ModeInCaption + ("colgroup", _) -> setMode p ModeInColumnGroup + ("table", _) -> setMode p ModeInTable + ("head", False) -> setMode p ModeInHead + ("body", _) -> setMode p ModeInBody + ("frameset", _) -> setMode p ModeInFrameset + ("template", _) -> templateModeCurrent p >>= \case + Just m -> setMode p m + Nothing -> pure () + ("html", _) -> getHeadID p >>= \case + Nothing -> setMode p ModeBeforeHead + Just _ -> setMode p ModeAfterHead + (_, True) -> setMode p ModeInBody + (_, False) -> f xs + where + lastNode = length xs == 0 + node = do + a <- rref parserFragmentMode + c <- rref parserContextElement + n <- getNode p $ fromJust c + pure $ + if lastNode && a && isJust c + then fromJust $ n + else x + + g (x:[]) = + setMode p ModeInSelect + g (x:y:ys) = + case domNodeElementName y of + "template" -> setMode p ModeInSelect + "table" -> setMode p ModeInSelectInTable + _otherwise -> g (y:ys) + +-- | Closes a P element. +closeElementP :: Parser s -> ST s () +closeElementP p = do + let t = domMakeTypeHTML "p" + generateImpliedEndTagsExcept p "p" + unlessM (currentNodeHasType p t) $ + parseError p Nothing "current node not p when closing p element" + elementStackPopUntilType p t + +-- | Defines the adoption agency state. +data ParserAdoptionAgency s = ParserAdoptionAgency + { aaSubject :: BS + , aaOuterLoopCount :: Int + , aaInnerLoopCount :: Int + , aaNode :: DOMID + , aaLastNode :: DOMID + , aaNextNode :: DOMID + , aaFormattingElement :: DOMID + , aaCommonAncestor :: DOMID + , aaFurthestBlock :: DOMID + , aaBookmark :: (Maybe DOMID) + , aaAnyOtherEndTag :: ST s () + } + +-- | Defines the default adoption agency state. +defaultAA :: ST s (ParserAdoptionAgency s) +defaultAA = + pure $ ParserAdoptionAgency + { aaSubject = bsEmpty + , aaOuterLoopCount = 0 + , aaInnerLoopCount = 0 + , aaNode = domNull + , aaLastNode = domNull + , aaNextNode = domNull + , aaFormattingElement = domNull + , aaCommonAncestor = domNull + , aaFurthestBlock = domNull + , aaBookmark = Nothing + , aaAnyOtherEndTag = pure () + } + +-- | Modifies the adoption agency state. +modifyAA :: Parser s -> (ParserAdoptionAgency s -> ParserAdoptionAgency s) -> ST s () +modifyAA Parser {..} = uref parserAdoptionAgency + +-- | Gets the adoption agency state. +getAA :: Parser s -> ST s (ParserAdoptionAgency s) +getAA Parser {..} = rref parserAdoptionAgency + +-- | Gets a field from the adoption agency state. +getsAA :: Parser s -> (ParserAdoptionAgency s -> a) -> ST s a +getsAA p f = f <$> getAA p + +-- | Runs the adoption agency algorithm. +adoptionAgencyRun :: Parser s -> BS -> ST s () -> ST s () +adoptionAgencyRun p @ Parser {..} subject anyOther = do + a <- currentNodeHasType p $ domMakeTypeHTML subject + b <- currentNodeID p >>= \case + Just i -> notM $ activeFormatContains p i + Nothing -> pure True + unless (a && b) $ do + aa <- defaultAA + modifyAA p $ const aa + { aaSubject = subject + , aaAnyOtherEndTag = anyOther + } + adoptionAgencyOuterLoop p + +-- | Runs the outer loop portion of the adoption agency algorithm. +adoptionAgencyOuterLoop :: Parser s -> ST s () +adoptionAgencyOuterLoop p = do + i <- getsAA p aaOuterLoopCount + -- (3) Check outer loop counter. + when (i < 8) $ do + -- (4) Increment outer loop counter. + modifyAA p $ \a -> a { aaOuterLoopCount = aaOuterLoopCount a + 1 } + -- (5) Find the formatting element. + liftA aaSubject (getAA p) >>= activeFormatFindTag p >>= \case + Nothing -> do + doAnyOtherEndTag <- getsAA p aaAnyOtherEndTag + doAnyOtherEndTag + Just (ParserFormatElement fe t) -> do + modifyAA p $ \a -> a { aaFormattingElement = fe } + -- Geting formatting node + x <- fromJust <$> getNode p fe + let name = domElementName x + -- (6) Check if formatting element is not in element stack. + (elementStackAny p ((==) fe . domNodeID)) >>= \case + False -> do + parseError p Nothing $ + "element stack missing " <> name + <> "(ID:" <> bcPack (show fe) <> ") during adoption" + activeFormatRemove p fe + True -> + -- (7) Check if formatting element is not in scope. + (elementInScope p $ domNodeType x) >>= \case + False -> + parseError p Nothing $ + "element " <> name <> " not in scope during adoption" + True -> do + -- (8) Check if formatting element is not current node. + unlessM (maybe False (==fe) <$> currentNodeID p) $ + parseError p Nothing $ "element " <> name + <> " is not the current ID during adoption" + -- (9) Find the furthest block. + d <- getDOM p + f <- pure $ find $ elementIsSpecial + . domNodeType . fromJust . domGetNode d + liftA (f . reverse . takeWhile (/=fe)) (elementStack p) >>= \case + Nothing -> do + -- (10) There was no furthest block. + elementStackPopUntilID p fe + activeFormatRemove p fe + Just fb -> do + -- (11) Find the common ancestor. + ca <- fromJust <$> elementStackSucc p fe + -- (12) Bookmark notes position of formatting element. + bm <- activeFormatSucc p fe + modifyAA p $ \a -> a + { aaNode = fb + , aaLastNode = fb + , aaCommonAncestor = ca + , aaFurthestBlock = fb + , aaBookmark = bm + } + adoptionAgencyInnerLoop p + +-- | Runs the inner loop portion of the adoption agency algorithm. +adoptionAgencyInnerLoop :: Parser s -> ST s () +adoptionAgencyInnerLoop p = do + -- (13.2) Increment inner loop counter. + modifyAA p $ \a -> a { aaInnerLoopCount = aaInnerLoopCount a + 1 } + -- (13.3) Move to the next node. + n <- getsAA p aaNode + m <- getsAA p aaNextNode + node <- maybe m id <$> elementStackSucc p n + -- (13.4) Check if node is the formatting element. + f <- getsAA p aaFormattingElement + if node == f + then adoptionAgencyPostLoop p + else do + -- (13.5) Check the inner loop counter. + ic <- getsAA p aaInnerLoopCount + ac <- activeFormatContains p node + when (ic > 3 && ac) $ activeFormatRemove p node + -- (13.6) Check if node is in the active format list. + unlessM (activeFormatContains p node) $ do + m <- fromJust <$> elementStackSucc p node + modifyAA p $ \a -> a { aaNextNode = m } + elementStackRemove p node + adoptionAgencyInnerLoop p + -- (13.7) Create an element for the token for node. + t <- fromJust <$> activeFormatFindToken p node + e <- createElementForToken p t HTMLNamespaceHTML + c <- getsAA p aaCommonAncestor + modifyDOM p $ domAppend c e + activeFormatReplace p node e + elementStackReplace p node e + modifyAA p $ \a -> a { aaNode = e } + -- (13.8) Check if node is the furthest block. + x <- getsAA p aaLastNode + b <- getsAA p aaFurthestBlock + when (x == b) $ do + bm <- activeFormatSucc p e + modifyAA p $ \a -> a { aaBookmark = bm } + -- (13.9) Insert last node into node. + modifyDOM p $ domMove x e + -- (13.10) Set last node to be node. + modifyAA p $ \a -> a { aaLastNode = e } + -- (13.11) Repeat inner loop. + adoptionAgencyInnerLoop p + +-- | Runs the post-loop portion of the adoption agency algorithm. +adoptionAgencyPostLoop :: Parser s -> ST s () +adoptionAgencyPostLoop p = do + -- (14) Insert last node with common ancestor as target. + c <- getsAA p aaCommonAncestor + n <- getsAA p aaLastNode + i <- appropriateInsertionLocation p $ Just c + modifyDOM p $ domMove n $ domPosParent i + -- (15) Create element for token. + f <- getsAA p aaFormattingElement + t <- fromJust <$> activeFormatFindToken p f + e <- createElementForToken p t HTMLNamespaceHTML + -- (16) Move furthest block children to new element. + b <- getsAA p aaFurthestBlock + modifyDOM p $ domMoveChildren b e + -- (17) Append new element to furthest block. + modifyDOM p $ domAppend b e + -- (18) Remove formatting element and insert new element. + activeFormatRemove p f + getsAA p aaBookmark >>= activeFormatInsertElement p e t + -- (19) Remove formatting element and insert new element. + elementStackRemove p f + elementStackInsertBefore p b e + -- (20) Jump back to outer loop. + adoptionAgencyOuterLoop p + +-- | Initializes the pending table characters. +pendingTableCharInit :: Parser s -> ST s () +pendingTableCharInit Parser {..} = wref parserTableChars [] + +-- | Appends a character to the pending table characters. +pendingTableCharAppend :: Parser s -> Token -> ST s () +pendingTableCharAppend Parser {..} t = uref parserTableChars (<>[t]) + +-- | Gets the pending table characters. +pendingTableChars :: Parser s -> ST s [Token] +pendingTableChars Parser {..} = rref parserTableChars + +-- | Checks the DOCTYPE token for validity. +doctypeTokenCheck :: Parser s -> Token -> ST s () +doctypeTokenCheck parser@Parser {..} t@(TDoctype n q p s) = + when (n /= "html" + || p /= Nothing + || s /= Nothing && s /= Just "about:legacy-compat") $ + parseError parser (Just t) "doctype error" + +-- | Determines if the doctype token represents quirks mode. +tokenQuirks :: Token -> Bool +tokenQuirks (TDoctype n True p s) = True +tokenQuirks (TDoctype n False p s) = + or + [ n /= "html" + , idMatch p "-//W3O//DTD W3 HTML Strict 3.0//EN//" + , idMatch p "-/W3C/DTD HTML 4.0 Transitional/EN" + , idMatch p "HTML" + , idMatch s "http://www.ibm.com/data/dtd/v11/ibmxhtml1-transitional.dtd" + , anyPrefix p publicIdPrefix + , and + [ s == Nothing + , anyPrefix p + [ "-//W3C//DTD HTML 4.01 Frameset//" + , "-//W3C//DTD HTML 4.01 Transitional//" + ] + ] + ] + +-- | Public ID prefixes. +publicIdPrefix :: [BS] +publicIdPrefix = + [ "+//Silmaril//dtd html Pro v0r11 19970101//" + , "-//AS//DTD HTML 3.0 asWedit + extensions//" + , "-//AdvaSoft Ltd//DTD HTML 3.0 asWedit + extensions//" + , "-//IETF//DTD HTML 2.0 Level 1//" + , "-//IETF//DTD HTML 2.0 Level 2//" + , "-//IETF//DTD HTML 2.0 Strict Level 1//" + , "-//IETF//DTD HTML 2.0 Strict Level 2//" + , "-//IETF//DTD HTML 2.0 Strict//" + , "-//IETF//DTD HTML 2.0//" + , "-//IETF//DTD HTML 2.1E//" + , "-//IETF//DTD HTML 3.0//" + , "-//IETF//DTD HTML 3.2 Final//" + , "-//IETF//DTD HTML 3.2//" + , "-//IETF//DTD HTML 3//" + , "-//IETF//DTD HTML Level 0//" + , "-//IETF//DTD HTML Level 1//" + , "-//IETF//DTD HTML Level 2//" + , "-//IETF//DTD HTML Level 3//" + , "-//IETF//DTD HTML Strict Level 0//" + , "-//IETF//DTD HTML Strict Level 1//" + , "-//IETF//DTD HTML Strict Level 2//" + , "-//IETF//DTD HTML Strict Level 3//" + , "-//IETF//DTD HTML Strict//" + , "-//IETF//DTD HTML//" + , "-//Metrius//DTD Metrius Presentational//" + , "-//Microsoft//DTD Internet Explorer 2.0 HTML Strict//" + , "-//Microsoft//DTD Internet Explorer 2.0 HTML//" + , "-//Microsoft//DTD Internet Explorer 2.0 Tables//" + , "-//Microsoft//DTD Internet Explorer 3.0 HTML Strict//" + , "-//Microsoft//DTD Internet Explorer 3.0 HTML//" + , "-//Microsoft//DTD Internet Explorer 3.0 Tables//" + , "-//Netscape Comm. Corp.//DTD HTML//" + , "-//Netscape Comm. Corp.//DTD Strict HTML//" + , "-//O'Reilly and Associates//DTD HTML 2.0//" + , "-//O'Reilly and Associates//DTD HTML Extended 1.0//" + , "-//O'Reilly and Associates//DTD HTML Extended Relaxed 1.0//" + , "-//SQ//DTD HTML 2.0 HoTMetaL + extensions//" + , "-//SoftQuad Software//DTD HoTMetaL PRO 6.0::19990601::extensions to HTML 4.0//" + , "-//SoftQuad//DTD HoTMetaL PRO 4.0::19971010::extensions to HTML 4.0//" + , "-//Spyglass//DTD HTML 2.0 Extended//" + , "-//Sun Microsystems Corp.//DTD HotJava HTML//" + , "-//Sun Microsystems Corp.//DTD HotJava Strict HTML//" + , "-//W3C//DTD HTML 3 1995-03-24//" + , "-//W3C//DTD HTML 3.2 Draft//" + , "-//W3C//DTD HTML 3.2 Final//" + , "-//W3C//DTD HTML 3.2//" + , "-//W3C//DTD HTML 3.2S Draft//" + , "-//W3C//DTD HTML 4.0 Frameset//" + , "-//W3C//DTD HTML 4.0 Transitional//" + , "-//W3C//DTD HTML Experimental 19960712//" + , "-//W3C//DTD HTML Experimental 970421//" + , "-//W3C//DTD W3 HTML//" + , "-//W3O//DTD W3 HTML 3.0//" + , "-//WebTechs//DTD Mozilla HTML 2.0//" + , "-//WebTechs//DTD Mozilla HTML//" + ] + +-- | Determines if the doctype token represents limited quirks mode. +tokenLimitedQuirks :: Token -> Bool +tokenLimitedQuirks TDoctype {..} = + or + [ anyPrefix tDoctypePublic + [ "-//W3C//DTD XHTML 1.0 Frameset//" + , "-//W3C//DTD XHTML 1.0 Transitional//" + ] + , and + [ isJust tDoctypeSystem + , anyPrefix tDoctypePublic + [ "-//W3C//DTD HTML 4.01 Frameset//" + , "-//W3C//DTD HTML 4.01 Transitional//" + ] + ] + ] + +-- | Determines if a DOCTYPE ID matches a value. +idMatch :: Maybe BS -> BS -> Bool +idMatch (Just x) y = bsLower x == bsLower y +idMatch Nothing y = False + +-- | Determines if a text has any prefix from a list. +anyPrefix :: Maybe BS -> [BS] -> Bool +anyPrefix (Just x) ys = any (\y -> y `bsPrefixCI` x) ys +anyPrefix Nothing ys = False + +-- | Handle the initial insertion mode. +doModeInitial :: Parser s -> Token -> ST s () +doModeInitial p @ Parser {..} t = + case t of + TChar {..} | chrWhitespace tCharData -> do + pure () + TComment {} -> do + insertDocComment p t + TDoctype {} -> do + doctypeTokenCheck p t + doctypeMake p t >>= insertNewDocumentNode p + iframe <- iframeSrcDoc p + when (not iframe && tokenQuirks t) $ do + modifyDOM p $ domQuirksSet DOMQuirksMode + when (not iframe && tokenLimitedQuirks t) $ do + modifyDOM p $ domQuirksSet DOMQuirksLimited + setMode p ModeBeforeHtml + _otherwise -> do + whenM (notM $ iframeSrcDoc p) $ do + parseError p (Just t) "initial unexpected token" + modifyDOM p $ domQuirksSet DOMQuirksMode + setMode p ModeBeforeHtml + reprocess p t + +-- | Handle the before html insertion mode. +doModeBeforeHtml :: Parser s -> Token -> ST s () +doModeBeforeHtml p @ Parser {..} t = + case t of + TDoctype {} -> + parseError p (Just t) "before html doctype" + TComment {} -> + insertDocComment p t + TChar {..} | chrWhitespace tCharData -> + pure () + TStart { tStartName = "html" } -> do + insertHtmlElement p t + setMode p ModeBeforeHead + TEnd { tEndName = x } + | elem x [ "head", "body", "html", "br" ] -> do + insertHtmlElementNamed p "html" + setMode p ModeBeforeHead + reprocess p t + TEnd {} -> + parseError p (Just t) "before html end tag" + _otherwise -> do + insertHtmlElementNamed p "html" + setMode p ModeBeforeHead + reprocess p t + +-- | Handle the before head insertion mode. +doModeBeforeHead :: Parser s -> Token -> ST s () +doModeBeforeHead p @ Parser {..} t = + case t of + TChar {..} | chrWhitespace tCharData -> + pure () + TComment {} -> + insertComment p t + TDoctype {} -> + parseError p (Just t) "before head doctype" + TStart { tStartName = "html" } -> + doModeInBody p t + TStart { tStartName = "head" } -> do + insertHtmlElement p t + saveHead p + setMode p ModeInHead + TEnd { tEndName = x } + | elem x [ "head", "body", "html", "br" ] -> do + insertHtmlElementNamed p "head" + saveHead p + setMode p ModeInHead + reprocess p t + TEnd {} -> + parseError p (Just t) "before head end tag" + _otherwise -> do + insertHtmlElementNamed p "head" + saveHead p + setMode p ModeInHead + reprocess p t + +-- | Handles the in-head parser mode. +doModeInHead :: Parser s -> Token -> ST s () +doModeInHead p @ Parser {..} t = + case t of + TChar {..} | chrWhitespace tCharData -> + insertChar p t + TComment {} -> + insertComment p t + TDoctype {} -> + warn "doctype" + TStart { tStartName = "html" } -> + doModeInBody p t + TStart { tStartName = x } + | elem x [ "base", "basefont", "bgsound", "link" ] -> do + insertHtmlElement p t + elementStackPop p + selfClosingAcknowledge p + TStart { tStartName = "meta" } -> do + insertHtmlElement p t + elementStackPop p + selfClosingAcknowledge p + -- The standard normally requires running the encoding determination + -- algorithm here, but we should not need it since the content should + -- be known to be UTF-16. + TStart { tStartName = "title" } -> + insertElementRCDATA p t + TStart { tStartName = "noframes" } -> + insertElementRAWTEXT p t + TStart { tStartName = "style" } -> + insertElementRAWTEXT p t + TStart { tStartName = "noscript" } -> do + insertHtmlElement p t + setMode p ModeInHeadNoscript + TStart { tStartName = "script" } -> do + insertHtmlElement p t + parserSetScriptData p + saveMode p + setMode p ModeText + TEnd { tEndName = "head" } -> do + elementStackPop p + setMode p ModeAfterHead + TEnd { tEndName = x } + | elem x [ "body", "html", "br" ] -> do + elementStackPop p + setMode p ModeAfterHead + reprocess p t + TStart { tStartName = "template" } -> do + insertHtmlElement p t + activeFormatAddMarker p + frameSetNotOK p + setMode p ModeInTemplate + templateModePush p ModeInTemplate + TEnd { tEndName = x@"template" } -> do + let a = domMakeTypeHTML x + -- Make sure a template element is on the stack. + elementStackHasTemplate p >>= \case + False -> + warn "template start tag missing" + True -> do + -- (1) Generate implied end tags thoroughly. + generateImpliedEndTagsThoroughly p + -- (2) Make sure template is the current node. + unlessM (currentNodeHasType p a) $ + parseError p Nothing "template not current node" + -- (3) Pop elements until a template has been popped. + elementStackPopUntilType p a + -- (4) Clear list of active formatting elements up to last marker. + activeFormatClear p + -- (5) Pop the current template insertion mode. + templateModePop p + -- (6) Reset the insertion mode appropriately. + resetInsertionMode p + TStart { tStartName = "head" } -> + warn "head" + TEnd {} -> + warn "unexpected end tag" + _otherwise -> do + elementStackPop p + setMode p ModeAfterHead + reprocess p t + where + warn x = parseError p (Just t) $ "in head " <> x + +-- | Handles the in head no script parser mode. +doModeInHeadNoscript :: Parser s -> Token -> ST s () +doModeInHeadNoscript p @ Parser {..} t = + case t of + TDoctype {} -> + warn "doctype" + TStart { tStartName = "html" } -> + doModeInBody p t + TEnd { tEndName = "noscript" } -> do + elementStackPop p + setMode p ModeInHead + TChar {..} | chrWhitespace tCharData -> + doModeInHead p t + TComment {} -> + doModeInHead p t + TStart { tStartName = x } + | elem x [ "basefont", "bgsound", "link", + "meta", "noframes", "style" ] -> + doModeInHead p t + TEnd { tEndName = "br" } -> do + warn "br" + elementStackPop p + setMode p ModeInHead + reprocess p t + TStart { tStartName = "head" } -> + warn "head" + TStart { tStartName = "noscript" } -> + warn "noscript" + TEnd {} -> + warn "end tag" + _otherwise -> do + warn "bad token" + elementStackPop p + setMode p ModeInHead + reprocess p t + where + warn x = parseError p (Just t) $ "in head noscript " <> x + +-- | Handles the after head parser mode. +doModeAfterHead :: Parser s -> Token -> ST s () +doModeAfterHead p @ Parser {..} t = + case t of + TChar {..} | chrWhitespace tCharData -> + insertChar p t + TComment {} -> + insertComment p t + TDoctype {} -> + parseError p (Just t) "after head doctype" + TStart { tStartName = "html" } -> + doModeInBody p t + TStart { tStartName = "body" } -> do + insertHtmlElement p t + frameSetNotOK p + setMode p ModeInBody + TStart { tStartName = "frameset" } -> do + insertHtmlElement p t + setMode p ModeInFrameset + TStart { tStartName = x } + | elem x [ "base", "basefont", "bgsound", "link", "meta", "noframes", + "script", "style", "template", "title", "head" ] -> do + parseError p (Just t) "AfterHead bad start tag" + Just h <- getHeadID p + elementStackPush p h + doModeInHead p t + elementStackRemove p h + TEnd { tEndName = "template" } -> + doModeInHead p t + TEnd { tEndName = x } + | elem x [ "body", "html", "br" ] -> do + insertHtmlElementNamed p "body" + setMode p ModeInBody + reprocess p t + TStart { tStartName = "head" } -> + parseError p (Just t) "after head head" + TEnd {} -> + parseError p (Just t) "after head end tag" + _otherwise -> do + insertHtmlElementNamed p "body" + setMode p ModeInBody + reprocess p t + +-- | Handles the in body parser mode. +doModeInBody :: Parser s -> Token -> ST s () +doModeInBody p @ Parser {..} t = + case t of + TChar {..} | chrWhitespace tCharData -> do + activeFormatReconstruct p + insertChar p t + TChar {} -> do + activeFormatReconstruct p + insertChar p t + frameSetNotOK p + TComment {} -> + insertComment p t + TDoctype {} -> + warn "doctype" + TStart { tStartName = x@"html" } -> do + warn x + unlessM (elementStackHasTemplate p) $ do + Just i <- lastNodeID p + modifyDOM p $ domAttrMerge i $ Seq.fromList $ + map (\(TAttr n v s) -> DOMAttr n v s) $ tStartAttr t + TStart { tStartName = x } + | elem x ["base", "basefont", "bgsound", "link", "meta", + "noframes", "script", "style", "template", "title"] -> + doModeInHead p t + TEnd { tEndName = "template" } -> + doModeInHead p t + TStart { tStartName = x@"body" } -> do + warn x + unlessM (notM (elementStackHasBody p) + ||^ liftA (==1) (elementStackSize p) + ||^ (elementStackHasTemplate p)) $ do + frameSetNotOK p + Just i <- listToMaybe . drop 1 . reverse <$> elementStack p + modifyDOM p $ domAttrMerge i $ Seq.fromList $ + map (\(TAttr n v s) -> DOMAttr n v s) $ tStartAttr t + TStart { tStartName = x@"frameset" } -> do + warn x + unlessM (liftA (==1) (elementStackSize p) + ||^ notM (elementStackHasBody p) + ||^ notM (rref parserFrameSetOK)) $ do + Just n <- listToMaybe . drop 1 . reverse <$> elementStackNodes p + modifyDOM p $ domRemoveChild (domNodeParent n) $ domNodeID n + elementStackPopWhile p $ \n -> + domNodeType n /= domMakeTypeHTML "html" + insertHtmlElement p t + setMode p ModeInFrameset + TEOF -> do + n <- templateModeCount p + if n > 0 + then doModeInTemplate p t + else do + whenM (elementStackAny p $ elementNameNotIn + ["dd", "dt", "li", "menuitem", "optgroup", + "option", "p", "rb", "rp", "rt", "rtc", + "tbody", "td", "tfoot", "th", "thead", "tr", + "body", "html"]) $ + warn "bad element on stack" + parserSetDone p + TEnd { tEndName = x@"body" } -> do + let a = domMakeTypeHTML x + elementInScope p a >>= \case + False -> + warn "no body element in scope" + True -> do + whenM (elementStackAny p $ elementNameNotIn + ["dd", "dt", "li", "menuitem", "optgroup", + "option", "p", "rb", "rp", "rt", "rtc", + "tbody", "td", "tfoot", "th", "thead", "tr", + "body", "html"]) $ + warn "bad element on stack" + setMode p ModeAfterBody + TEnd { tEndName = x@"html" } -> do + let a = domMakeTypeHTML x + elementInScope p a >>= \case + False -> + warn "no body element in scope" + True -> do + whenM (elementStackAny p $ elementNameNotIn + ["dd", "dt", "li", "menuitem", "optgroup", + "option", "p", "rb", "rp", "rt", "rtc", + "tbody", "td", "tfoot", "th", "thead", "tr", + "body", "html"]) $ + warn "bad element on stack" + setMode p ModeAfterBody + reprocess p t + TStart { tStartName = x } | elem x + ["address", "article", "aside", "blockquote", + "center", "details", "dialog", "dir", "div", "dl", + "fieldset", "figcaption", "figure", "footer", "header", + "hgroup", "main", "nav", "ol", "p", "section", + "summary", "ul"] -> do + closeP + insertHtmlElement p t + TStart { tStartName = "menu" } -> do + closeP + popMenuitem + insertHtmlElement p t + TStart { tStartName = x } + | elem x ["h1", "h2", "h3", "h4", "h5", "h6"] -> do + closeP + whenM (currentNodeHasTypeIn p $ domTypesHTML + ["h1", "h2", "h3", "h4", "h5", "h6"]) $ do + warn "bad header tag on stack" + elementStackPop p + insertHtmlElement p t + TStart { tStartName = x } | elem x ["pre", "listing"] -> do + closeP + insertHtmlElement p t + parserSkipNextLF p + frameSetNotOK p + TStart { tStartName = "form" } -> do + (formNotNull p &&^ elementStackMissingTemplate p) >>= \case + True -> + warn "form without template" + False -> do + closeP + insertHtmlElement p t + whenM (elementStackMissingTemplate p) $ saveForm p + TStart { tStartName = x@"li" } -> do + let a = domMakeTypeHTML x + s = Set.fromList $ domTypesHTML [ "address", "div", "p" ] + f [] = pure () + f (y:ys) + | y == a = do + generateImpliedEndTagsExcept p x + unlessM (currentNodeHasType p a) $ + warn "current node is not li" + elementStackPopUntilType p a + | elementIsSpecial y && Set.notMember y s = pure () + | otherwise = f ys + frameSetNotOK p + elementStackTypes p >>= f + closeP + insertHtmlElement p t + TStart { tStartName = x } | elem x ["dd", "dt"] -> do + let dd = domMakeTypeHTML "dd" + dt = domMakeTypeHTML "dt" + s = Set.fromList $ domTypesHTML [ "address", "div", "p" ] + f [] = pure () + f (y:ys) + | y == dd || y == dt = do + generateImpliedEndTagsExcept p $ domTypeName y + unlessM (currentNodeHasType p y) $ + warn "current node is not dd or dt" + elementStackPopUntilType p y + | elementIsSpecial y && Set.notMember y s = pure () + | otherwise = f ys + frameSetNotOK p + elementStackTypes p >>= f + closeP + insertHtmlElement p t + TStart { tStartName = "plaintext" } -> do + closeP + insertHtmlElement p t + parserSetPLAINTEXT p + TStart { tStartName = x@"button" } -> do + let a = domMakeTypeHTML x + whenM (elementInScope p a) $ do + warn "button element in scope" + generateImpliedEndTags p + elementStackPopUntilType p a + activeFormatReconstruct p + insertHtmlElement p t + frameSetNotOK p + TEnd { tEndName = x } + | elem x ["address", "article", "aside", "blockquote", "button", + "center", "details", "dialog", "dir", "div", "dl", + "fieldset", "figcaption", "figure", "footer", "header", + "hgroup", "listing", "main", "menu", "nav", "ol", + "pre", "section", "summary", "ul"] -> do + let a = domMakeTypeHTML x + elementInScope p a >>= \case + False -> + warn "element not in scope" + True -> do + generateImpliedEndTags p + unlessM (currentNodeHasType p a) $ + warn "current node wrong type" + elementStackPopUntilType p a + TEnd { tEndName = x@"form" } -> + elementStackHasTemplate p >>= \case + False -> do + getFormID p >>= \case + Nothing -> + warn "form not defined" + Just n -> do + a <- fromJust <$> getFormType p + setFormID p Nothing + elementInScope p a >>= \case + False -> + warn "form not in scope" + True -> do + generateImpliedEndTags p + unlessM (liftA (==(Just n)) (currentNodeID p)) $ + warn "current node is wrong node" + elementStackRemove p n + True -> do + let a = domMakeTypeHTML x + elementInScope p a >>= \case + False -> + warn "form not in scope" + True -> do + generateImpliedEndTags p + unlessM (currentNodeHasType p a) $ + warn "current node is not a form" + elementStackPopUntilType p a + TEnd { tEndName = x@"p" } -> do + let a = domMakeTypeHTML x + unlessM (elementInButtonScope p a) $ do + warn "no p in button scope" + insertHtmlElementNamed p x + closeElementP p + TEnd { tEndName = x@"li" } -> do + let a = domMakeTypeHTML x + elementInListScope p a >>= \case + False -> + warn "no li in list scope" + True -> do + generateImpliedEndTagsExcept p x + unlessM (currentNodeHasType p a) $ + warn "current node not an li element" + elementStackPopUntilType p a + TEnd { tEndName = x } | elem x ["dd", "dt"] -> do + let a = domMakeTypeHTML x + elementInListScope p a >>= \case + False -> + warn "no dd or dt in list scope" + True -> do + generateImpliedEndTagsExcept p x + unlessM (currentNodeHasType p a) $ + warn "current not is not a dd or dt" + elementStackPopUntilType p a + TEnd { tEndName = x } + | elem x ["h1", "h2", "h3", "h4", "h5", "h6"] -> do + let h = domTypesHTML ["h1", "h2", "h3", "h4", "h5", "h6"] + anyM (elementInScope p) h >>= \case + False -> + warn "header element not in scope" + True -> do + generateImpliedEndTags p + unlessM (currentNodeHasType p $ domMakeTypeHTML x) $ + warn "current node not a header type" + elementStackPopUntilTypeIn p h + TEnd { tEndName = "sarcasm" } -> + doAnyOtherEndTag + TStart { tStartName = x@"a" } -> do + let a = domMakeTypeHTML x + activeFormatFindTag p x >>= \case + Nothing -> pure () + Just (ParserFormatElement i _) -> do + warn "active format already has anchor" + runAA x + elementStackRemove p i + activeFormatRemove p i + activeFormatReconstruct p + insertHtmlElement p t + activeFormatAddCurrentNode p t + TStart { tStartName = x } | elem x + ["b", "big", "code", "em", "font", "i", "s", + "small", "strike", "strong", "tt", "u"] -> do + activeFormatReconstruct p + insertHtmlElement p t + activeFormatAddCurrentNode p t + TStart { tStartName = x@"nobr" } -> do + let a = domMakeTypeHTML x + activeFormatReconstruct p + whenM (elementInScope p a) $ do + warn "nobr tag when nobr element already in scope" + runAA x + activeFormatReconstruct p + insertHtmlElement p t + activeFormatAddCurrentNode p t + TEnd { tEndName = x } | elem x + ["a", "b", "big", "code", "em", "font", "i", "nobr", + "s", "small", "strike", "strong", "tt", "u"] -> + runAA x + TStart { tStartName = x } | elem x + ["applet", "marquee", "object"] -> do + activeFormatReconstruct p + insertHtmlElement p t + activeFormatAddMarker p + frameSetNotOK p + TEnd { tEndName = x } | elem x + ["applet", "marquee", "object"] -> do + let a = domMakeTypeHTML x + elementInScope p a >>= \case + False -> + warn "element scope missing" + True -> do + generateImpliedEndTags p + unlessM (currentNodeHasType p a) $ + warn "current node is wring type" + elementStackPopUntilType p a + activeFormatClear p + TStart { tStartName = "table" } -> do + q <- domQuirksGet <$> getDOM p + when (q /= DOMQuirksMode) closeP + insertHtmlElement p t + frameSetNotOK p + setMode p ModeInTable + TEnd { tEndName = "br" } -> do + warn "br end tag" + activeFormatReconstruct p + insertHtmlElement p $ TStart "br" False [] + elementStackPop p + selfClosingAcknowledge p + frameSetNotOK p + TStart { tStartName = x } | elem x + ["area", "br", "embed", "img", "keygen", "wbr"] -> do + activeFormatReconstruct p + insertHtmlElement p t + elementStackPop p + selfClosingAcknowledge p + frameSetNotOK p + TStart { tStartName = "input" } -> do + activeFormatReconstruct p + insertHtmlElement p t + elementStackPop p + selfClosingAcknowledge p + case tokenGetAttrVal "type" t of + Just v -> when (bsLower v /= "hidden") $ frameSetNotOK p + Nothing -> frameSetNotOK p + TStart { tStartName = x } | elem x + ["param", "source", "track"] -> do + insertHtmlElement p t + elementStackPop p + selfClosingAcknowledge p + TStart { tStartName = "hr" } -> do + closeP + popMenuitem + insertHtmlElement p t + elementStackPop p + selfClosingAcknowledge p + frameSetNotOK p + TStart { tStartName = "image" } -> do + warn "image" + let t' = t { tStartName = "img" } + reprocess p t' + TStart { tStartName = "textarea" } -> do + insertHtmlElement p t + parserSkipNextLF p + parserSetRCDATA p + saveMode p + frameSetNotOK p + setMode p ModeText + TStart { tStartName = "xmp" } -> do + closeP + activeFormatReconstruct p + frameSetNotOK p + insertElementRAWTEXT p t + TStart { tStartName = "iframe" } -> do + frameSetNotOK p + insertElementRAWTEXT p t + TStart { tStartName = "noembed" } -> + insertElementRAWTEXT p t + TStart { tStartName = "select" } -> do + activeFormatReconstruct p + insertHtmlElement p t + frameSetNotOK p + s <- pure $ Set.fromList + [ ModeInTable, ModeInCaption, ModeInTableBody, + ModeInRow, ModeInCell ] + rref parserInsertionMode >>= \x -> setMode p $ + if Set.member x s + then ModeInSelectInTable + else ModeInSelect + TStart { tStartName = x } | elem x + ["optgroup", "option"] -> do + elementStackPopIf p $ elementName "option" + activeFormatReconstruct p + insertHtmlElement p t + TStart { tStartName = "menuitem" } -> do + popMenuitem + insertHtmlElement p t + TStart { tStartName = x } | elem x ["rb", "rtc"] -> do + let a = domMakeTypeHTML "ruby" + whenM (elementInScope p a) $ do + generateImpliedEndTags p + unlessM (currentNodeHasType p a) $ + warn "ruby element not in scope" + insertHtmlElement p t + TStart { tStartName = x } | elem x ["rp", "rt"] -> do + let a = domMakeTypeHTML "ruby" + b = domMakeTypeHTML "rtc" + whenM (elementInScope p a) $ do + generateImpliedEndTagsExcept p "rtc" + unlessM (currentNodeHasType p a ||^ currentNodeHasType p b) $ + warn "ruby or rtc element not in scope" + insertHtmlElement p t + TStart { tStartName = "math" } -> do + activeFormatReconstruct p + insertMathMLElement p . adjustAttrForeign . adjustAttrMathML $ t + when (tStartClosed t) $ do + elementStackPop p + selfClosingAcknowledge p + TStart { tStartName = "svg" } -> do + activeFormatReconstruct p + insertSvgElement p . adjustAttrForeign . adjustAttrSVG $ t + when (tStartClosed t) $ do + elementStackPop p + selfClosingAcknowledge p + TStart { tStartName = x } | elem x + ["caption", "col", "colgroup", "frame", "head", + "tbody", "td", "tfoot", "th", "thead", "tr"] -> + warn "bad start token" + TStart {} -> do + activeFormatReconstruct p + insertHtmlElement p t + TEnd {} -> + doAnyOtherEndTag + where + closeP = do + let a = domMakeTypeHTML "p" + whenM (elementInButtonScope p a) $ closeElementP p + popMenuitem = + elementStackPopIf p $ elementName "menuitem" + runAA = + flip (adoptionAgencyRun p) doAnyOtherEndTag + doAnyOtherEndTag = + elementStackTypes p >>= f + where + n = tEndName t + a = domMakeTypeHTML n + f [] = pure () + f (x:xs) + | x == a = do + generateImpliedEndTagsExcept p n + unlessM (currentNodeHasType p x) $ + warn "current node has wrong type" + elementStackPop p + | elementIsSpecial x = do + warn "special element in stack" + | otherwise = f xs + warn x = + parseError p (Just t) $ "in body " <> x + +-- | Handle the text insertion mode. +doModeText :: Parser s -> Token -> ST s () +doModeText p @ Parser {..} t = + case t of + TChar {} -> + insertChar p t + TEOF -> do + parseError p (Just t) "text eof" + elementStackPop p + restoreMode p + reprocess p t + TEnd { tEndName = "script" } -> do + elementStackPop p + restoreMode p + -- The standard explains how to execute the script + -- at this point, but we are just parsing. + _otherwise -> do + elementStackPop p + restoreMode p + +-- | Handle the in-table insertion mode. +doModeInTable :: Parser s -> Token -> ST s () +doModeInTable p @ Parser {..} t = + case t of + TChar {} -> do + a <- currentNodeHasTypeIn p $ domTypesHTML + ["table", "tbody", "tfoot", "thead", "tr"] + if a + then do + pendingTableCharInit p + saveMode p + setMode p ModeInTableText + reprocess p t + else do + -- Because of the way the check is implmented, perform the + -- steps for anything else here. + anythingElse + TComment {} -> + insertComment p t + TDoctype {} -> + warn "doctype" + TStart { tStartName = "caption" } -> do + clearToTableContext + activeFormatAddMarker p + insertHtmlElement p t + setMode p ModeInCaption + TStart { tStartName = "colgroup" } -> do + clearToTableContext + insertHtmlElement p t + setMode p ModeInColumnGroup + TStart { tStartName = x@"col" } -> do + clearToTableContext + insertHtmlElementNamed p x + setMode p ModeInColumnGroup + reprocess p t + TStart { tStartName = x } | elem x + ["tbody", "tfoot", "thead"] -> do + clearToTableContext + insertHtmlElement p t + setMode p ModeInTableBody + TStart { tStartName = x } | elem x + ["td", "th", "tr"] -> do + clearToTableContext + insertHtmlElementNamed p "tbody" + setMode p ModeInTableBody + reprocess p t + TStart { tStartName = x@"table" } -> do + warn "table start tag" + let a = domMakeTypeHTML x + unlessM (elementInTableScope p a) $ do + elementStackPopUntilType p a + resetInsertionMode p + reprocess p t + TEnd { tEndName = x@"table" } -> do + let a = domMakeTypeHTML x + elementInTableScope p a >>= \case + False -> + warn "no table in scope" + True -> do + elementStackPopUntilType p a + resetInsertionMode p + TStart { tStartName = x } | elem x + ["body", "caption", "col", "colgroup", "html", + "tbody", "td", "tfoot", "th", "thead", "tr"] -> + warn "unexpected start tag" + TStart { tStartName = x } | elem x + ["style", "script", "template"] -> + doModeInHead p t + TEnd { tEndName = "template" } -> + doModeInHead p t + TStart { tStartName = "input" } -> do + if case tokenGetAttr "type" t of + Nothing -> True + Just a -> bsLower (tAttrName a) /= "hidden" + then anythingElse + else do + warn "hidden input" + insertHtmlElement p t + elementStackPop p + selfClosingAcknowledge p + TStart { tStartName = "form" } -> do + warn "form start tag" + unlessM (elementStackHasTemplate p ||^ formNotNull p) $ do + insertHtmlElement p t + saveForm p + elementStackPop p + TEOF -> + doModeInBody p t + _otherwise -> + anythingElse + where + clearToTableContext = + elementStackPopWhile p $ \x -> not $ elem (domNodeType x) $ + domTypesHTML ["table", "template", "html"] + anythingElse = do + warn "unexpected token" + fosterParentingSet p + doModeInBody p t + fosterParentingClear p + warn x = + parseError p (Just t) $ "in table " <> x + +-- | Handle the in-table-text insertion mode. +doModeInTableText :: Parser s -> Token -> ST s () +doModeInTableText p @ Parser {..} t = + case t of + TChar {} -> + pendingTableCharAppend p t + _otherwise -> do + a <- pendingTableChars p + if any (not . chrWhitespace . tCharData) a + then do + warn "unexpected character" + fosterParentingSet p + mapM_ (doModeInBody p) a + fosterParentingClear p + else do + mapM_ (insertChar p) a + restoreMode p + reprocess p t + where + warn x = + parseError p (Just t) $ "in table text " <> x + +-- | Handle the in-caption insertion mode. +doModeInCaption :: Parser s -> Token -> ST s () +doModeInCaption p @ Parser {..} t = + case t of + TEnd { tEndName = x@"caption" } -> + processCaption + TStart { tStartName = x } | elem x + ["caption", "col", "colgroup", + "tbody", "td", "tfoot", "th", "thead", "tr"] -> do + processCaption + reprocess p t + TEnd { tEndName = "table" } -> do + processCaption + reprocess p t + TEnd { tEndName = x } | elem x + ["body", "col", "colgroup", "html", + "tbody", "td", "tfoot", "th", "thead", "tr"] -> + warn "unexpected end tag" + _otherwise -> + doModeInBody p t + where + processCaption = do + let a = domMakeTypeHTML "caption" + elementInTableScope p a >>= \case + False -> + warn "no caption in table scope" + True -> do + generateImpliedEndTags p + unlessM (currentNodeHasType p a) $ + warn "current node is not a caption" + elementStackPopUntilType p a + activeFormatClear p + setMode p ModeInTable + warn x = + parseError p (Just t) $ "in caption " <> x + +-- | Handle the in-column-group insertion mode. +doModeInColumnGroup :: Parser s -> Token -> ST s () +doModeInColumnGroup p @ Parser {..} t = + case t of + TChar {..} | chrWhitespace tCharData -> + insertChar p t + TComment {} -> + insertComment p t + TDoctype {} -> + warn "doctype" + TStart { tStartName = "html" } -> + doModeInBody p t + TStart { tStartName = "col" } -> do + insertHtmlElement p t + elementStackPop p + selfClosingAcknowledge p + TEnd { tEndName = x@"colgroup" } -> do + let a = domMakeTypeHTML x + currentNodeHasType p a >>= \case + False -> + warn "current node not colgroup end" + True -> do + elementStackPop p + setMode p ModeInTable + TEnd { tEndName = "col" } -> + warn "col end tag" + TStart { tStartName = "template" } -> + doModeInHead p t + TEnd { tEndName = "template" } -> + doModeInHead p t + TEOF -> + doModeInBody p t + _otherwise -> do + let a = domMakeTypeHTML "colgroup" + currentNodeHasType p a >>= \case + False -> + warn "current node not colgroup end" + True -> do + elementStackPop p + setMode p ModeInTable + reprocess p t + where + warn x = + parseError p (Just t) $ "in column group " <> x + +-- | Handle the in-table-body insertion mode. +doModeInTableBody :: Parser s -> Token -> ST s () +doModeInTableBody p @ Parser {..} t = + case t of + TStart { tStartName = "tr" } -> do + clearToTableBodyContext + insertHtmlElement p t + setMode p ModeInRow + TStart { tStartName = x } | elem x ["th", "td"] -> do + warn "th or td missing tr" + clearToTableBodyContext + insertHtmlElementNamed p "tr" + setMode p ModeInRow + reprocess p t + TEnd { tEndName = x } | elem x + ["tbody", "tfoot", "thead"] -> do + let a = domMakeTypeHTML x + elementInTableScope p a >>= \case + False -> + warn "element not in table scope" + True -> do + clearToTableBodyContext + elementStackPop p + setMode p ModeInTable + TStart { tStartName = x } | elem x + ["caption", "col", "colgroup", "tbody", "tfoot", "thead"] -> + processElements + TEnd { tEndName = "table" } -> + processElements + TEnd { tEndName = x } | elem x + ["body", "caption", "col", "colgroup", "html", "td", "th", "tr"] -> + warn "unexpected end tag" + _otherwise -> + doModeInTable p t + where + processElements = do + anyM (elementInTableScope p . domMakeTypeHTML) + ["tbody", "tfoot", "thead"] >>= \case + False -> + warn "element not in table scope" + True -> do + clearToTableBodyContext + elementStackPop p + setMode p ModeInTable + reprocess p t + clearToTableBodyContext = + elementStackPopWhile p $ \x -> not $ elem (domNodeType x) $ + domTypesHTML ["tbody", "tfoot", "thead", "template", "html"] + warn x = + parseError p (Just t) $ "in table body " <> x + +-- | Handle the in-row insertion mode. +doModeInRow :: Parser s -> Token -> ST s () +doModeInRow p @ Parser {..} t = + case t of + TStart { tStartName = x } | elem x ["th", "td"] -> do + clearToTableRowContext + insertHtmlElement p t + setMode p ModeInCell + activeFormatAddMarker p + TEnd { tEndName = "tr" } -> + processTr + TStart { tStartName = x } | elem x + ["caption", "col", "colgroup", "tbody", "tfoot", "thead", "tr"] -> do + processTr + reprocess p t + TEnd { tEndName = "table" } -> do + processTr + reprocess p t + TEnd { tEndName = x } | elem x + ["tbody", "tfoot", "thead"] -> do + let a = domMakeTypeHTML x + b = domMakeTypeHTML "tr" + elementInTableScope p a >>= \case + False -> + warn "element not in table scope" + True -> + whenM (elementInTableScope p b) $ do + clearToTableRowContext + elementStackPop p + setMode p ModeInTableBody + reprocess p t + TEnd { tEndName = x } | elem x + ["body", "caption", "col", "colgroup", "html", "td", "th"] -> + warn "unexpected end tag" + _otherwise -> + doModeInTable p t + where + processTr = do + let a = domMakeTypeHTML "tr" + elementInTableScope p a >>= \case + False -> + warn "element not in table scope" + True -> do + clearToTableRowContext + elementStackPop p + setMode p ModeInTableBody + clearToTableRowContext = + elementStackPopWhile p $ \x -> not $ elem (domNodeType x) $ + domTypesHTML ["tr", "template", "html"] + warn x = + parseError p (Just t) $ "in row " <> x + +-- | Handle the in-cell insertion mode. +doModeInCell :: Parser s -> Token -> ST s () +doModeInCell p @ Parser {..} t = + case t of + TEnd { tEndName = x } | elem x ["td", "th"] -> do + let a = domMakeTypeHTML x + elementInTableScope p a >>= \case + False -> + warn "element not in table scope" + True -> do + generateImpliedEndTags p + unlessM (currentNodeHasType p a) $ + warn $ "current node not " <> x + elementStackPopUntilType p a + activeFormatClear p + setMode p ModeInRow + TStart { tStartName = x } | elem x + ["caption", "col", "colgroup", + "tbody", "td", "tfoot", "th", "thead", "tr"] -> do + anyM (elementInTableScope p . domMakeTypeHTML) ["td", "th"] >>= \case + False -> + warn "td or th not in table scope" + True -> do + closeCell + reprocess p t + TEnd { tEndName = x } | elem x + ["body", "caption", "col", "colgroup", "html"] -> + warn "unexpected end tag" + TEnd { tEndName = x } | elem x + ["table", "tbody", "tfoot", "thead", "tr"] -> do + let a = domMakeTypeHTML x + elementInTableScope p a >>= \case + False -> + warn "element not in table scope" + True -> do + closeCell + reprocess p t + _otherwise -> + doModeInBody p t + where + closeCell = do + let a = domTypesHTML ["td", "th"] + generateImpliedEndTags p + unlessM (currentNodeHasTypeIn p a) $ + warn "current node is not td or th" + elementStackPopUntilTypeIn p a + activeFormatClear p + setMode p ModeInRow + warn x = + parseError p (Just t) $ "in cell " <> x + +-- | Handle the in-select insertion mode. +doModeInSelect :: Parser s -> Token -> ST s () +doModeInSelect p @ Parser {..} t = + case t of + TChar {} -> + insertChar p t + TComment {} -> + insertComment p t + TDoctype {} -> + warn "doctype" + TStart { tStartName = "html" } -> + doModeInBody p t + TStart { tStartName = x@"option" } -> do + elementStackPopIf p $ elementName x + insertHtmlElement p t + TStart { tStartName = x@"optgroup" } -> do + elementStackPopIf p $ elementName "option" + elementStackPopIf p $ elementName x + insertHtmlElement p t + TEnd { tEndName = x@"optgroup" } -> do + let a = domMakeTypeHTML "option" + b = domMakeTypeHTML x + y <- take 2 <$> elementStackTypes p + when (y == [a,b]) $ elementStackPop p + currentNodeHasType p b >>= \case + False -> + warn $ "current node not " <> x + True -> + elementStackPop p + TEnd { tEndName = x@"option" } -> do + currentNodeHasType p (domMakeTypeHTML x) >>= \case + False -> + warn $ "current node not " <> x + True -> + elementStackPop p + TEnd { tEndName = x@"select" } -> do + let a = domMakeTypeHTML x + elementInSelectScope p a >>= \case + False -> + warn "no select in select scope" + True -> do + elementStackPopUntilType p a + resetInsertionMode p + TStart { tStartName = x@"select" } -> do + warn "unexpected start tag" + let a = domMakeTypeHTML x + whenM (elementInSelectScope p a) $ do + elementStackPopUntilType p a + resetInsertionMode p + TStart { tStartName = x } | elem x + ["input", "keygen", "textarea"] -> do + warn "unexpected start tag" + let a = domMakeTypeHTML x + whenM (elementInSelectScope p a) $ do + elementStackPopUntilType p a + resetInsertionMode p + reprocess p t + TStart { tStartName = x } | elem x + ["script", "template"] -> + doModeInHead p t + TEnd { tEndName = "template" } -> + doModeInHead p t + TEOF -> + doModeInBody p t + _otherwise -> + warn "unexpected token" + where + warn x = + parseError p (Just t) $ "in select " <> x + +-- | Handle the in-select-in-table insertion mode. +doModeInSelectInTable :: Parser s -> Token -> ST s () +doModeInSelectInTable p @ Parser {..} t = + case t of + TStart { tStartName = x } | elem x + ["caption", "table", "tbody", "tfoot", + "thead", "tr", "td", "th"] -> do + warn "unexpected start tag" + elementStackPopUntilType p $ domMakeTypeHTML "select" + resetInsertionMode p + reprocess p t + TEnd { tEndName = x } | elem x + ["caption", "table", "tbody", "tfoot", + "thead", "tr", "td", "th"] -> do + warn "unexpected end tag" + whenM (elementInTableScope p $ domMakeTypeHTML x) $ do + elementStackPopUntilType p $ domMakeTypeHTML "select" + resetInsertionMode p + reprocess p t + _otherwise -> + doModeInSelect p t + where + warn x = + parseError p (Just t) $ "in select in table " <> x + +-- | Handle the in-template insertion mode. +doModeInTemplate :: Parser s -> Token -> ST s () +doModeInTemplate p @ Parser {..} t = + case t of + TChar {} -> + doModeInBody p t + TComment {} -> + doModeInBody p t + TDoctype {} -> + doModeInBody p t + TStart { tStartName = x } | elem x + ["base", "basefont", "bgsound", "link", "meta", + "noframes", "script", "style", "template", "title"] -> + doModeInHead p t + TEnd { tEndName = "template" } -> + doModeInHead p t + TStart { tStartName = x } | elem x + ["caption", "col", "tbody", "tfoot", "thead"] -> do + templateModePop p + templateModePush p ModeInTable + setMode p ModeInTable + reprocess p t + TStart { tStartName = "col" } -> do + templateModePop p + templateModePush p ModeInColumnGroup + setMode p ModeInColumnGroup + reprocess p t + TStart { tStartName = "tr" } -> do + templateModePop p + templateModePush p ModeInTableBody + setMode p ModeInTableBody + reprocess p t + TStart { tStartName = x } | elem x ["td", "th"] -> do + templateModePop p + templateModePush p ModeInRow + setMode p ModeInRow + reprocess p t + TStart {} -> do + templateModePop p + templateModePush p ModeInBody + setMode p ModeInBody + reprocess p t + TEnd {} -> + warn "unexpected end tag" + TEOF -> + elementStackMissingTemplate p >>= \case + True -> + parserSetDone p + False -> do + warn "template on stack" + activeFormatClear p + templateModePop p + resetInsertionMode p + reprocess p t + where + warn x = + parseError p (Just t) $ "in template " <> x + +-- | Handle the after-body insertion mode. +doModeAfterBody :: Parser s -> Token -> ST s () +doModeAfterBody p @ Parser {..} t = + case t of + TChar {..} | chrWhitespace tCharData -> + doModeInBody p t + TComment {} -> do + x <- domPos . fromJust <$> lastNodeID p + commentMake p t >>= void . insertNewNode p x + TDoctype {} -> + warn "doctype" + TStart { tStartName = "html" } -> + doModeInBody p t + TEnd { tEndName = "html" } -> + rref parserFragmentMode >>= \case + True -> + warn "html end tag" + False -> + setMode p ModeAfterAfterBody + TEOF -> + parserSetDone p + _otherwise -> do + warn "unexpected token" + setMode p ModeInBody + reprocess p t + where + warn x = + parseError p (Just t) $ "after body " <> x + +-- | Handle the in-frameset insertion mode. +doModeInFrameset :: Parser s -> Token -> ST s () +doModeInFrameset p @ Parser {..} t = + case t of + TChar {..} | chrWhitespace tCharData -> + insertChar p t + TComment {} -> + insertComment p t + TDoctype {} -> + warn "doctype" + TStart { tStartName = "html" } -> + doModeInBody p t + TStart { tStartName = "frameset" } -> + insertHtmlElement p t + TEnd { tEndName = "frameset" } -> do + currentNodeHasHTMLType p "html" >>= \case + True -> + warn "current node is html" + False -> do + elementStackPop p + whenM (notM (rref parserFragmentMode) &&^ + notM (currentNodeHasHTMLType p "frameset")) $ + setMode p ModeAfterFrameset + TStart { tStartName = "frame" } -> do + insertHtmlElement p t + elementStackPop p + selfClosingAcknowledge p + TStart { tStartName = "noframes" } -> + doModeInHead p t + TEOF -> do + unlessM (currentNodeHasHTMLType p "html") $ + warn "current node is not html" + parserSetDone p + _ -> + warn "unexpected token" + where + warn x = + parseError p (Just t) $ "in frameset " <> x + +-- | Handle the after-frameset insertion mode. +doModeAfterFrameset :: Parser s -> Token -> ST s () +doModeAfterFrameset p @ Parser {..} t = + case t of + TChar {..} | chrWhitespace tCharData -> + insertChar p t + TComment {} -> + insertComment p t + TDoctype {} -> + warn "doctype" + TStart { tStartName = "html" } -> + doModeInBody p t + TEnd { tEndName = "html" } -> + setMode p ModeAfterAfterFrameset + TStart { tStartName = "noframes" } -> + doModeInHead p t + TEOF -> + parserSetDone p + _ -> + warn "unexpected token" + where + warn x = + parseError p (Just t) $ "after frameset " <> x + +-- | Handle the after-after-body insertion mode. +doModeAfterAfterBody :: Parser s -> Token -> ST s () +doModeAfterAfterBody p @ Parser {..} t = + case t of + TComment {} -> + insertDocComment p t + TDoctype {} -> + doModeInBody p t + TChar {..} | chrWhitespace tCharData -> + doModeInBody p t + TStart { tStartName = "html" } -> + doModeInBody p t + TEOF -> + parserSetDone p + _otherwise -> do + warn "unexpected token" + setMode p ModeInBody + reprocess p t + where + warn x = + parseError p (Just t) $ "after after body " <> x + +-- | Handle the after-after-frameset insertion mode. +doModeAfterAfterFrameset :: Parser s -> Token -> ST s () +doModeAfterAfterFrameset p @ Parser {..} t = + case t of + TComment {} -> + insertDocComment p t + TDoctype {} -> + doModeInBody p t + TChar {..} | chrWhitespace tCharData -> + doModeInBody p t + TStart { tStartName = "html" } -> + doModeInBody p t + TEOF -> + parserSetDone p + TStart { tStartName = "noframes" } -> + doModeInHead p t + _otherwise -> do + warn "unexpected token" + where + warn x = + parseError p (Just t) $ "after after frameset " <> x + +-- | Handle foreign content. +doForeignContent :: Parser s -> Token -> ST s () +doForeignContent p @ Parser {..} t = + case t of + TChar {..} | chrWhitespace tCharData -> + insertChar p t + TChar {} -> do + insertChar p t + frameSetNotOK p + TComment {} -> + insertComment p t + TDoctype {} -> + warn "doctype" + TStart { tStartName = x } | elem x + ["b", "big", "blockquote", "body", "br", "center", + "code", "dd", "div", "dl", "dt", "em", "embed", + "h1", "h2", "h3", "h4", "h5", "h6", "head", + "hr", "i", "img", "li", "listing", "menu", + "meta", "nobr", "ol", "p", "pre", "ruby", "s", + "small", "span", "strong", "strike", "sub", + "sup", "table", "tt", "u", "ul", "var"] + || x == "font" && + any (flip tokenHasAttr t) ["color","face","size"] -> do + warn "unexpected start tag" + rref parserFragmentMode >>= \case + True -> + anyOtherStartTag + False -> do + elementStackPop p + elementStackPopWhile p $ \n -> + not (isMathMLIntegrationPoint n + || isHtmlIntgrationPoint n + || domNodeIsHTML n) + reprocess p t + TStart {} -> + anyOtherStartTag + TEnd {} -> do + let s = "script" + a = domMakeTypeSVG s + n = tEndName t + svg <- maybe False ((==) a . domNodeType) <$> currentNode p + if n == s && svg + then doScriptEndTag + else do + node <- fromJust <$> currentNode p + let h = bsLower . domNodeElementName + nodeName = h node + when (nodeName /= n) $ + warn $ + "bad end tag in foreign content (" + <> nodeName <> " /= " <> bcPack (show n) <> ")" + let f (x:[]) = pure () + f (x:y:ys) + | h x == n = + elementStackPopUntilID p $ domNodeID node + | domNodeIsHTML y = + doHtmlContent p t + | otherwise = + f (y:ys) + elementStackNodes p >>= f + where + anyOtherStartTag = do + (t', n) <- adjustedCurrentNode p >>= \case + Just a + | domNodeIsMathML a -> + pure ( adjustAttrMathML t + , domNodeElementNamespace a + ) + | domNodeIsSVG a -> + pure ( adjustElemSVG $ adjustAttrSVG t + , domNodeElementNamespace a + ) + Nothing -> + pure (t, HTMLNamespaceHTML) + insertForeignElement p n $ adjustAttrForeign t' + when (tStartClosed t) $ do + svg <- maybe False domNodeIsSVG <$> currentNode p + if tStartName t == "script" && svg + then do + selfClosingAcknowledge p + doScriptEndTag + else do + elementStackPop p + selfClosingAcknowledge p + doScriptEndTag = do + elementStackPop p + warn x = + parseError p (Just t) $ "foreign content " <> x diff --git a/src/Zenacy/HTML/Internal/Query.hs b/src/Zenacy/HTML/Internal/Query.hs new file mode 100644 --- /dev/null +++ b/src/Zenacy/HTML/Internal/Query.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | A basic query facility. +module Zenacy.HTML.Internal.Query + ( HTMLQuery + , htmlQueryRun + , htmlQueryExec + , htmlQueryTry + , htmlQueryStop + , htmlQueryCont + , htmlQuerySucc + , htmlQueryZipper + , htmlQueryNode + , htmlQueryFirst + , htmlQueryLast + , htmlQueryNext + , htmlQueryPrev + , htmlQueryUp + , htmlQueryTest + , htmlQueryName + , htmlQueryIsFirst + , htmlQueryIsLast + , htmlQuerySave + , htmlQueryGet + , htmlQueryGetZipper + , htmlQuerySrc + , htmlQueryAttr + , htmlQueryAttrVal + , htmlQueryId + , htmlQueryHasClass + , htmlQueryOnly + ) where + +import Prelude +import Zenacy.HTML.Internal.HTML +import Zenacy.HTML.Internal.Oper +import Zenacy.HTML.Internal.Zip +import Control.Monad.State + ( MonadState + , State + , evalState + , modify + , gets + ) +import Control.Monad.Trans.Maybe + ( MaybeT(..) + , runMaybeT + ) +import Data.Bool + ( bool + ) +import Data.IntMap + ( IntMap + ) +import qualified Data.IntMap as IntMap + ( fromList + , lookup + , insert + ) +import Data.Maybe + ( fromMaybe + , isNothing + ) +import Data.Text + ( Text + ) + +-- | Defines the query state. +type QueryState = (HTMLZipper, IntMap HTMLZipper) + +-- | Defines the type for a query. +newtype HTMLQuery a = HTMLQuery { htmlQueryState :: MaybeT (State QueryState) a } + deriving (Functor, Applicative, Monad, MonadState QueryState) + +-- | Runs a query and returns a result. +htmlQueryRun :: HTMLNode -> HTMLQuery a -> Maybe a +htmlQueryRun x q = evalState (runMaybeT $ htmlQueryState q) s + where + z = htmlZip x + s = (z, IntMap.fromList [(0,z)]) + +-- | Same as run with the arguments flipped. +htmlQueryExec :: HTMLQuery a -> HTMLNode -> Maybe a +htmlQueryExec = flip htmlQueryRun + +-- | Same as run with the arguments flipped. +htmlQueryTry :: HTMLQuery HTMLNode -> HTMLNode -> HTMLNode +htmlQueryTry q x = fromMaybe x $ htmlQueryRun x q + +-- | Wraps a value as a query result. +htmlQueryWrap :: Maybe a -> HTMLQuery a +htmlQueryWrap = HTMLQuery . MaybeT . pure + +-- | Returns a result that stops the query. +htmlQueryStop :: HTMLQuery a +htmlQueryStop = htmlQueryWrap $ Nothing + +-- | Returns a result that continues the query. +htmlQueryCont :: HTMLQuery () +htmlQueryCont = htmlQuerySucc () + +-- | Returns a successful query result. +htmlQuerySucc :: a -> HTMLQuery a +htmlQuerySucc = htmlQueryWrap . Just + +-- | Gets the current query zipper. +htmlQueryZipper :: HTMLQuery HTMLZipper +htmlQueryZipper = gets fst + +-- | Gets the current query node. +htmlQueryNode :: HTMLQuery HTMLNode +htmlQueryNode = htmlZipNode <$> htmlQueryZipper + +-- | Performs a query step with a zipper operation. +withZip :: (HTMLZipper -> Maybe HTMLZipper) -> HTMLQuery () +withZip f = do + z <- htmlQueryZipper + case f z of + Nothing -> + htmlQueryStop + Just z' -> do + modify $ \(_, m) -> (z', m) + htmlQueryCont + +-- | Moves the query to the first child node. +htmlQueryFirst :: HTMLQuery () +htmlQueryFirst = withZip htmlZipFirst + +-- | Moves the query to the last child node. +htmlQueryLast :: HTMLQuery () +htmlQueryLast = withZip htmlZipLast + +-- | Moves the query to the next sibling node. +htmlQueryNext :: HTMLQuery () +htmlQueryNext = withZip htmlZipNext + +-- | Moves the query to the previous sibling node. +htmlQueryPrev :: HTMLQuery () +htmlQueryPrev = withZip htmlZipPrev + +-- | Moves the query to the parent node. +htmlQueryUp :: HTMLQuery () +htmlQueryUp = withZip htmlZipUp + +-- | Evaluates a test result and continues the query if true. +htmlQueryTest :: Bool -> HTMLQuery () +htmlQueryTest = bool htmlQueryStop htmlQueryCont + +-- | Tests the current element name. +htmlQueryName :: Text -> HTMLQuery () +htmlQueryName x = do + n <- htmlQueryNode + htmlQueryTest $ htmlElemName n == x + +-- | Tests the current node to see if it is the first sibling. +htmlQueryIsFirst :: HTMLQuery () +htmlQueryIsFirst = do + z <- htmlQueryZipper + htmlQueryTest $ isNothing $ htmlZipPrev z + +-- | Tests the current node to see if it is the last sibling. +htmlQueryIsLast :: HTMLQuery () +htmlQueryIsLast = do + z <- htmlQueryZipper + htmlQueryTest $ isNothing $ htmlZipNext z + +-- | Saves the current query state. +htmlQuerySave :: Int -> HTMLQuery () +htmlQuerySave x = do + modify $ \(z, m) -> (z, IntMap.insert x z m) + htmlQueryCont + +-- | Gets a saved query node. +htmlQueryGet :: Int -> HTMLQuery HTMLNode +htmlQueryGet x = htmlZipNode <$> htmlQueryGetZipper x + +-- | Gets a saved query zipper. +htmlQueryGetZipper :: Int -> HTMLQuery HTMLZipper +htmlQueryGetZipper x = do + m <- gets snd + case IntMap.lookup x m of + Just z -> htmlQuerySucc z + Nothing -> htmlQueryStop + +-- | Gets the source input node. +htmlQuerySrc :: HTMLQuery HTMLNode +htmlQuerySrc = htmlQueryGet 0 + +-- | Tests if the current node has an attribute. +htmlQueryAttr :: Text -> HTMLQuery () +htmlQueryAttr x = htmlQueryNode >>= htmlQueryTest . htmlElemHasAttrName x + +-- | Tests if the current node has an attribute value. +htmlQueryAttrVal :: Text -> Text -> HTMLQuery () +htmlQueryAttrVal n v = htmlQueryNode >>= htmlQueryTest . htmlElemHasAttrVal n v + +-- | Tests if the current node has an id. +htmlQueryId :: Text -> HTMLQuery () +htmlQueryId x = htmlQueryNode >>= htmlQueryTest . htmlElemHasID x + +-- | Tests if the current node has a class. +htmlQueryHasClass :: Text -> HTMLQuery () +htmlQueryHasClass x = htmlQueryNode >>= htmlQueryTest . htmlElemClassesContains x + +-- | Moves to the child and require that it is the only child. +htmlQueryOnly :: Text -> HTMLQuery () +htmlQueryOnly x = htmlQueryFirst >> htmlQueryName x >> htmlQueryIsLast diff --git a/src/Zenacy/HTML/Internal/Render.hs b/src/Zenacy/HTML/Internal/Render.hs new file mode 100644 --- /dev/null +++ b/src/Zenacy/HTML/Internal/Render.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Defines the HTML render. +module Zenacy.HTML.Internal.Render + ( htmlPrint + , htmlPrintPretty + , htmlRender + , htmlRenderContent + , htmlRenderNodes + , htmlRenderPretty + ) where + +import Zenacy.HTML.Internal.Core +import Zenacy.HTML.Internal.HTML +import Zenacy.HTML.Internal.Oper +import Data.Monoid + ( (<>) + ) +import Data.Text + ( Text + ) +import qualified Data.Text as T + ( append + , concat + , empty + , intercalate + , replace + ) +import qualified Data.Text.IO as T + ( putStrLn + ) + +-- | The rendering mode. +data HTMLRenderMode + = HTMLRenderNormal + | HTMLRenderPretty + deriving (Show, Eq, Ord) + +-- | Prints an HTML document. +htmlPrint :: HTMLNode -> IO () +htmlPrint = T.putStrLn . htmlRender + +-- | Pretty prints an HTML document. +htmlPrintPretty :: HTMLNode -> IO () +htmlPrintPretty = T.putStrLn . htmlRenderPretty + +-- | Renders an HTML document. +htmlRender :: HTMLNode -> Text +htmlRender = renderModal HTMLRenderNormal + +-- | Renders the contents of a node +htmlRenderContent :: HTMLNode -> Text +htmlRenderContent = htmlRenderNodes . htmlNodeContent + +-- | Renders a list of nodes. +htmlRenderNodes :: [HTMLNode] -> Text +htmlRenderNodes = T.concat . map htmlRender + +-- | Renders an HTML document using pretty printing. +htmlRenderPretty :: HTMLNode -> Text +htmlRenderPretty = renderModal HTMLRenderPretty + +-- | Renders an HTML document with a styling mode. +renderModal :: HTMLRenderMode -> HTMLNode -> Text +renderModal m = go 0 "" + where + go level parent node = + case node of + HTMLDocument _ c -> + join $ map (go level parent) c + HTMLDoctype n p s -> + indent <> renderDoctype n p s + HTMLFragment n c -> + join $ map (go level parent) c + HTMLElement n s a c -> + indent + <> renderElemStart n a + <> if voidTag n + then T.empty + else (if | genLF n c -> "\n" + | oneLine c -> T.empty + | otherwise -> sep) + <> (join $ map (go (if oneLine c then 0 else level') n) c) + <> (if | oneLine c -> T.empty + | null c -> indent + | otherwise -> sep <> indent) + <> renderElemEnd n + HTMLTemplate s a c -> + indent <> renderElemStart tmp a + <> sep <> go level' tmp c + <> sep <> indent <> renderElemEnd tmp + HTMLText t -> + indent <> renderText t parent + HTMLComment c -> + indent <> renderComment c + where + level' = level + 1 + join = T.intercalate sep + indent = case m of + HTMLRenderNormal -> T.empty + HTMLRenderPretty -> textBlank level + sep = case m of + HTMLRenderNormal -> T.empty + HTMLRenderPretty -> "\n" + tmp = "template" + voidTag x = elem x + ["area", "base", "basefont", "bgsound", "br", "col", + "embed", "frame", "hr", "img", "input", "keygen", + "link", "meta", "param", "source", "track", "wbr"] + genLF x c = elem x ["pre", "textarea", "listing"] && oneText c + oneText (HTMLText {}:[]) = True + oneText _ = False + oneLine x = oneText x || null x + +-- | Renders text for a doctype. +renderDoctype :: Text -> Maybe Text -> Maybe Text -> Text +renderDoctype x y z = " x <> f y <> f z <> ">" + where + f = maybe "" (T.append " ") + +-- | Returns text for an attribute. +renderAttr :: HTMLAttr -> Text +renderAttr (HTMLAttr n v s) = + " " <> n' <> "=\"" <> escapeString True v <> "\"" + where + n' = case s of + HTMLAttrNamespaceNone -> n + HTMLAttrNamespaceXLink -> "xlink:" <> n + HTMLAttrNamespaceXML -> "xml:" <> n + HTMLAttrNamespaceXMLNS -> + if n == "xmlns" then n else "xmlns:" <> n + +-- | Returns text for a list of attributes. +renderAttrList :: [HTMLAttr] -> Text +renderAttrList = T.concat . map renderAttr + +-- | Returns text for a start element. +renderElemStart :: Text -> [HTMLAttr] -> Text +renderElemStart x y = "<" <> x <> renderAttrList y <> ">" + +-- | Returns text for an end element. +renderElemEnd :: Text -> Text +renderElemEnd x = " x <> ">" + +-- | Renders a text value. +renderText :: Text -> Text -> Text +renderText x parent = + if parent `elem` a then x else escapeString False x + where a = ["style", "script", "xmp", "iframe", + "noembed", "noframes", "plaintext"] + +-- | Renders text for a comment element. +renderComment :: Text -> Text +renderComment x = "" + +-- | Escapes a string for serialization. +escapeString :: Bool -> Text -> Text +escapeString attributeMode = + f . T.replace "\x00A0" " " + -- . T.replace "&" "&" -- TODO: consider if this is needed + where + f = if attributeMode + then T.replace "\"" """ + else T.replace ">" ">" + . T.replace "<" "<" diff --git a/src/Zenacy/HTML/Internal/Token.hs b/src/Zenacy/HTML/Internal/Token.hs new file mode 100644 --- /dev/null +++ b/src/Zenacy/HTML/Internal/Token.hs @@ -0,0 +1,695 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Defines a token type used by the lexer. +module Zenacy.HTML.Internal.Token + ( Token(..) + , TokenBuffer(..) + , TAttr(..) + , tokenAttr + , tokenHasAttr + , tokenGetAttr + , tokenGetAttrVal + , tokenBuffer + , tokenCapacity + , tokenReset + , tokenTail + , tokenFirst + , tokenNext + , tokenCount + , tokenOffset + , tokenList + , tokenDrop + , tokenHasEOF + , tokenSlice + , tokenTagStartName + , tokenTagEndName + , tokenDoctypeType + , tokenTagStartType + , tokenTagEndType + , tokenCommentType + , tokenCharType + , tokenEOFType + , tokenDoctypeInit + , tokenDoctypeNameAppend + , tokenDoctypeSetForceQuirks + , tokenDoctypePublicIdInit + , tokenDoctypePublicIdAppend + , tokenDoctypeSystemIdInit + , tokenDoctypeSystemIdAppend + , tokenTagStartInit + , tokenTagStartSetSelfClosing + , tokenTagEndInit + , tokenTagNameAppend + , tokenAttrInit + , tokenAttrNameAppend + , tokenAttrValAppend + , tokenAttrNamePrune + , tokenCommentInit + , tokenCommentAppend + , tokenCharInit + , tokenEOFInit + , tokenType + , tokenSize + , tokenPack + ) where + +import Zenacy.HTML.Internal.BS +import Zenacy.HTML.Internal.Buffer +import Zenacy.HTML.Internal.Core +import Zenacy.HTML.Internal.Types +import Control.Monad + ( when + , forM + ) +import Control.Monad.Extra + ( anyM + ) +import Control.Monad.ST + ( ST + ) +import Data.STRef + ( STRef + , newSTRef + , readSTRef + , writeSTRef + ) +import Data.DList + ( DList + ) +import qualified Data.DList as D + ( empty + , snoc + , toList + ) +import Data.List + ( find + , or + ) +import Data.Maybe + ( catMaybes + , isJust + ) +import Data.Vector.Unboxed.Mutable + ( MVector + ) +import qualified Data.Vector.Unboxed.Mutable as U + ( new + , length + , read + , write + , grow + ) +import Data.Word + ( Word8 + ) + +-- | Defines the token type. +-- The token type is used for testing and debugging only. +data Token + = TDoctype + { tDoctypeName :: !BS + , tDoctypeQuirks :: !Bool + , tDoctypePublic :: !(Maybe BS) + , tDoctypeSystem :: !(Maybe BS) + } + | TStart + { tStartName :: !BS + , tStartClosed :: !Bool + , tStartAttr :: ![TAttr] + } + | TEnd + { tEndName :: !BS + } + | TComment + { tCommentData :: !BS + } + | TChar + { tCharData :: !Word8 + } + | TEOF + deriving (Eq, Ord, Show) + +-- | An HTML element attribute type. +data TAttr = TAttr + { tAttrName :: BS + , tAttrVal :: BS + , tAttrNamespace :: HTMLAttrNamespace + } deriving (Eq, Ord, Show) + +-- | A type of buffer used to hold tokens. +data TokenBuffer s = TokenBuffer + { tbCntl :: MVector s Int + , tbData :: MVector s Word8 + } + +-- | Makes an attribute. +tokenAttr :: BS -> BS -> TAttr +tokenAttr n v = TAttr n v HTMLAttrNamespaceNone + +-- | Determines if a token has an attribute. +tokenHasAttr :: BS -> Token -> Bool +tokenHasAttr x t = isJust $ tokenGetAttr x t + +-- | Finds an attribute in a token. +tokenGetAttr :: BS -> Token -> Maybe TAttr +tokenGetAttr x = \case + TStart{..} -> find (\TAttr{..} -> tAttrName == x) tStartAttr + _otherwise -> Nothing + +-- | Finds an attribute value for a token. +tokenGetAttrVal :: BS -> Token -> Maybe BS +tokenGetAttrVal x t = tAttrVal <$> tokenGetAttr x t + +-- | Makes a new token buffer. +tokenBuffer :: ST s (STRef s (TokenBuffer s)) +tokenBuffer = do + c <- U.new 100 + d <- U.new 100 + r <- newSTRef (TokenBuffer c d) + tokenReset r + pure r + +-- | Gets the capacity of the buffer. +tokenCapacity :: STRef s (TokenBuffer s) -> ST s (Int, Int) +tokenCapacity r = do + TokenBuffer{..} <- readSTRef r + pure (U.length tbCntl, U.length tbData) + +-- | Size of the buffer header. +headerSize :: Int +headerSize = 4 + +-- | Resets a token buffer. +tokenReset :: STRef s (TokenBuffer s) -> ST s () +tokenReset r = do + TokenBuffer{..} <- readSTRef r + U.write tbCntl 0 1 -- data buffer length (skip first byte) + U.write tbCntl 1 0 -- token list head offset + U.write tbCntl 2 0 -- token list tail offset + U.write tbCntl 3 0 -- token emit offset + U.write tbData 0 0 -- first byte is unsed + +-- | Get the token buffer tail offset. +tokenTail :: STRef s (TokenBuffer s) -> ST s Int +tokenTail r = do + TokenBuffer{..} <- readSTRef r + U.read tbCntl 2 + +-- | Positions the emitter to the first token and returns its offset. +tokenFirst :: STRef s (TokenBuffer s) -> ST s Int +tokenFirst r = do + TokenBuffer{..} <- readSTRef r + h <- U.read tbCntl 1 + U.write tbCntl 3 h + pure h + +-- | Positions the emitter to the next token and returns its offset. +tokenNext :: STRef s (TokenBuffer s) -> ST s Int +tokenNext r = do + TokenBuffer{..} <- readSTRef r + t <- U.read tbCntl 2 + i <- U.read tbCntl 3 + n <- U.read tbCntl (i + 1) + if i == t + then pure 0 + else do + let j = i + n + U.write tbCntl 3 j + pure j + +-- | Counts the number of tokens in the buffer. +tokenCount :: STRef s (TokenBuffer s) -> ST s Int +tokenCount r = tokenFold (\i n -> n + 1) 0 r + +-- | Gets a list of the tokens in the buffer. +tokenOffset :: STRef s (TokenBuffer s) -> ST s [Int] +tokenOffset r = D.toList <$> tokenFold (flip D.snoc) D.empty r + +-- | Gets a list of the tokens in the buffer. +tokenList :: STRef s (TokenBuffer s) -> ST s [Token] +tokenList r = tokenOffset r >>= mapM (flip tokenPack r) + +-- | Performs a fold over the token offsets in the buffer. +tokenFold :: (Int -> a -> a) -> a -> STRef s (TokenBuffer s) -> ST s a +tokenFold f a r = do + TokenBuffer{..} <- readSTRef r + i <- U.read tbCntl 3 + x <- go a tokenFirst + U.write tbCntl 3 i + pure x + where + go b g = do + i <- g r + if i == 0 + then pure b + else go (f i b) tokenNext + +-- | Drops the last token from the buffer. +tokenDrop :: STRef s (TokenBuffer s) -> ST s () +tokenDrop r = do + TokenBuffer{..} <- readSTRef r + headPtr <- U.read tbCntl 1 + tailPtr <- U.read tbCntl 2 + when (tailPtr > 0) $ do + if tailPtr == headPtr + then tokenReset r + else go tbCntl tailPtr headPtr + where + go d t i = do + n <- U.read d (i + offsetSize) + if t == i + n + then U.write d 2 i + else go d t (i + n) + +-- | Returns whether a buffer includes an EOF token. +tokenHasEOF :: STRef s (TokenBuffer s) -> ST s Bool +tokenHasEOF r = + tokenOffset r >>= anyM isEOF + where + isEOF i = (== tokenEOFType) <$> tokenType i r + +-- | Returns a slice of the data area of a token buffer. +tokenSlice :: Int -> Int -> STRef s (TokenBuffer s) -> ST s [Word8] +tokenSlice offset len r = do + TokenBuffer{..} <- readSTRef r + go tbData offset len D.empty + where + go d i 0 a = pure $ D.toList a + go d i n a = do + w <- U.read d i + go d (i + 1) (n - 1) $ D.snoc a w + +-- | Returns the start tag name at for the token at an offset. +tokenTagStartName :: Int -> STRef s (TokenBuffer s) -> ST s (Maybe [Word8]) +tokenTagStartName = tagNameIfType tokenTagStartType + +-- | Returns the end tag name at for the token at an offset. +tokenTagEndName :: Int -> STRef s (TokenBuffer s) -> ST s (Maybe [Word8]) +tokenTagEndName = tagNameIfType tokenTagEndType + +-- | Returns the start tag name at for the token at an offset. +tagNameIfType :: Int -> Int -> STRef s (TokenBuffer s) -> ST s (Maybe [Word8]) +tagNameIfType t x r = do + TokenBuffer{..} <- readSTRef r + a <- tokenType x r + if a == t + then do + o <- U.read tbCntl (x + 2) + n <- U.read tbCntl (x + 3) + Just <$> tokenSlice o n r + else + pure Nothing + +-- | Defines the type for a DOCTYPE token. +tokenDoctypeType :: Int +tokenDoctypeType = 101 + +-- | Defines the type for a start tag token. +tokenTagStartType :: Int +tokenTagStartType = 102 + +-- | Defines the type for a end tag token. +tokenTagEndType :: Int +tokenTagEndType = 103 + +-- | Defines the type for a comment token. +tokenCommentType :: Int +tokenCommentType = 104 + +-- | Defines the type for a character token. +tokenCharType :: Int +tokenCharType = 105 + +-- | Defines the type for an EOF token. +tokenEOFType :: Int +tokenEOFType = 106 + +tokenInit :: Int -> STRef s (TokenBuffer s) -> ST s (MVector s Int, Int) +tokenInit maxIndex r = do + t@TokenBuffer{..} <- readSTRef r + tailPtr <- U.read tbCntl 2 + i <- if tailPtr == 0 + then do + U.write tbCntl 1 headerSize + U.write tbCntl 2 headerSize + pure headerSize + else do + n <- U.read tbCntl (tailPtr + offsetSize) + let j = tailPtr + n + U.write tbCntl 2 j + pure j + c <- ensureCntl (i + maxIndex) t r + pure (c, i) + +-- | Defines the size of the doctype token. +tokenDoctypeSize :: Int +tokenDoctypeSize = 11 + +-- | Adds a new DOCTYPE token to the lexer. +tokenDoctypeInit :: STRef s (TokenBuffer s) -> ST s () +tokenDoctypeInit r = do + (c, i) <- tokenInit 10 r + U.write c (i + 0) tokenDoctypeType + U.write c (i + 1) tokenDoctypeSize + U.write c (i + 2) 0 -- name offset + U.write c (i + 3) 0 -- name length + U.write c (i + 4) 0 -- force quirks flag + U.write c (i + 5) 0 -- public id exists flag + U.write c (i + 6) 0 -- public id offset + U.write c (i + 7) 0 -- public id length + U.write c (i + 8) 0 -- system id exists flag + U.write c (i + 9) 0 -- system id offset + U.write c (i + 10) 0 -- system id length + +-- | Appends a character to the current DOCTYPE token. +tokenDoctypeNameAppend :: Word8 -> STRef s (TokenBuffer s) -> ST s () +tokenDoctypeNameAppend = stringAppendTail 2 + +-- | Sets the force quirks flag for the current DOCTYPE. +tokenDoctypeSetForceQuirks :: STRef s (TokenBuffer s) -> ST s () +tokenDoctypeSetForceQuirks r = do + TokenBuffer{..} <- readSTRef r + i <- U.read tbCntl 2 + U.write tbCntl (i + 4) 1 + +-- | Initializes the DOCTYPE public ID. +tokenDoctypePublicIdInit :: STRef s (TokenBuffer s) -> ST s () +tokenDoctypePublicIdInit r = do + TokenBuffer{..} <- readSTRef r + i <- U.read tbCntl 2 + U.write tbCntl (i + 5) 1 + +-- | Appends a character to the DOCTYPE public ID. +tokenDoctypePublicIdAppend :: Word8 -> STRef s (TokenBuffer s) -> ST s () +tokenDoctypePublicIdAppend = stringAppendTail 6 + +-- | Initializes the DOCTYPE system ID. +tokenDoctypeSystemIdInit :: STRef s (TokenBuffer s) -> ST s () +tokenDoctypeSystemIdInit r = do + TokenBuffer{..} <- readSTRef r + i <- U.read tbCntl 2 + U.write tbCntl (i + 8) 1 + +-- | Appends a character to the DOCTYPE system ID. +tokenDoctypeSystemIdAppend :: Word8 -> STRef s (TokenBuffer s) -> ST s () +tokenDoctypeSystemIdAppend = stringAppendTail 9 + +-- | Defines the size of an attribute record. +attrSize :: Int +attrSize = 4 + +-- | Defines the offset to the start of the attributes. +attrStart :: Int +attrStart = 6 + +-- | Defines the size of the start tag token. +tokenTagStartSize :: Int +tokenTagStartSize = 6 + +-- | Adds a new start tag to the lexer. +tokenTagStartInit :: STRef s (TokenBuffer s) -> ST s () +tokenTagStartInit r = do + (c, i) <- tokenInit 5 r + U.write c (i + 0) tokenTagStartType + U.write c (i + 1) tokenTagStartSize + U.write c (i + 2) 0 -- name offset + U.write c (i + 3) 0 -- name length + U.write c (i + 4) 0 -- self closing flag + U.write c (i + 5) 0 -- attribute count + +-- | Defines the size of the end tag token. +tokenTagEndSize :: Int +tokenTagEndSize = 4 + +-- | Adds a new end tag to the lexer. +tokenTagEndInit :: STRef s (TokenBuffer s) -> ST s () +tokenTagEndInit r = do + (c, i) <- tokenInit 3 r + U.write c (i + 0) tokenTagEndType + U.write c (i + 1) tokenTagEndSize + U.write c (i + 2) 0 -- name offset + U.write c (i + 3) 0 -- name length + +-- | Adds a new start tag to the lexer. +tokenTagStartSetSelfClosing :: STRef s (TokenBuffer s) -> ST s () +tokenTagStartSetSelfClosing r = do + TokenBuffer{..} <- readSTRef r + i <- U.read tbCntl 2 + U.write tbCntl (i + 4) 1 + +-- | Appends a character to a tag name if the token is a tag. +tokenTagNameAppend :: Word8 -> STRef s (TokenBuffer s) -> ST s () +tokenTagNameAppend = stringAppendTail 2 + +-- | Starts a new attribute +tokenAttrInit :: STRef s (TokenBuffer s) -> ST s () +tokenAttrInit r = do + t@TokenBuffer{..} <- readSTRef r + tailPtr <- U.read tbCntl 2 + m <- U.read tbCntl (tailPtr + 1) + n <- U.read tbCntl (tailPtr + 5) + let i = attrSize * n + attrStart + tailPtr + c <- ensureCntl (i + 3) t r + U.write c (i + 0) 0 -- attribute name offset + U.write c (i + 1) 0 -- attribute name length + U.write c (i + 2) 0 -- attribute value offset + U.write c (i + 3) 0 -- attribute value length + U.write c (tailPtr + 1) (m + 4) -- add attr to size of token + U.write c (tailPtr + 5) (n + 1) + +-- | Appends a character to the latest attribute name. +tokenAttrNameAppend :: Word8 -> STRef s (TokenBuffer s) -> ST s () +tokenAttrNameAppend x r = do + t@TokenBuffer{..} <- readSTRef r + tailPtr <- U.read tbCntl 2 + n <- U.read tbCntl (tailPtr + 5) + let i = attrSize * (n - 1) + attrStart + tailPtr + stringAppend (i + 0) x t r + +-- | Appends a character to the latest attribute value. +tokenAttrValAppend :: Word8 -> STRef s (TokenBuffer s) -> ST s () +tokenAttrValAppend x r = do + t@TokenBuffer{..} <- readSTRef r + tailPtr <- U.read tbCntl 2 + n <- U.read tbCntl (tailPtr + 5) + let i = attrSize * (n - 1) + attrStart + tailPtr + stringAppend (i + 2) x t r + +-- | Checks for duplicate attribute names. +-- Refer to section 12.2.5.33 for details. +tokenAttrNamePrune :: Int -> STRef s (TokenBuffer s) -> ST s Bool +tokenAttrNamePrune x r = do + t@TokenBuffer{..} <- readSTRef r + a <- U.read tbCntl (x + offsetType) + if a /= tokenTagStartType + then pure False + else do + attrCount <- U.read tbCntl (x + 5) + u <- forM [1 .. attrCount] $ \j -> do + let i = (j - 1) * attrSize + attrStart + x + no0 <- U.read tbCntl (i + 0) + nc0 <- U.read tbCntl (i + 1) + match <- forM [1 .. j - 1] $ \k -> do + let m = (k - 1) * attrSize + attrStart + x + no1 <- U.read tbCntl (m + 0) + nc1 <- U.read tbCntl (m + 1) + s0 <- tokenSlice no0 nc0 r + s1 <- tokenSlice no1 nc1 r + pure $ nc0 == nc1 && s0 == s1 + if or match + then do + U.write tbCntl (i + 0) 0 + U.write tbCntl (i + 1) 0 + pure True + else + pure False + pure $ or u + +-- | Defines the size of the comment token. +tokenCommentSize :: Int +tokenCommentSize = 4 + +-- | Adds a new comment token to the lexer. +tokenCommentInit :: STRef s (TokenBuffer s) -> ST s () +tokenCommentInit r = do + (c, i) <- tokenInit 3 r + U.write c (i + 0) tokenCommentType + U.write c (i + 1) tokenCommentSize + U.write c (i + 2) 0 -- string offset + U.write c (i + 3) 0 -- string length + +-- | Appends a character to the current comment token. +tokenCommentAppend :: Word8 -> STRef s (TokenBuffer s) -> ST s () +tokenCommentAppend = stringAppendTail 2 + +-- | Defines the size of the char token. +tokenCharSize :: Int +tokenCharSize = 3 + +-- | Initializes a text token. +tokenCharInit :: Word8 -> STRef s (TokenBuffer s) -> ST s () +tokenCharInit x r = do + t <- readSTRef r + (c, i) <- tokenInit 2 r + U.write c (i + 0) tokenCharType + U.write c (i + 1) tokenCharSize + U.write c (i + 2) (fromIntegral x) + +-- | Defines the size of the eof token. +tokenEOFSize :: Int +tokenEOFSize = 2 + +-- | Initializes an EOF token. +tokenEOFInit :: STRef s (TokenBuffer s) -> ST s () +tokenEOFInit r = do + (c, i) <- tokenInit 2 r + U.write c (i + 0) tokenEOFType + U.write c (i + 1) tokenEOFSize + +-- | Defines the token offset for the type field. +offsetType :: Int +offsetType = 0 + +-- | Defines the token offset for the size field. +offsetSize :: Int +offsetSize = 1 + +-- | Gets the type of a token. +tokenType :: Int -> STRef s (TokenBuffer s) -> ST s Int +tokenType x r = do + TokenBuffer{..} <- readSTRef r + U.read tbCntl (x + offsetType) + +-- | Gets the size of a token. +tokenSize :: Int -> STRef s (TokenBuffer s) -> ST s Int +tokenSize x r = do + TokenBuffer{..} <- readSTRef r + U.read tbCntl (x + offsetSize) + +-- | Unpacks a token at the specified index. +tokenPack :: Int -> STRef s (TokenBuffer s) -> ST s Token +tokenPack x r = do + TokenBuffer{..} <- readSTRef r + t <- U.read tbCntl x + n <- U.read tbCntl 0 + s <- bufferString tbData n + if | t == tokenDoctypeType -> packDoctype x tbCntl s + | t == tokenTagStartType -> packTagStart x tbCntl s + | t == tokenTagEndType -> packTagEnd x tbCntl s + | t == tokenCommentType -> packComment x tbCntl s + | t == tokenCharType -> packChar x tbCntl + | t == tokenEOFType -> pure TEOF + | otherwise -> pure TEOF + +-- | Unpacks a doctype token. +packDoctype :: Int -> MVector s Int -> BS -> ST s Token +packDoctype x tbCntl bs = do + nameOffset <- U.read tbCntl (x + 2) + nameLen <- U.read tbCntl (x + 3) + quirks <- U.read tbCntl (x + 4) + pubExists <- U.read tbCntl (x + 5) + pubOffset <- U.read tbCntl (x + 6) + pubLen <- U.read tbCntl (x + 7) + sysExists <- U.read tbCntl (x + 8) + sysOffset <- U.read tbCntl (x + 9) + sysLen <- U.read tbCntl (x + 10) + pure $ TDoctype + (bsPart nameOffset nameLen bs) + (quirks == 1) + (if pubExists == 1 then Just (bsPart pubOffset pubLen bs) else Nothing) + (if sysExists == 1 then Just (bsPart sysOffset sysLen bs) else Nothing) + +-- | Unpacks an start tag token. +packTagStart :: Int -> MVector s Int -> BS -> ST s Token +packTagStart x tbCntl bs = do + nameOffset <- U.read tbCntl (x + 2) + nameLen <- U.read tbCntl (x + 3) + selfClose <- U.read tbCntl (x + 4) + attrCount <- U.read tbCntl (x + 5) + attr <- forM [1 .. attrCount] $ \j -> do + let i = (j - 1) * attrSize + attrStart + x + no <- U.read tbCntl (i + 0) + nc <- U.read tbCntl (i + 1) + ao <- U.read tbCntl (i + 2) + ac <- U.read tbCntl (i + 3) + pure $ + if no > 0 + then Just $ TAttr + (bsPart no nc bs) + (bsPart ao ac bs) + HTMLAttrNamespaceNone + else Nothing + pure $ TStart + (bsPart nameOffset nameLen bs) + (selfClose == 1) + (catMaybes attr) + +-- | Unpacks an end tag token. +packTagEnd :: Int -> MVector s Int -> BS -> ST s Token +packTagEnd x tbCntl bs = do + nameOffset <- U.read tbCntl (x + 2) + nameLen <- U.read tbCntl (x + 3) + pure $ TEnd $ bsPart nameOffset nameLen bs + +-- | Unpacks a comment token. +packComment :: Int -> MVector s Int -> BS -> ST s Token +packComment x tbCntl bs = do + o <- U.read tbCntl (x + 2) + n <- U.read tbCntl (x + 3) + pure $ TComment $ bsPart o n bs + +-- | Unpacks a character token. +packChar :: Int -> MVector s Int -> ST s Token +packChar x tbCntl = do + c <- U.read tbCntl (x + 2) + pure $ TChar $ fromIntegral c + +-- | Appends a character to a string at an offset in the current token. +stringAppendTail :: Int -> Word8 -> STRef s (TokenBuffer s) -> ST s () +stringAppendTail offset word r = do + t@TokenBuffer{..} <- readSTRef r + tailPtr <- U.read tbCntl 2 + stringAppend (tailPtr + offset) word t r +{-# INLINE stringAppendTail #-} + +-- | Appends a character to a string at an offset. +stringAppend :: Int -> Word8 -> TokenBuffer s -> STRef s (TokenBuffer s) -> ST s () +stringAppend x word t@TokenBuffer{..} r = do + let y = x + 1 + i <- U.read tbCntl 0 + o <- U.read tbCntl x + n <- U.read tbCntl y + d <- ensureData i t r + U.write d i word + U.write tbCntl 0 (i + 1) + U.write tbCntl y (n + 1) + when (o == 0) $ + U.write tbCntl x i +{-# INLINE stringAppend #-} + +-- | Ensures that the control buffer has enough space and grows it if needed. +ensureCntl :: Int -> TokenBuffer s -> STRef s (TokenBuffer s) -> ST s (MVector s Int) +ensureCntl x TokenBuffer{..} r + | x < U.length tbCntl = + pure tbCntl + | otherwise = do + v <- U.grow tbCntl $ U.length tbCntl + writeSTRef r $ TokenBuffer v tbData + pure v +{-# INLINE ensureCntl #-} + +-- | Ensures that the data buffer has enough space and grows it if needed. +ensureData :: Int -> TokenBuffer s -> STRef s (TokenBuffer s) -> ST s (MVector s Word8) +ensureData x TokenBuffer{..} r + | x < U.length tbData = + pure tbData + | otherwise = do + v <- U.grow tbData $ U.length tbData + writeSTRef r $ TokenBuffer tbCntl v + pure v +{-# INLINE ensureData #-} diff --git a/src/Zenacy/HTML/Internal/Trie.hs b/src/Zenacy/HTML/Internal/Trie.hs new file mode 100644 --- /dev/null +++ b/src/Zenacy/HTML/Internal/Trie.hs @@ -0,0 +1,70 @@ +-- | A basic trie over byte strings. +module Zenacy.HTML.Internal.Trie + ( Trie + , empty + , fromList + , insert + , insertWords + , match + ) where + +import Zenacy.HTML.Internal.BS +import Data.Map + ( Map + ) +import qualified Data.Map as Map + ( empty + , fromList + , insert + , lookup + ) +import Data.Word + ( Word8 + ) + +-- | Defines the tree. +data Trie a = Trie (Maybe a) (Map Word8 (Trie a)) deriving (Show) + +-- | Creates an empty trie. +empty :: Trie a +empty = Trie Nothing Map.empty + +-- | Creates a trie from a list of tuples containing key and value. +fromList :: [(BS,a)] -> Trie a +fromList = foldl (\t (x,y) -> insert x y t) empty + +-- | Finds the longest prefix with a value in the trie and returns +-- the prefix, the value, and the remaining string. +match :: Trie a -> BS -> Maybe (BS, a, BS) +match t s = + case go Nothing 0 t s of + Nothing -> Nothing + Just (n, v) -> Just (bsTake n s, v, bsDrop n s) + where + go a n (Trie v m) s = + case bsUncons s of + Nothing -> a + Just (w, t) -> + case Map.lookup w m of + Nothing -> a + Just b @ (Trie (Just v2) _) -> + go (Just (n + 1, v2)) (n + 1) b t + Just b -> + go a (n + 1) b t + +-- | Inserts a value into a trie. +insert :: BS -> a -> Trie a -> Trie a +insert x = insertWords $ bsUnpack x + +-- | Inserts a value into a trie. +insertWords :: [Word8] -> a -> Trie a -> Trie a +insertWords x y = go x + where + go [] (Trie v m) = + Trie (Just y) m + go (w:ws) (Trie v m) = + case Map.lookup w m of + Nothing -> + Trie v $ Map.insert w (go ws empty) m + Just b -> + Trie v $ Map.insert w (go ws b) m diff --git a/src/Zenacy/HTML/Internal/Types.hs b/src/Zenacy/HTML/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Zenacy/HTML/Internal/Types.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Defines supporting types. +module Zenacy.HTML.Internal.Types + ( HTMLNamespace(..) + , HTMLAttrNamespace(..) + ) where + +import Data.Default + ( Default(..) + ) + +-- | An HTML namespace type. +data HTMLNamespace + = HTMLNamespaceHTML + | HTMLNamespaceSVG + | HTMLNamespaceMathML + deriving (Eq, Ord, Show) + +-- | An HTML attribute namespace type. +data HTMLAttrNamespace + = HTMLAttrNamespaceNone + | HTMLAttrNamespaceXLink + | HTMLAttrNamespaceXML + | HTMLAttrNamespaceXMLNS + deriving (Eq, Ord, Show) + +-- | Defines a default namespace. +instance Default HTMLNamespace where + def = HTMLNamespaceHTML + +-- | Defines a default attribute namespace. +instance Default HTMLAttrNamespace where + def = HTMLAttrNamespaceNone diff --git a/src/Zenacy/HTML/Internal/Zip.hs b/src/Zenacy/HTML/Internal/Zip.hs new file mode 100644 --- /dev/null +++ b/src/Zenacy/HTML/Internal/Zip.hs @@ -0,0 +1,519 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Defines types for zipping and iterating over HTML trees. +module Zenacy.HTML.Internal.Zip + ( HTMLZipper + , HTMLZipAction + , HTMLIter + , HTMLZipPath(..) + , htmlZip + , htmlZipM + , htmlUnzip + , htmlUnzipM + , htmlZipNode + , htmlZipNodeM + , htmlZipRoot + , htmlZipRootM + , htmlZipUp + , htmlZipParent + , htmlZipFirst + , htmlZipLast + , htmlZipFind + , htmlZipNext + , htmlZipPrev + , htmlZipGet + , htmlZipTest + , htmlZipTestNode + , htmlZipTestName + , htmlZipTestFirst + , htmlZipTestLast + , htmlZipModify + , htmlZipModifyM + , htmlZipDelete + , htmlZipCollapse + , htmlZipInsertBefore + , htmlZipInsertAfter + , htmlZipContentBefore + , htmlZipContentAfter + , htmlZipContentLeft + , htmlZipContentRight + , htmlZipDropBefore + , htmlZipDropAfter + , htmlZipDropLeft + , htmlZipDropRight + , htmlZipPruneBefore + , htmlZipPruneAfter + , htmlZipPruneLeft + , htmlZipPruneRight + , htmlZipRepeat + , htmlZipStepNext + , htmlZipStepBack + , htmlZipSearch + , htmlZipIndex + , htmlIter + , htmlIterZipper + , htmlIterSearch + , htmlIterModify + , htmlIterNext + , htmlIterBack + , htmlZipPath + , htmlZipPathEmpty + , htmlZipPathFind + ) where + +import Zenacy.HTML.Internal.Core +import Zenacy.HTML.Internal.HTML +import Zenacy.HTML.Internal.Oper +import Control.Monad + ( (>=>) + ) +import Data.Bool + ( bool + ) +import Data.Default + ( Default(..) + ) +import Data.Maybe + ( fromMaybe + , isNothing + ) +import Data.Monoid + ( (<>) + ) +import Data.Text + ( Text + ) +import qualified Data.Text as T + ( unpack + ) + +-- | The zipper crumb definition. +data HTMLCrumb = HTMLCrumb HTMLNode [HTMLNode] [HTMLNode] + +-- | The zipper type. +data HTMLZipper = HTMLZipper HTMLNode [HTMLCrumb] + +-- | Defines an action on a zipper. +type HTMLZipAction = HTMLZipper -> Maybe HTMLZipper + +-- | Defines a zip direction. +data Direction = Down | Across | Up + +-- | The zipper iterator type. +data HTMLIter = HTMLIter Direction HTMLZipper + +-- | Defines the type for a path. +newtype HTMLZipPath = HTMLZipPath [Int] deriving (Show, Eq, Ord) + +-- | Defaults for zip path. +instance Default HTMLZipPath where + def = htmlZipPathEmpty + +-- | Creates a zipper for a HTML node. +htmlZip :: HTMLNode -> HTMLZipper +htmlZip x = HTMLZipper x [] + +-- | Creates a zipper for a HTML node in a Monad. +htmlZipM :: Monad m => HTMLNode -> m HTMLZipper +htmlZipM = pure . htmlZip + +-- | Extracts the HTML node from a zipper. +htmlUnzip :: HTMLZipper -> HTMLNode +htmlUnzip = htmlZipNode . htmlZipRoot + +-- | Extracts the HTML node from a zipper in a Monad. +htmlUnzipM :: Monad m => HTMLZipper -> m HTMLNode +htmlUnzipM = pure . htmlUnzip + +-- | Gets the current HTML node. +htmlZipNode :: HTMLZipper -> HTMLNode +htmlZipNode (HTMLZipper x _) = x + +-- | Gets the current HTML node in a Monad. +htmlZipNodeM :: Monad m => HTMLZipper -> m HTMLNode +htmlZipNodeM = pure . htmlZipNode + +-- | Moves the zipper to the root HTML node. +htmlZipRoot :: HTMLZipper -> HTMLZipper +htmlZipRoot x = maybe x htmlZipRoot $ htmlZipParent x + +-- | Moves the zipper to the root HTML node in a Monad. +htmlZipRootM :: Monad m => HTMLZipper -> m HTMLZipper +htmlZipRootM = pure . htmlZipRoot + +-- | Moves the zipper to the parent node. +htmlZipUp :: HTMLZipper -> Maybe HTMLZipper +htmlZipUp = htmlZipParent + +-- | Moves the zipper to the parent node. +htmlZipParent :: HTMLZipper -> Maybe HTMLZipper +htmlZipParent = \case + HTMLZipper x [] -> Nothing + HTMLZipper x ((HTMLCrumb n ls rs):cs) -> + let c = reverse ls <> [x] <> rs + in case n of + HTMLDocument n [] -> + Just $ HTMLZipper (HTMLDocument n c) cs + HTMLDoctype n p s -> + Nothing + HTMLFragment n [] -> + Just $ HTMLZipper (HTMLFragment n c) cs + HTMLElement n s a [] -> + Just $ HTMLZipper (HTMLElement n s a c) cs + HTMLTemplate s a c -> + Nothing + HTMLText t -> + Nothing + HTMLComment c -> + Nothing + +-- | Moves the zipper to the first child node. +htmlZipFirst :: HTMLZipper -> Maybe HTMLZipper +htmlZipFirst (HTMLZipper y z) = case y of + HTMLDocument n c -> + f c $ HTMLDocument n [] + HTMLFragment n c -> + f c $ HTMLFragment n [] + HTMLElement n s a c -> + f c $ HTMLElement n s a [] + _ -> Nothing + where + f [] n = Nothing + f (h:rs) n = Just $ HTMLZipper h ((HTMLCrumb n [] rs):z) + +-- | Moves the zipper to the last child node. +htmlZipLast :: HTMLZipper -> Maybe HTMLZipper +htmlZipLast (HTMLZipper y z) = case y of + HTMLDocument n c -> + f c $ HTMLDocument n [] + HTMLFragment n c -> + f c $ HTMLFragment n [] + HTMLElement n s a c -> + f c $ HTMLElement n s a [] + _ -> Nothing + where + f [] n = Nothing + f xs n = let (h:ls) = reverse xs in Just $ + HTMLZipper h ((HTMLCrumb n ls []):z) + +-- | Moves the zipper to a named child element. +htmlZipFind :: (HTMLNode -> Bool) -> HTMLZipper -> Maybe HTMLZipper +htmlZipFind p (HTMLZipper y z) = case y of + HTMLDocument n c -> + f c $ HTMLDocument n [] + HTMLFragment n c -> + f c $ HTMLFragment n [] + HTMLElement n s a c -> + f c $ HTMLElement n s a [] + _ -> Nothing + where + f c n = case break p c of + (ls, []) -> Nothing + (ls, h:rs) -> Just $ + HTMLZipper h ((HTMLCrumb n (reverse ls) rs):z) + +-- | Moves to the next sibling. +htmlZipNext :: HTMLZipper -> Maybe HTMLZipper +htmlZipNext = \case + HTMLZipper x [] -> Nothing + HTMLZipper x ((HTMLCrumb n ls []):cs) -> Nothing + HTMLZipper x ((HTMLCrumb n ls (h:rs)):cs) -> + Just $ HTMLZipper h ((HTMLCrumb n (x:ls) rs):cs) + +-- | Moves to the previous sibling. +htmlZipPrev :: HTMLZipper -> Maybe HTMLZipper +htmlZipPrev = \case + HTMLZipper x [] -> Nothing + HTMLZipper x ((HTMLCrumb n [] rs):cs) -> Nothing + HTMLZipper x ((HTMLCrumb n (h:ls) rs):cs) -> + Just $ HTMLZipper h ((HTMLCrumb n ls (x:rs)):cs) + +-- | Gets the child specified by an index. +htmlZipGet :: Int -> HTMLZipper -> Maybe HTMLZipper +htmlZipGet n z + | n < 0 = Nothing + | n == 0 = htmlZipFirst z + | otherwise = htmlZipFirst z >>= f n + where + f 0 = Just + f n = htmlZipNext >=> f (n - 1) + +-- | Continues a zipper if a test is passed. +htmlZipTest :: (HTMLZipper -> Bool) -> HTMLZipper -> Maybe HTMLZipper +htmlZipTest f z = bool Nothing (Just z) $ f z + +-- | Continues a zipper if a node test is passed. +htmlZipTestNode :: (HTMLNode -> Bool) -> HTMLZipper -> Maybe HTMLZipper +htmlZipTestNode f = htmlZipTest $ f . htmlZipNode + +-- | Tests the current node for an element name. +htmlZipTestName :: Text -> HTMLZipper -> Maybe HTMLZipper +htmlZipTestName x = htmlZipTest (htmlElemHasName x . htmlZipNode) + +-- | Test whether the zipper is at the first child node. +htmlZipTestFirst :: HTMLZipper -> Maybe HTMLZipper +htmlZipTestFirst = htmlZipTest (isNothing . htmlZipPrev) + +-- | Test whether the zipper is at the last child node. +htmlZipTestLast :: HTMLZipper -> Maybe HTMLZipper +htmlZipTestLast = htmlZipTest (isNothing . htmlZipNext) + +-- | Modifies the currently focused node. +htmlZipModify :: (HTMLNode -> HTMLNode) -> HTMLZipper -> HTMLZipper +htmlZipModify f (HTMLZipper y z) = HTMLZipper (f y) z + +-- | Modifies the currently focused node in a Monad. +htmlZipModifyM :: Monad m => (HTMLNode -> HTMLNode) -> HTMLZipper -> m HTMLZipper +htmlZipModifyM f = pure . htmlZipModify f + +-- | Deletes the current node. +htmlZipDelete :: HTMLZipper -> Maybe HTMLZipper +htmlZipDelete = \case + HTMLZipper x [] -> Nothing + HTMLZipper x ((HTMLCrumb n l r):cs) -> + let c = reverse l <> r + in case n of + HTMLDocument n [] -> + Just $ HTMLZipper (HTMLDocument n c) cs + HTMLFragment n [] -> + Just $ HTMLZipper (HTMLFragment n c) cs + HTMLElement n s a [] -> + Just $ HTMLZipper (HTMLElement n s a c) cs + _ -> Nothing + +-- | Collapses the current node. +htmlZipCollapse :: HTMLZipper -> Maybe HTMLZipper +htmlZipCollapse = \case + HTMLZipper x [] -> Nothing + HTMLZipper x ((HTMLCrumb n l r):cs) -> + let c = reverse l <> htmlNodeContent x <> r + in case n of + HTMLDocument n [] -> + Just $ HTMLZipper (HTMLDocument n c) cs + HTMLFragment n [] -> + Just $ HTMLZipper (HTMLFragment n c) cs + HTMLElement n s a [] -> + Just $ HTMLZipper (HTMLElement n s a c) cs + _ -> Nothing + +-- | Inserts a node before the current node. +htmlZipInsertBefore :: HTMLNode -> HTMLZipper -> Maybe HTMLZipper +htmlZipInsertBefore y = \case + HTMLZipper x [] -> Nothing + HTMLZipper x ((HTMLCrumb n l r):cs) -> + Just $ HTMLZipper x ((HTMLCrumb n (y:l) r):cs) + +-- | Inserts a node after the current node. +htmlZipInsertAfter :: HTMLNode -> HTMLZipper -> Maybe HTMLZipper +htmlZipInsertAfter y = \case + HTMLZipper x [] -> Nothing + HTMLZipper x ((HTMLCrumb n l r):cs) -> + Just $ HTMLZipper x ((HTMLCrumb n l (y:r)):cs) + +-- | Gets the siblings to the left of the current node. +htmlZipContentBefore :: HTMLZipper -> [HTMLNode] +htmlZipContentBefore = \case + HTMLZipper x [] -> [] + HTMLZipper x ((HTMLCrumb n l r):cs) -> reverse l + +-- | Gets the siblings to the right of the current node. +htmlZipContentAfter :: HTMLZipper -> [HTMLNode] +htmlZipContentAfter = \case + HTMLZipper x [] -> [] + HTMLZipper x ((HTMLCrumb n l r):cs) -> r + +-- | Synonym for htmlZipContentBefore. +htmlZipContentLeft :: HTMLZipper -> [HTMLNode] +htmlZipContentLeft = htmlZipContentBefore + +-- | Synonym for htmlZipContentAfter. +htmlZipContentRight :: HTMLZipper -> [HTMLNode] +htmlZipContentRight = htmlZipContentAfter + +-- | Drops the siblings to the left of the current node. +htmlZipDropBefore :: HTMLZipper -> Maybe HTMLZipper +htmlZipDropBefore = \case + HTMLZipper x [] -> Nothing + HTMLZipper x ((HTMLCrumb n _ r):cs) -> + Just $ HTMLZipper x ((HTMLCrumb n [] r):cs) + +-- | Drops the siblings to the right of the current node. +htmlZipDropAfter :: HTMLZipper -> Maybe HTMLZipper +htmlZipDropAfter = \case + HTMLZipper x [] -> Nothing + HTMLZipper x ((HTMLCrumb n l _):cs) -> + Just $ HTMLZipper x ((HTMLCrumb n l []):cs) + +-- | Synonym for htmlZipDropBefore. +htmlZipDropLeft :: HTMLZipper -> Maybe HTMLZipper +htmlZipDropLeft = htmlZipDropBefore + +-- | Synonym for htmlZipDropAfter. +htmlZipDropRight :: HTMLZipper -> Maybe HTMLZipper +htmlZipDropRight = htmlZipDropAfter + +-- | Drops all of the branches to the left of the current node +-- while moving up to and ending at the root. +htmlZipPruneBefore :: HTMLZipper -> Maybe HTMLZipper +htmlZipPruneBefore = htmlZipRepeat safeDrop htmlZipParent + where + safeDrop z = Just $ fromMaybe z $ htmlZipDropBefore z + +-- | Drops all of the branches to the right of the current node +-- while moving up to and ending at the root. +htmlZipPruneAfter :: HTMLZipper -> Maybe HTMLZipper +htmlZipPruneAfter = htmlZipRepeat safeDrop htmlZipParent + where + safeDrop z = Just $ fromMaybe z $ htmlZipDropAfter z + +-- | Synonym for htmlZipPruneBefore. +htmlZipPruneLeft :: HTMLZipper -> Maybe HTMLZipper +htmlZipPruneLeft = htmlZipPruneBefore + +-- | Synonym for htmlZipPruneAfter. +htmlZipPruneRight :: HTMLZipper -> Maybe HTMLZipper +htmlZipPruneRight = htmlZipPruneAfter + +-- | Repeats a zipper action until another zipper returns Nothing. +htmlZipRepeat :: HTMLZipAction -> HTMLZipAction -> HTMLZipAction +htmlZipRepeat f g z = + case f z of + Nothing -> Nothing + Just z1 -> case g z1 of + Nothing -> Just z1 + Just z2 -> htmlZipRepeat f g z2 + +-- | Step a zipper forward one node. +htmlZipStepNext :: HTMLZipper -> Maybe HTMLZipper +htmlZipStepNext = htmlZipStep htmlZipFirst htmlZipNext + +-- | Step a zipper back one node. +htmlZipStepBack :: HTMLZipper -> Maybe HTMLZipper +htmlZipStepBack = htmlZipStep htmlZipLast htmlZipPrev + +-- | Step a zipper. +htmlZipStep :: HTMLZipAction -> HTMLZipAction -> HTMLZipAction +htmlZipStep first next z = + case first z of + Just x -> Just x + Nothing -> f z + where + f x = case next x of + Just a -> Just a + Nothing -> case htmlZipParent x of + Just b -> f b + Nothing -> Nothing + +-- | Searches a zipper until a predicate is true. +htmlZipSearch + :: (HTMLZipper -> Maybe HTMLZipper) + -> (HTMLZipper -> Bool) + -> HTMLZipper + -> Maybe HTMLZipper +htmlZipSearch step test x + | test x = Just x + | otherwise = maybe Nothing (htmlZipSearch step test) $ step x + +-- | Gets the index for a node. +htmlZipIndex :: HTMLZipper -> Maybe Int +htmlZipIndex = \case + HTMLZipper _ [] -> Nothing + HTMLZipper _ ((HTMLCrumb _ ls _):_) -> Just $ length ls + +-- | Dumps a zipper to a string. +htmlZipDump :: HTMLZipper -> String +htmlZipDump (HTMLZipper n cs) = + name n <> "\n" <> go cs + where + go :: [HTMLCrumb] -> String + go [] = "" + go ((HTMLCrumb n ls rs):cs) = + name n <> "\n" + <> " ls: " <> names ls <> "\n" + <> " rs: " <> names rs <> "\n" + <> go cs + name = T.unpack . htmlElemName + names = show . map name + +-- | Returns an iterator for a zipper. +htmlIter :: HTMLZipper -> HTMLIter +htmlIter = HTMLIter Down + +-- | Gets the iterator for a zipper. +htmlIterZipper :: HTMLIter -> HTMLZipper +htmlIterZipper (HTMLIter _ z) = z + +-- | Modifies the zipper for an interator. +htmlIterModify :: (HTMLZipper -> HTMLZipper) -> HTMLIter -> HTMLIter +htmlIterModify f (HTMLIter d z) = (HTMLIter d $ f z) + +-- | Advances an iterator to the next element. +htmlIterNext :: HTMLIter -> Maybe HTMLIter +htmlIterNext = iterStep htmlZipFirst htmlZipNext + +-- | Advances an iterator to the previous element. +htmlIterBack :: HTMLIter -> Maybe HTMLIter +htmlIterBack = iterStep htmlZipLast htmlZipPrev + +-- | Steps an iterator. +iterStep + :: (HTMLZipper -> Maybe HTMLZipper) + -> (HTMLZipper -> Maybe HTMLZipper) + -> HTMLIter + -> Maybe HTMLIter +iterStep first next = go + where + go (HTMLIter d z) = + case d of + Down -> + case first z of + Just x -> Just $ HTMLIter Down x + Nothing -> go $ HTMLIter Across z + Across -> + case next z of + Just x -> Just $ HTMLIter Down x + Nothing -> go $ HTMLIter Up z + Up -> + case htmlZipParent z of + Just x -> Just $ HTMLIter Across x + Nothing -> Nothing + +-- | Searches an iterator until a predicate is true. +htmlIterSearch + :: (HTMLIter -> Maybe HTMLIter) + -> (HTMLZipper -> Bool) + -> HTMLIter + -> Maybe HTMLIter +htmlIterSearch step test x@(HTMLIter _ z) + | test z = Just x + | otherwise = maybe Nothing (htmlIterSearch step test) $ step x + +-- | Defines an empty path. +htmlZipPathEmpty :: HTMLZipPath +htmlZipPathEmpty = HTMLZipPath [] + +-- | Gets the path for a node. +htmlZipPath :: HTMLZipper -> HTMLZipPath +htmlZipPath = maybe (HTMLZipPath []) id . go htmlZipPathEmpty + where + go :: HTMLZipPath -> HTMLZipper -> Maybe HTMLZipPath + go (HTMLZipPath p) z = + case htmlZipIndex z of + Nothing -> + Just $ HTMLZipPath p + Just x -> + case htmlZipParent z of + Nothing -> Nothing + Just y -> go (HTMLZipPath $ x : p) y + +-- | Finds the zipper for a path starting from the current node. +htmlZipPathFind :: HTMLZipPath -> HTMLZipper -> Maybe HTMLZipper +htmlZipPathFind (HTMLZipPath p) = f p + where + f [] = pure + f (x:xs) = htmlZipGet x >=> f xs diff --git a/test/Samples.hs b/test/Samples.hs new file mode 100644 --- /dev/null +++ b/test/Samples.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE QuasiQuotes #-} + +module Samples + ( testSamples + ) where + +import Zenacy.HTML +import Data.Default + ( Default(..) + ) +import Test.Framework + ( Test + , testGroup + ) +import Test.Framework.Providers.HUnit + ( testCase + ) +import Test.HUnit + ( assertBool + , assertEqual + , assertFailure + ) +import Data.Maybe + ( fromJust + , fromMaybe + ) +import Data.Text + ( Text + ) +import qualified Data.Text as T + ( pack + ) +import Text.RawString.QQ + +testSamples :: Test +testSamples = testGroup "Samples" + [ testHello + , testRewrite + , testExtract + , testQuery + , testQuery2 + ] + +testHello :: Test +testHello = testCase "sample hello" $ do + flip (assertEqual "Sample 1") + (htmlRender $ htmlParseEasy "
HelloWorld
") + "
HelloWorld
" + + flip (assertEqual "Sample 2") + (htmlParseEasy "
HelloWorld
") + (HTMLDocument "" + [ HTMLElement "html" HTMLNamespaceHTML [] + [ HTMLElement "head" HTMLNamespaceHTML [] [] + , HTMLElement "body" HTMLNamespaceHTML [] + [ HTMLElement "div" HTMLNamespaceHTML [] + [ HTMLText "HelloWorld" ] ] ] ]) + + flip (assertEqual "Sample 3") + (htmlParseEasy "
HelloWorld
") + HTMLDocument + { htmlDocumentName = "" + , htmlDocumentChildren = + [ HTMLElement + { htmlElementName = "html" + , htmlElementNamespace = HTMLNamespaceHTML + , htmlElementAttributes = [] + , htmlElementChildren = + [ HTMLElement + { htmlElementName = "head" + , htmlElementNamespace = HTMLNamespaceHTML + , htmlElementAttributes = [] + , htmlElementChildren = [] + } + , HTMLElement + { htmlElementName = "body" + , htmlElementNamespace = HTMLNamespaceHTML + , htmlElementAttributes = [] + , htmlElementChildren = + [ HTMLElement + { htmlElementName = "div" + , htmlElementNamespace = HTMLNamespaceHTML + , htmlElementAttributes = [] + , htmlElementChildren = + [ HTMLText + { htmlTextData = "HelloWorld" } + ] } ] } ] } ] } + +testRewrite :: Test +testRewrite = testCase "sample rewrite" $ do + flip (assertEqual "Sample 1") + (rewrite "HelloWorld") + "
Hello
World
" + +rewrite :: Text -> Text +rewrite = htmlRender . htmlMapElem f . fromJust . htmlDocHtml . htmlParseEasy + where + f x + | htmlElemHasName "span" x = htmlElemRename "div" x + | otherwise = x + +testExtract :: Test +testExtract = testCase "sample extract" $ do + flip (assertEqual "Sample 1") + (extract "") + [ "https://example1.com" + , "https://example2.com" + ] + +extract :: Text -> [Text] +extract = go . htmlParseEasy + where + go = \case + HTMLDocument n c -> + concatMap go c + e @ (HTMLElement "a" s a c) -> + case htmlElemAttrFind (htmlAttrHasName "href") e of + Just (HTMLAttr n v s) -> + v : concatMap go c + Nothing -> + concatMap go c + HTMLElement n s a c -> + concatMap go c + _otherwise -> + [] + +testQuery :: Test +testQuery = testCase "sample query" $ do + assertEqual "Sample 1" (Just "AAA") $ query (b h) + where + h = [r| +

+ +
+ AAA + +

+ |] + b = fromJust + . htmlSpaceRemove + . fromJust + . htmlDocBody + . htmlParseEasy + +query :: HTMLNode -> Maybe Text +query = htmlQueryExec $ do + htmlQueryName "body" + htmlQueryFirst + htmlQueryName "p" + htmlQueryFirst + htmlQueryId "x" + htmlQueryNext + htmlQueryNext + htmlQueryName "a" + a <- htmlQueryNode + htmlQuerySucc $ + fromMaybe "" $ htmlElemText a + +testQuery2 = testCase "sample query2" $ do + assertEqual "Sample 1" (htmlRender h') $ + htmlRender $ htmlMapElem query2 h + where + h = b [r| +
+
+
+ |] + h' = b [r| +
aaa
+
bbb
+
ccc
+ |] + b = fromJust + . htmlSpaceRemove + . fromJust + . htmlDocBody + . htmlParseEasy + +query2 :: HTMLNode -> HTMLNode +query2 = htmlQueryTry $ do + htmlQueryName "div" + htmlQueryOnly "img" + a <- htmlQueryNode + let Just b = htmlElemGetAttr "src" a + htmlQuerySucc $ + htmlElem "a" [ htmlAttr "href" b ] + [ htmlText b ] diff --git a/test/TestSuite.hs b/test/TestSuite.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite.hs @@ -0,0 +1,33 @@ +module Main where + +import Samples +import Zenacy.HTML.Internal.Buffer.Tests +import Zenacy.HTML.Internal.Entity.Tests +import Zenacy.HTML.Internal.HTML.Tests +import Zenacy.HTML.Internal.Image.Tests +import Zenacy.HTML.Internal.Lexer.Tests +import Zenacy.HTML.Internal.Oper.Tests +import Zenacy.HTML.Internal.Parser.Tests +import Zenacy.HTML.Internal.Query.Tests +import Zenacy.HTML.Internal.Token.Tests +import Zenacy.HTML.Internal.Trie.Tests +import Zenacy.HTML.Internal.Zip.Tests +import Test.Framework + ( defaultMain + ) + +main :: IO () +main = defaultMain + [ testBuffer + , testEntity + , testToken + , testLexer + , testParser + , testHtml + , testImage + , testOper + , testTrie + , testZip + , testQuery + , testSamples + ] diff --git a/test/Zenacy/HTML/Internal/Buffer/Tests.hs b/test/Zenacy/HTML/Internal/Buffer/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Zenacy/HTML/Internal/Buffer/Tests.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Zenacy.HTML.Internal.Buffer.Tests + ( testBuffer + ) where + +import Zenacy.HTML.Internal.Buffer +import Control.Monad +import Control.Monad.ST +import qualified Data.ByteString as S +import Test.Framework + ( Test + , testGroup + ) +import Test.Framework.Providers.HUnit + ( testCase + ) +import Test.HUnit + ( assertBool + , assertEqual + , assertFailure + ) + +testBuffer :: Test +testBuffer = testGroup "Zenacy.HTML.Internal.Buffer" + [ testCapacity + , testSize + , testReset + , testPack + , testApply + , testTake + ] + +testCapacity :: Test +testCapacity = testCase "buffer capacity" $ do + assertEqual "TEST 1" (1,100) $ + runST $ do + b <- bufferNew + bufferCapacity b + assertEqual "TEST 2" (1,25600) $ + runST $ do + b <- bufferNew + forM_ [1..20000] $ const $ bufferAppend 0x40 b + bufferCapacity b + +testSize :: Test +testSize = testCase "buffer size" $ do + assertEqual "TEST 1" 0 $ + runST $ do + b <- bufferNew + bufferSize b + assertEqual "TEST 2" 200 $ + runST $ do + b <- bufferNew + forM_ [1..200] $ const $ bufferAppend 0x40 b + bufferSize b + assertEqual "TEST 3" 1000 $ + runST $ do + b <- bufferNew + forM_ [1..1000] $ const $ bufferAppend 0x40 b + bufferSize b + +testReset :: Test +testReset = testCase "buffer reset" $ do + assertEqual "TEST 1" (0,200,0) $ + runST $ do + b <- bufferNew + n0 <- bufferSize b + forM_ [1..200] $ const $ bufferAppend 0x40 b + n1 <- bufferSize b + bufferReset b + n2 <- bufferSize b + pure (n0,n1,n2) + +testPack :: Test +testPack = testCase "buffer pack" $ do + assertEqual "TEST 1" x $ f x + assertEqual "TEST 2" "0" $ f "0" + assertEqual "TEST 2" "" $ f "" + where + x = "the quick brown fox jumps over the lazy dog" + f a = + runST $ do + b <- bufferNew + forM_ (S.unpack a) $ \c -> bufferAppend c b + bufferPack b + +testApply :: Test +testApply = testCase "buffer apply" $ do + assertEqual "TEST 1" x $ f x + assertEqual "TEST 2" "0" $ f "0" + assertEqual "TEST 2" "" $ f "" + where + x = "the quick brown fox jumps over the lazy dog" + f a = runST $ do + b0 <- bufferNew + b1 <- bufferNew + forM_ (S.unpack a) $ \c -> bufferAppend c b0 + bufferApply (\w -> bufferAppend w b1) b0 + bufferPack b1 + +testTake :: Test +testTake = testCase "buffer take" $ do + assertEqual "TEST 1" + [] + (f x 0) + assertEqual "TEST 2" + [0] + (f x 1) + assertEqual "TEST 3" + [0,1,2,3,4] + (f x 5) + assertEqual "TEST 4" + [0,1,2,3,4,5,6,7,8,9] + (f x 100) + where + x = "\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09" + f a n = runST $ do + b <- bufferNew + forM_ (S.unpack a) $ \c -> bufferAppend c b + bufferTake n b diff --git a/test/Zenacy/HTML/Internal/Entity/Tests.hs b/test/Zenacy/HTML/Internal/Entity/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Zenacy/HTML/Internal/Entity/Tests.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Zenacy.HTML.Internal.Entity.Tests + ( testEntity + ) where + +import Zenacy.HTML.Internal.Entity +import Test.Framework + ( Test + , testGroup + ) +import Test.Framework.Providers.HUnit + ( testCase + ) +import Test.HUnit + ( assertBool + , assertEqual + , assertFailure + ) + +testEntity :: Test +testEntity = testGroup "Zenacy.HTML.Internal.Entity" + [ testGeneral + , testLongest + ] + +testGeneral :: Test +testGeneral = testCase "entity general" $ do + assertEqual "TEST 1" Nothing $ entityMatch "aamp;b" + assertEqual "TEST 2" (Just ("amp;", "&", "bbb")) $ entityMatch "amp;bbb" + assertEqual "TEST 3" (Just ("amp;", "&", "")) $ entityMatch "amp;" + assertEqual "TEST 4" (Just ("amp", "&", "b")) $ entityMatch "ampb" + +testLongest :: Test +testLongest = testCase "entity longest" $ do + assertEqual "TEST 1" + -- TODO: is this the correct result? + (Just ("DoubleLongLeftRightArrow;", "\226\159\186", "x")) + (entityMatch "DoubleLongLeftRightArrow;x") diff --git a/test/Zenacy/HTML/Internal/HTML/Tests.hs b/test/Zenacy/HTML/Internal/HTML/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Zenacy/HTML/Internal/HTML/Tests.hs @@ -0,0 +1,577 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE QuasiQuotes #-} + +module Zenacy.HTML.Internal.HTML.Tests + ( testHtml + ) where + +import Zenacy.HTML +import Data.Default + ( Default(..) + ) +import Test.Framework + ( Test + , testGroup + ) +import Test.Framework.Providers.HUnit + ( testCase + ) +import Test.HUnit + ( assertBool + , assertEqual + , assertFailure + ) +import Data.Text + ( Text + ) +import qualified Data.Text as T + ( pack + ) +import Text.RawString.QQ + +testHtml :: Test +testHtml = testGroup "Zenacy.HTML.Internal.HTML" + [ testBasic + , testAA1 + , testAA2 + , testOmit + , testTableSparse + , testMath + , testScript + , testInput + , testList + , testScriptBeforeHead + , testComment + , testEntity + , testAfterHead + ] + +genNormal x = + case htmlParse def x of + Left e -> T.pack $ show e + Right r -> htmlRender $ htmlResultDocument r + +genPretty x = + case htmlParse def x of + Left e -> T.pack $ show e + Right r -> htmlRenderPretty $ htmlResultDocument r + +genEntity x y = + case htmlParse (def { htmlOptionIgnoreEntities = y }) x of + Left e -> T.pack $ show e + Right r -> htmlRender $ htmlResultDocument r + +testBasic :: Test +testBasic = testCase "html basic" $ do + assertEqual "TEST 1" htmlPretty $ genPretty htmlIn + assertEqual "TEST 2" htmlNormal $ genNormal htmlIn + +htmlIn = + "\ + \TITLE\ + \

HEY


\ + \\ + \\ + \\ + \\ + \
MEGADETH
\ + \" + +htmlPretty = + "\n\ + \\n\ + \ \n\ + \ TITLE\n\ + \ \n\ + \ \n\ + \

HEY

\n\ + \
\n\ + \ \n\ + \ \n\ + \ \n\ + \ \n\ + \ \n\ + \ \n\ + \ \n\ + \ \n\ + \ \n\ + \
MEGADETH
\n\ + \ \n\ + \" + +htmlNormal = + "\ + \\ + \\ + \TITLE\ + \\ + \\ + \

HEY

\ + \
\ + \\ + \\ + \\ + \\ + \\ + \\ + \\ + \\ + \\ + \
MEGADETH
\ + \\ + \" + +testAA1 :: Test +testAA1 = testCase "html adoption agency 1" $ do + assertEqual "TEST 1" htmlAA1Pretty $ genPretty htmlAA1In + assertEqual "TEST 2" htmlAA1Normal $ genNormal htmlAA1In + +htmlAA1In = + "\ + \AA Case 1\ + \\ + \

12345

\ + \\ + \" + +htmlAA1Pretty = + "\n\ + \\n\ + \ \n\ + \ AA Case 1\n\ + \ \n\ + \ \n\ + \

\n\ + \ 1\n\ + \ \n\ + \ 2\n\ + \ 3\n\ + \ \n\ + \ 4\n\ + \ 5\n\ + \

\n\ + \ \n\ + \" + +htmlAA1Normal = + "\ + \\ + \\ + \AA Case 1\ + \\ + \\ + \

\ + \1\ + \\ + \2\ + \3\ + \\ + \4\ + \5\ + \

\ + \\ + \" + +testAA2 :: Test +testAA2 = testCase "html adoption agency 2" $ do + assertEqual "TEST 1" htmlAA2Pretty $ genPretty htmlAA2In + assertEqual "TEST 2" htmlAA2Normal $ genNormal htmlAA2In + +htmlAA2In = + "\ + \1

23

\ + \" + +htmlAA2Pretty = + "\n\ + \\n\ + \ \n\ + \ \n\ + \ 1\n\ + \

\n\ + \ 2\n\ + \ 3\n\ + \

\n\ + \ \n\ + \" + +htmlAA2Normal = + "\ + \\ + \\ + \\ + \1\ + \

\ + \2\ + \3\ + \

\ + \\ + \" + +testOmit :: Test +testOmit = testCase "html omit" $ do + assertEqual "TEST 1" htmlOmitOut $ genNormal htmlOmitIn1 + assertEqual "TEST 2" htmlOmitOut $ genNormal htmlOmitIn2 + assertEqual "TEST 3" htmlOmit3Out $ genNormal htmlOmit3In + +htmlOmitIn1 = + "Hello

example.

" + +htmlOmitIn2 = + "Hello

example." + +htmlOmitOut = + "\ + \Hello\ + \

example.

" + +htmlOmit3In = + "\ + \Hello\ + \

example." + +htmlOmit3Out = + "\ + \Hello\ + \

example.

" + +testTableSparse :: Test +testTableSparse = testCase "html table sparse" $ do + assertEqual "TEST 1" + htmlTableSparseOut $ genNormal htmlTableSparseIn + +htmlTableSparseIn = + "\ + \\ + \ \ + \ \ + \ \ + \
37547 TEE Electric Powered Rail Car Train Functions\ + \
Function Control Unit Central\ + \
Headlights ✔ ✔\ + \
Interior Lights ✔ ✔\ + \
Electric locomotive sounds ✔ ✔\ + \
Engineer's cab lighting ✔\ + \
Station Announce - Swiss ✔\ + \
" + +htmlTableSparseOut = + "\ + \\ + \\ + \ \ + \\ + \ \ + \ \ + \\ + \\ + \\ + \\ + \\ + \ \ + \ \ + \\ + \\ + \\ + \ \ + \\ + \\ + \\ + \ \ + \\ + \\ + \\ + \ \ + \\ + \\ + \\ + \ \ + \\ + \\ + \
37547 TEE Electric Powered Rail Car Train Functions\ + \
Function Control Unit Central
Headlights \10004 \10004
Interior Lights \10004 \10004
Electric locomotive sounds \10004 \10004
Engineer's cab lighting \10004
Station Announce - Swiss \10004
" + +testMath :: Test +testMath = testCase "html math" $ do + assertEqual "TEST 1" htmlMathOut $ genNormal htmlMathIn + +htmlMathIn = + "\ + \

You can add a string to a number, but this stringifies the number:

\ + \\ + \x<y\ + \+\ + \3\ + \=\ + \x<y3\ + \" + +htmlMathOut = + "\ + \\ + \

You can add a string to a number, but this stringifies the number:

\ + \\ + \x<y\ + \+3=\ + \x<y3\ + \" + +testScript :: Test +testScript = testCase "html script" $ do + assertEqual "TEST 1" htmlScript1Out $ genNormal htmlScript1In + assertEqual "TEST 2" htmlScript2Out $ genNormal htmlScript2In + assertEqual "TEST 3" htmlScript3Out $ genNormal htmlScript3In + assertEqual "TEST 4" htmlScript4Out $ genNormal htmlScript4In + +htmlScript1In = + "\ + \" + +htmlScript1Out = + "\ + \\ + \\ + \\ + \\ + \\ + \" + +htmlScript2In = + "\ + \
\ + \\ + \\ + \
\ + \" + +htmlScript2Out = + "\ + \\ + \
\ + \\ + \\ + \
\ + \\ + \" + +htmlScript3In = + "\ + \" + +htmlScript3Out = + "\ + \\ + \\ + \" + +htmlScript4In = + [r||] + +htmlScript4Out = + [r||] + +testInput :: Test +testInput = testCase "html input" $ do + assertEqual "TEST 1" htmlInputOut $ genNormal htmlInputIn + +htmlInputIn = + "\ + \\ + \\ + \\ + \" + +htmlInputOut = + "\ + \\ + \\ + \\ + \\ + \\ + \" + +testList :: Test +testList = testCase "html list" $ do + assertEqual "TEST 1" htmlList1Out $ genNormal htmlList1In + +htmlList1In = + "\ + \" + +htmlList1Out = + "\ + \\ + \\ + \" + +testScriptBeforeHead :: Test +testScriptBeforeHead = testCase "html script before head" $ do + assertEqual "TEST 1" + htmlScriptBeforeHeadOut $ genNormal htmlScriptBeforeHeadIn + +htmlScriptBeforeHeadIn = + "\ + \\ + \\ + \\ + \" + +htmlScriptBeforeHeadOut = + "\ + \\ + \\ + \\ + \\ + \\ + \" + +testComment :: Test +testComment = testCase "html comment" $ do + assertEqual "TEST 1" + htmlCommentOut $ genNormal htmlCommentIn + +htmlCommentIn = + "\ + \\ + \\ + \" + +htmlCommentOut = + "\ + \\ + \\ + \\ + \\ + \" + +testEntity :: Test +testEntity = testCase "html entity" $ do + assertEqual "TEST 1" + htmlEntity1Out $ genEntity htmlEntity1In False + assertEqual "TEST 2" + htmlEntity2Out $ genEntity htmlEntity1In True + assertEqual "TEST 3" + htmlEntityNum1Out $ genEntity htmlEntityNumIn False + assertEqual "TEST 4" + htmlEntityNum2Out $ genEntity htmlEntityNumIn True + +htmlEntity1In = + "\ + \

&

" + +htmlEntity1Out = + "\ + \\ + \\ + \\ + \\ + \

&

\ + \\ + \" + +htmlEntity2Out = + "\ + \\ + \\ + \\ + \\ + \

&

\ + \\ + \" + +htmlEntityNumIn = + "

−Δ 

" + +htmlEntityNum1Out = + "\ + \

\8722\916 

" + +htmlEntityNum2Out = + "\ + \

−Δ 

" + +testAfterHead :: Test +testAfterHead = testCase "html after head" $ do + assertEqual "TEST 1" htmlAfterHead1Out $ genNormal htmlAfterHead1In + +htmlAfterHead1In = + "\ + \\ + \\ + \\ + \\ + \\ + \\ + \" + +htmlAfterHead1Out = + "\ + \\ + \\ + \\ + \\ + \\ + \\ + \" diff --git a/test/Zenacy/HTML/Internal/Image/Tests.hs b/test/Zenacy/HTML/Internal/Image/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Zenacy/HTML/Internal/Image/Tests.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Zenacy.HTML.Internal.Image.Tests + ( testImage + ) where + +import Zenacy.HTML.Internal.BS +import Zenacy.HTML.Internal.Char +import Zenacy.HTML.Internal.Image +import Zenacy.HTML.Internal.Types +import Data.Text + ( Text + ) +import qualified Data.Text as T + ( reverse + ) +import Test.Framework + ( Test + , testGroup + ) +import Test.Framework.Providers.HUnit + ( testCase + ) +import Test.HUnit + ( assertBool + , assertEqual + , assertFailure + ) + +testImage :: Test +testImage = testGroup "Zenacy.HTML.Internal.Image" + [ testParse + , testRender + , testURL + , testMap + , testMin + , testMax + ] + +testParse :: Test +testParse = testCase "srcset parse" $ do + assertEqual "TEST 1" + (HTMLSrcset []) + (htmlSrcsetParse "") + assertEqual "TEST 2" + (HTMLSrcset [HTMLSrcsetCandidate "/a/b/c" HTMLSrcsetNone]) + (htmlSrcsetParse "/a/b/c") + assertEqual "TEST 3" + (HTMLSrcset [HTMLSrcsetCandidate "/a/b/c" (HTMLSrcsetPixel 2)]) + (htmlSrcsetParse "/a/b/c 2x") + assertEqual "TEST 4" + (HTMLSrcset + [HTMLSrcsetCandidate "/a" HTMLSrcsetNone + ,HTMLSrcsetCandidate "/b" HTMLSrcsetNone + ]) + (htmlSrcsetParse "/a,/b") + assertEqual "TEST 5" + (HTMLSrcset + [HTMLSrcsetCandidate "/a" (HTMLSrcsetPixel 2) + ,HTMLSrcsetCandidate "/b" (HTMLSrcsetWidth 2) + ]) + (htmlSrcsetParse "/a 2x , /b 2w") + assertEqual "TEST 6" + (HTMLSrcset []) + (htmlSrcsetParse ",") + assertEqual "TEST 7" + (HTMLSrcset [HTMLSrcsetCandidate "/a/b/c" HTMLSrcsetNone]) + (htmlSrcsetParse " /a/b/c ") + assertEqual "TEST 8" + (HTMLSrcset [HTMLSrcsetCandidate "/a/b/c" HTMLSrcsetNone]) + (htmlSrcsetParse " /a/b/c, ") + assertEqual "TEST 9" + (HTMLSrcset [HTMLSrcsetCandidate "/a/b/c" (HTMLSrcsetPixel 2)]) + (htmlSrcsetParse ",/a/b/c 2x,") + assertEqual "TEST 10" + (HTMLSrcset + [HTMLSrcsetCandidate "/a" (HTMLSrcsetPixel 2) + ,HTMLSrcsetCandidate "/b" (HTMLSrcsetWidth 2) + ]) + (htmlSrcsetParse " /a 2x , /b 2w , ") + +testRender :: Test +testRender = testCase "srcset render" $ do + assertEqual "TEST 1" "" $ p "" + assertEqual "TEST 2" "/a/b/c" $ p "/a/b/c" + assertEqual "TEST 3" "/a/b/c 2x" $ p "/a/b/c 2x" + assertEqual "TEST 4" "/a,/b" $ p "/a,/b" + assertEqual "TEST 5" "/a 2x,/b 2w" $ p "/a 2x,/b 2w" + assertEqual "TEST 6" "" $ p "," + where + p = htmlSrcsetRender + . htmlSrcsetParse + +testURL :: Test +testURL = testCase "srcset list" $ do + assertEqual "TEST 1" [] $ p "" + assertEqual "TEST 2" ["/a/b/c"] $ p "/a/b/c" + assertEqual "TEST 3" ["/a/b/c"] $ p "/a/b/c 3x" + assertEqual "TEST 4" ["/a","/b"] $ p "/a,/b" + assertEqual "TEST 5" ["/a","/b"] $ p "/a 2x,/b 2w" + where + p = htmlSrcsetListURL + . htmlSrcsetParse + +testMap :: Test +testMap = testCase "srcset map" $ do + assertEqual "TEST 1" "a/ 2x,b/ 2w" $ p "/a 2x,/b 2w" + where + p = htmlSrcsetRender + . htmlSrcsetMapURL T.reverse + . htmlSrcsetParse + +testMin :: Test +testMin = testCase "srcset min" $ do + assertEqual "TEST 1" "/a" $ p "/a,/b 2x" + assertEqual "TEST 2" "/a" $ p "/a" + assertEqual "TEST 3" "/a" $ p "/a 100w" + assertEqual "TEST 4" "/a" $ p "/c 3x, /d 4x, /a, /b 2x" + where + p = htmlSrcsetImageMin + . htmlSrcsetParse + +testMax :: Test +testMax = testCase "srcset max" $ do + assertEqual "TEST 1" "/b" $ p "/a,/b 2x" + assertEqual "TEST 2" "/a" $ p "/a" + assertEqual "TEST 3" "/a" $ p "/a 100w" + assertEqual "TEST 4" "/d" $ p "/c 3x, /d 4x, /a, /b 2x" + where + p = htmlSrcsetImageMax + . htmlSrcsetParse diff --git a/test/Zenacy/HTML/Internal/Lexer/Tests.hs b/test/Zenacy/HTML/Internal/Lexer/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Zenacy/HTML/Internal/Lexer/Tests.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE QuasiQuotes #-} + +module Zenacy.HTML.Internal.Lexer.Tests + ( testLexer + ) where + +import Zenacy.HTML.Internal.BS +import Zenacy.HTML.Internal.Char +import Zenacy.HTML.Internal.Lexer +import Zenacy.HTML.Internal.Token +import Zenacy.HTML.Internal.Types +import Control.Monad.ST +import Data.Default + ( Default(..) + ) +import Data.DList + ( DList + ) +import qualified Data.DList as D + ( empty + , snoc + , toList + ) +import Data.Either.Extra + ( fromRight + ) +import Data.Monoid + ( (<>) + ) +import Test.Framework + ( Test + , testGroup + ) +import Test.Framework.Providers.HUnit + ( testCase + ) +import Test.HUnit + ( assertBool + , assertEqual + , assertFailure + ) +import Text.RawString.QQ + +testLexer :: Test +testLexer = testGroup "Zenacy.HTML.Internal.Lexer" + [ testBasic + , testBuffer + , testComment + , testDoctype + , testSelfClose + , testPrune + , testCharRef + , testScript + ] + +testBasic :: Test +testBasic = testCase "lexer basic" $ do + assertEqual "TEST 1" + [ TStart "html" False [] + , TStart "body" False [] + , TStart "a" False [tokenAttr "href" "https://example.com"] + , TEnd "a" + , TEnd "body" + , TEnd "html" + , TEOF + ] $ getTokens htmlData + +testBuffer :: Test +testBuffer = testCase "lexer buffer" $ do + assertEqual "TEST 1" + [ TStart "html" False [] + , TStart "body" False [] + , TStart "a" False [tokenAttr "href" "https://example.com"] + , TEnd "a" + , TEnd "body" + , TEnd "html" + , TEOF + ] $ getTokens htmlData + +testComment :: Test +testComment = testCase "lexer comment" $ do + assertEqual "TEST 1" + [ TComment "abcxyz" + , TComment " abcxyz " + , TEOF + ] $ getTokens htmlComm + +testDoctype :: Test +testDoctype = testCase "lexer doctype" $ do + assertEqual "TEST 1" + [ TDoctype "html" False Nothing Nothing, TEOF ] $ + getTokens [r||] + assertEqual "TEST 2" + [ TDoctype "html" False (Just "A") (Just "B"), TEOF ] $ + getTokens [r||] + assertEqual "TEST 3" + [ TDoctype "html" False Nothing (Just "x"), TEOF ] $ + getTokens [r||] + assertEqual "TEST 4" + [ TDoctype "html" True Nothing Nothing, TEOF ] $ + getTokens [r||] + assertEqual "TEST 5" + [ TDoctype "html" False Nothing Nothing, TEOF ] $ + getTokens [r||] + assertEqual "TEST 6" + [ TDoctype "html" False Nothing Nothing, TEOF ] $ + getTokens [r||] + +testSelfClose :: Test +testSelfClose = testCase "lexer self close" $ do + assertEqual "TEST 1" + [ TStart "meta" True [tokenAttr "charset" "UTF-8"] + , TEOF + ] $ getTokens [r||] + +testPrune :: Test +testPrune = testCase "lexer prune" $ do + assertEqual "TEST 1" + [ TStart "div" True [tokenAttr "id" "1"] + , TEOF + ] $ getTokens [r|
|] + +testCharRef :: Test +testCharRef = testCase "lexer char ref" $ do + assertEqual "TEST 1" + [ TStart "div" True [tokenAttr "a" "\226\136\128"] + , TEOF + ] $ getTokens [r|
|] + assertEqual "TEST 2" + [ TStart "div" True [tokenAttr "b" "\226\135\146"] + , TEOF + ] $ getTokens [r|
|] + assertEqual "TEST 3" + [ TStart "div" False [tokenAttr "c" "\226\136\183"] + , TEOF + ] $ getTokens [r|
|] + assertEqual "TEST 4" + [ TStart "div" False [] + , TChar 226 + , TChar 136 + , TChar 130 + , TEnd "div" + , TEOF + ] $ getTokens [r|
∂
|] + assertEqual "TEST 5" + [ TStart "div" False [tokenAttr "a" "\226\136\128\226\136\128"] + , TEOF + ] $ getTokens [r|
|] + +testScript :: Test +testScript = testCase "lexer script" $ do + run "TEST 1" "var a = 0;" + where + run x y = assertEqual x (res y) $ getTokens (scr y) + scr x = "" + res x = [TStart "script" False []] + <> map TChar (bsUnpack x) + <> [TEnd "script", TEOF] + +getTokens :: BS -> [Token] +getTokens s = + runST $ do + lexerNew def { lexerOptionInput = s } >>= \case + Left e -> pure [] + Right x -> go x D.empty + where + go x a = do + lexerNext x >>= \case + TEOF -> pure $ D.toList $ D.snoc a TEOF + token -> go x $ D.snoc a token + +htmlData = [r||] + +htmlComm = [r||] diff --git a/test/Zenacy/HTML/Internal/Oper/Tests.hs b/test/Zenacy/HTML/Internal/Oper/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Zenacy/HTML/Internal/Oper/Tests.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Zenacy.HTML.Internal.Oper.Tests + ( testOper + ) where + +import Zenacy.HTML +import Control.Monad + ( (>=>) + ) +import Data.Map + ( Map + ) +import qualified Data.Map as Map + ( fromList + , lookup + ) +import Data.Maybe + ( fromJust + ) +import Test.Framework + ( Test + , testGroup + ) +import Test.Framework.Providers.HUnit + ( testCase + ) +import Test.HUnit + ( assertBool + , assertEqual + , assertFailure + ) + +testOper :: Test +testOper = testGroup "Zenacy.HTML.Internal.Oper" + [ testStyle + ] + +h = fromJust + . htmlDocBody + $ htmlParseEasy + "\ + \

\ + \

AAA

\ + \

\ + \

\ + \

\ + \

\ + \

\ + \

\ + \

\ + \

\ + \
\ + \
\ + \" +f x = fromJust . htmlElemFindID x + +testStyle :: Test +testStyle = testCase "oper style" $ do + assertEqual "TEST 1" m0 $ g "1" + assertEqual "TEST 2" m0 $ g "2" + assertEqual "TEST 3" m0 $ g "3" + assertEqual "TEST 4" m0 $ g "4" + assertEqual "TEST 5" m1 $ g "5" + assertEqual "TEST 6" m2 $ g "6" + assertEqual "TEST 7" m1 $ g "7" + assertEqual "TEST 8" m0 $ g "8" + assertEqual "TEST 9" + (Map.fromList [("background-image","url(https://a/b)")]) + (g "9") + assertEqual "TEST 10" + (Just "https://a/b") + ((Map.lookup "background-image" >=> htmlElemStyleParseURL) (g "9")) + assertEqual "TEST 11" + (Just "https://a/b") + ((Map.lookup "background-image" >=> htmlElemStyleParseURL) (g "10")) + where + g x = htmlElemStyles $ f x h + m0 = Map.fromList [("display","none")] + m1 = Map.fromList [("display","")] + m2 = Map.fromList [] diff --git a/test/Zenacy/HTML/Internal/Parser/Tests.hs b/test/Zenacy/HTML/Internal/Parser/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Zenacy/HTML/Internal/Parser/Tests.hs @@ -0,0 +1,447 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE QuasiQuotes #-} + +module Zenacy.HTML.Internal.Parser.Tests + ( testParser + ) where + +import Zenacy.HTML.Internal.BS +import Zenacy.HTML.Internal.Char +import Zenacy.HTML.Internal.DOM +import Zenacy.HTML.Internal.Lexer +import Zenacy.HTML.Internal.Parser +import Zenacy.HTML.Internal.Token +import Zenacy.HTML.Internal.Types +import Control.Monad.ST +import Data.Default + ( Default(..) + ) +import Data.Either.Extra + ( fromRight + ) +import Data.IntMap + ( IntMap + ) +import qualified Data.IntMap as IntMap + ( fromList + ) +import Data.Sequence + ( Seq + ) +import qualified Data.Sequence as Seq + ( fromList + ) +import GHC.Exts + ( IsList(..) + ) +import Test.Framework + ( Test + , testGroup + ) +import Test.Framework.Providers.HUnit + ( testCase + ) +import Test.HUnit + ( assertBool + , assertEqual + , assertFailure + ) +import Text.RawString.QQ +import Text.Show.Pretty + ( ppShow + , pPrint + ) + +testParser :: Test +testParser = testGroup "Zenacy.HTML.Internal.Parser" + [ testBasic + , testComment + , testTemplate + , testType + , testCode + ] + +testBasic :: Test +testBasic = testCase "parser basic" $ do + assertEqual "TEST 1" domData $ parserResultDOM $ getResult htmlData + +testComment :: Test +testComment = testCase "parser comment" $ do + assertEqual "TEST 1" domComm $ parserResultDOM $ getResult htmlComm + +testTemplate :: Test +testTemplate = testCase "parser template" $ do + assertEqual "TEST 1" domTemp $ parserResultDOM $ getResult htmlTemp + +testType :: Test +testType = testCase "parser type" $ do + assertEqual "TEST 1" domType $ parserResultDOM $ getResult htmlType + +testCode :: Test +testCode = testCase "parser code" $ do + assertEqual "TEST 1" domCode $ parserResultDOM $ getResult htmlCode + +-- | This test case is used to make other test cases by rendering +-- the results of the dom. +testRender :: Test +testRender = testCase "parser render" $ do + let r = getResult htmlCode + let d = parserResultDOM r + pPrint d + assertEqual "TEST 1" def $ ppShow d + +getResult :: BS -> ParserResult +getResult s = fromRight def $ parseDocument def { parserOptionInput = s } + +htmlData = [r|aaabbbccc|] + +htmlComm = [r||] + +htmlTemp = [r||] + +htmlType = [r||] + +htmlCode = [r|−Δ |] + +domData = + DOM + { domNodes = + fromList + [ ( 1 + , DOMDocument + { domDocumentID = 0 + , domDocumentParent = 0 + , domDocumentName = "" + , domDocumentChildren = fromList [ 2 ] + , domDocumentQuirksMode = DOMQuirksMode + } + ) + , ( 2 + , DOMElement + { domElementID = 2 + , domElementParent = 1 + , domElementName = "html" + , domElementNamespace = HTMLNamespaceHTML + , domElementAttributes = fromList [] + , domElementChildren = fromList [ 3 , 4 ] + } + ) + , ( 3 + , DOMElement + { domElementID = 3 + , domElementParent = 2 + , domElementName = "head" + , domElementNamespace = HTMLNamespaceHTML + , domElementAttributes = fromList [] + , domElementChildren = fromList [] + } + ) + , ( 4 + , DOMElement + { domElementID = 4 + , domElementParent = 2 + , domElementName = "body" + , domElementNamespace = HTMLNamespaceHTML + , domElementAttributes = fromList [] + , domElementChildren = fromList [ 5 , 6 , 8 ] + } + ) + , ( 5 + , DOMText + { domTextID = 5 , domTextParent = 4 , domTextData = "aaa" } + ) + , ( 6 + , DOMElement + { domElementID = 6 + , domElementParent = 4 + , domElementName = "a" + , domElementNamespace = HTMLNamespaceHTML + , domElementAttributes = + fromList + [ DOMAttr + { domAttrName = "href" + , domAttrVal = "https://example.com" + , domAttrNamespace = HTMLAttrNamespaceNone + } + ] + , domElementChildren = fromList [ 7 ] + } + ) + , ( 7 + , DOMText + { domTextID = 7 , domTextParent = 6 , domTextData = "bbb" } + ) + , ( 8 + , DOMText + { domTextID = 8 , domTextParent = 4 , domTextData = "ccc" } + ) + ] + , domNextID = 9 + } + +domComm = + DOM + { domNodes = + fromList + [ ( 1 + , DOMDocument + { domDocumentID = 0 + , domDocumentParent = 0 + , domDocumentName = "" + , domDocumentChildren = fromList [ 2 , 3 , 4 ] + , domDocumentQuirksMode = DOMQuirksMode + } + ) + , ( 2 + , DOMComment + { domCommentID = 2 + , domCommentParent = 1 + , domCommentData = "abcxyz" + } + ) + , ( 3 + , DOMComment + { domCommentID = 3 + , domCommentParent = 1 + , domCommentData = " abcxyz " + } + ) + , ( 4 + , DOMElement + { domElementID = 4 + , domElementParent = 1 + , domElementName = "html" + , domElementNamespace = HTMLNamespaceHTML + , domElementAttributes = fromList [] + , domElementChildren = fromList [ 5 , 6 ] + } + ) + , ( 5 + , DOMElement + { domElementID = 5 + , domElementParent = 4 + , domElementName = "head" + , domElementNamespace = HTMLNamespaceHTML + , domElementAttributes = fromList [] + , domElementChildren = fromList [] + } + ) + , ( 6 + , DOMElement + { domElementID = 6 + , domElementParent = 4 + , domElementName = "body" + , domElementNamespace = HTMLNamespaceHTML + , domElementAttributes = fromList [] + , domElementChildren = fromList [] + } + ) + ] + , domNextID = 7 + } + +domTemp = + DOM + { domNodes = + fromList + [ ( 1 + , DOMDocument + { domDocumentID = 0 + , domDocumentParent = 0 + , domDocumentName = "" + , domDocumentChildren = fromList [ 2 , 3 ] + , domDocumentQuirksMode = DOMQuirksNone + } + ) + , ( 2 + , DOMDoctype + { domDoctypeID = 2 + , domDoctypeParent = 1 + , domDoctypeName = "html" + , domDoctypePublicID = Nothing + , domDoctypeSystemID = Nothing + } + ) + , ( 3 + , DOMElement + { domElementID = 3 + , domElementParent = 1 + , domElementName = "html" + , domElementNamespace = HTMLNamespaceHTML + , domElementAttributes = fromList [] + , domElementChildren = fromList [ 4 , 9 ] + } + ) + , ( 4 + , DOMElement + { domElementID = 4 + , domElementParent = 3 + , domElementName = "head" + , domElementNamespace = HTMLNamespaceHTML + , domElementAttributes = fromList [] + , domElementChildren = fromList [ 6 ] + } + ) + , ( 5 + , DOMFragment + { domFragmentID = 5 + , domFragmentParent = 6 + , domFragmentName = "" + , domFragmentChildren = fromList [ 7 ] + } + ) + , ( 6 + , DOMTemplate + { domTemplateID = 6 + , domTemplateParent = 4 + , domTemplateNamespace = HTMLNamespaceHTML + , domTemplateAttributes = fromList [] + , domTemplateContents = 5 + } + ) + , ( 7 + , DOMElement + { domElementID = 7 + , domElementParent = 5 + , domElementName = "div" + , domElementNamespace = HTMLNamespaceHTML + , domElementAttributes = fromList [] + , domElementChildren = fromList [ 8 ] + } + ) + , ( 8 + , DOMText { domTextID = 8 , domTextParent = 7 , domTextData = "a" } + ) + , ( 9 + , DOMElement + { domElementID = 9 + , domElementParent = 3 + , domElementName = "body" + , domElementNamespace = HTMLNamespaceHTML + , domElementAttributes = fromList [] + , domElementChildren = fromList [] + } + ) + ] + , domNextID = 10 + } + +domType = + DOM + { domNodes = + fromList + [ ( 1 + , DOMDocument + { domDocumentID = 0 + , domDocumentParent = 0 + , domDocumentName = "" + , domDocumentChildren = fromList [ 2 , 3 ] + , domDocumentQuirksMode = DOMQuirksNone + } + ) + , ( 2 + , DOMDoctype + { domDoctypeID = 2 + , domDoctypeParent = 1 + , domDoctypeName = "html" + , domDoctypePublicID = Just "-//W3C//DTD HTML 4.01//EN" + , domDoctypeSystemID = Just "http://www.w3.org/TR/html4/strict.dtd" + } + ) + , ( 3 + , DOMElement + { domElementID = 3 + , domElementParent = 1 + , domElementName = "html" + , domElementNamespace = HTMLNamespaceHTML + , domElementAttributes = fromList [] + , domElementChildren = fromList [ 4 , 5 ] + } + ) + , ( 4 + , DOMElement + { domElementID = 4 + , domElementParent = 3 + , domElementName = "head" + , domElementNamespace = HTMLNamespaceHTML + , domElementAttributes = fromList [] + , domElementChildren = fromList [] + } + ) + , ( 5 + , DOMElement + { domElementID = 5 + , domElementParent = 3 + , domElementName = "body" + , domElementNamespace = HTMLNamespaceHTML + , domElementAttributes = fromList [] + , domElementChildren = fromList [] + } + ) + ] + , domNextID = 6 + } + +domCode = + DOM + { domNodes = + fromList + [ ( 1 + , DOMDocument + { domDocumentID = 0 + , domDocumentParent = 0 + , domDocumentName = "" + , domDocumentChildren = fromList [ 2 , 3 ] + , domDocumentQuirksMode = DOMQuirksNone + } + ) + , ( 2 + , DOMDoctype + { domDoctypeID = 2 + , domDoctypeParent = 1 + , domDoctypeName = "html" + , domDoctypePublicID = Nothing + , domDoctypeSystemID = Nothing + } + ) + , ( 3 + , DOMElement + { domElementID = 3 + , domElementParent = 1 + , domElementName = "html" + , domElementNamespace = HTMLNamespaceHTML + , domElementAttributes = fromList [] + , domElementChildren = fromList [ 4 , 5 ] + } + ) + , ( 4 + , DOMElement + { domElementID = 4 + , domElementParent = 3 + , domElementName = "head" + , domElementNamespace = HTMLNamespaceHTML + , domElementAttributes = fromList [] + , domElementChildren = fromList [] + } + ) + , ( 5 + , DOMElement + { domElementID = 5 + , domElementParent = 3 + , domElementName = "body" + , domElementNamespace = HTMLNamespaceHTML + , domElementAttributes = fromList [] + , domElementChildren = fromList [ 6 ] + } + ) + , ( 6 + , DOMText + { domTextID = 6 + , domTextParent = 5 + , domTextData = "\226\136\146\206\148\194\160" + } + ) + ] + , domNextID = 7 + } diff --git a/test/Zenacy/HTML/Internal/Query/Tests.hs b/test/Zenacy/HTML/Internal/Query/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Zenacy/HTML/Internal/Query/Tests.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Zenacy.HTML.Internal.Query.Tests + ( testQuery + ) where + +import Zenacy.HTML +import Data.Maybe + ( fromJust + ) +import Test.Framework + ( Test + , testGroup + ) +import Test.Framework.Providers.HUnit + ( testCase + ) +import Test.HUnit + ( assertBool + , assertEqual + , assertFailure + ) + +testQuery :: Test +testQuery = testGroup "Zenacy.HTML.Internal.Query" + [ testFirst + , testLast + , testNext + , testPrev + , testUp + , testIsFirst + , testIsLast + , testSave + , testNode + , testName + , testAttr + , testAttrVal + , testId + , testClass + , testGeneral + , testOnly + ] + +h = htmlParseEasy + "

\ + \AAA
\ + \

" +b = fromJust $ htmlDocBody h + +testFirst :: Test +testFirst = testCase "query first" $ do + assertEqual "TEST 1" (Just True) $ + htmlQueryRun b $ do + htmlQueryFirst + htmlQueryName "h1" + htmlQuerySucc True + assertEqual "TEST 2" (Nothing) $ + htmlQueryRun b $ do + htmlQueryFirst + htmlQueryFirst + htmlQuerySucc True + +testLast :: Test +testLast = testCase "query last" $ do + assertEqual "TEST 1" (Just True) $ + htmlQueryRun b $ htmlQueryLast >> htmlQueryName "p" >> htmlQuerySucc True + assertEqual "TEST 2" (Nothing) $ + htmlQueryRun b $ htmlQueryFirst >> htmlQueryLast >> htmlQuerySucc True + +testNext :: Test +testNext = testCase "query next" $ do + assertEqual "TEST 1" (Nothing) $ + htmlQueryRun b $ htmlQueryNext >> htmlQuerySucc True + +testPrev :: Test +testPrev = testCase "query prev" $ do + assertEqual "TEST 1" (Nothing) $ + htmlQueryRun b $ htmlQueryPrev >> htmlQuerySucc True + +testUp :: Test +testUp = testCase "query up" $ do + assertEqual "TEST 1" (Just True) $ + htmlQueryRun b $ htmlQueryLast >> htmlQueryLast >> htmlQueryName "img" + >> htmlQueryUp >> htmlQueryName "p" >> htmlQueryUp >> htmlQueryName "body" + >> htmlQuerySucc True + assertEqual "TEST 2" (Nothing) $ + htmlQueryRun b $ htmlQueryUp >> htmlQuerySucc True + +testIsFirst :: Test +testIsFirst = testCase "query isfirst" $ do + assertEqual "TEST 1" (Just True) $ + htmlQueryRun b $ htmlQueryIsFirst >> htmlQuerySucc True + +testIsLast :: Test +testIsLast = testCase "query islast" $ do + assertEqual "TEST 1" (Just True) $ + htmlQueryRun b $ htmlQueryIsLast >> htmlQuerySucc True + +testSave :: Test +testSave = testCase "query save" $ do + assertEqual "TEST 1" (Just "body") $ + htmlQueryRun b $ htmlQuerySave 4 >> htmlQueryGet 4 >>= \a -> htmlQuerySucc $ htmlElemName a + +testNode :: Test +testNode = testCase "query node" $ do + assertEqual "TEST 1" (Just True) $ + htmlQueryRun b $ htmlQueryNode >>= htmlQuerySucc . htmlElemHasName "body" + +testName :: Test +testName = testCase "query name" $ do + assertEqual "TEST 1" (Just True) $ + htmlQueryRun b $ htmlQueryName "body" >> htmlQuerySucc True + assertEqual "TEST 2" (Nothing) $ + htmlQueryRun b $ htmlQueryName "x" >> htmlQuerySucc True + +testAttr :: Test +testAttr = testCase "query attr" $ do + assertEqual "TEST 1" (Just True) $ + htmlQueryRun b $ do + htmlQueryLast + htmlQueryFirst + htmlQueryNext + htmlQueryAttr "id" + htmlQuerySucc True + assertEqual "TEST 2" (Nothing) $ + htmlQueryRun b $ do + htmlQueryAttr "x" + htmlQuerySucc True + +testAttrVal :: Test +testAttrVal = testCase "query attr val" $ do + assertEqual "TEST 1" (Just True) $ + htmlQueryRun b $ do + htmlQueryLast + htmlQueryFirst + htmlQueryNext + htmlQueryAttrVal "id" "x" + htmlQuerySucc True + assertEqual "TEST 2" (Nothing) $ + htmlQueryRun b $ do + htmlQueryLast + htmlQueryFirst + htmlQueryNext + htmlQueryAttrVal "id" "0" + htmlQuerySucc True + +testId :: Test +testId = testCase "query id" $ do + assertEqual "TEST 1" (Just True) $ + htmlQueryRun b $ do + htmlQueryLast + htmlQueryFirst + htmlQueryNext + htmlQueryId "x" + htmlQuerySucc True + assertEqual "TEST 2" (Nothing) $ + htmlQueryRun b $ do + htmlQueryLast + htmlQueryFirst + htmlQueryNext + htmlQueryId "0" + htmlQuerySucc True + +testClass :: Test +testClass = testCase "query class" $ do + assertEqual "TEST 1" (Just True) $ + htmlQueryRun b $ do + htmlQueryLast + htmlQueryFirst + htmlQueryNext + htmlQueryHasClass "z" + htmlQuerySucc True + assertEqual "TEST 2" (Nothing) $ + htmlQueryRun b $ do + htmlQueryLast + htmlQueryFirst + htmlQueryNext + htmlQueryHasClass "0" + htmlQuerySucc True + +testGeneral :: Test +testGeneral = testCase "query general" $ do + assertEqual "TEST 4" (Just "h1") $ + htmlQueryRun b $ do + htmlQueryName "body" + htmlQueryFirst + htmlQueryName "h1" + htmlQuerySave 1 + htmlQueryNext + htmlQueryName "p" + htmlQueryIsLast + a <- htmlQueryGet 1 + htmlQuerySucc $ htmlElemName a + +testOnly :: Test +testOnly = testCase "query only" $ do + assertEqual "TEST 1" (Just True) $ + htmlQueryRun a $ do + htmlQueryFirst + htmlQueryNext + htmlQueryOnly "span" + htmlQueryOnly "a" + htmlQuerySucc True + assertEqual "TEST 2" (Nothing) $ + htmlQueryRun a $ do + htmlQueryFirst + htmlQueryNext + htmlQueryOnly "a" + htmlQueryOnly "a" + htmlQuerySucc True + assertEqual "TEST 3" (Nothing) $ + htmlQueryRun a $ do + htmlQueryOnly "h1" + htmlQuerySucc True + where + a = fromJust $ htmlDocBody $ htmlParseEasy + "

" diff --git a/test/Zenacy/HTML/Internal/Token/Tests.hs b/test/Zenacy/HTML/Internal/Token/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Zenacy/HTML/Internal/Token/Tests.hs @@ -0,0 +1,610 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Zenacy.HTML.Internal.Token.Tests + ( testToken + ) where + +import Zenacy.HTML.Internal.BS +import Zenacy.HTML.Internal.Char +import Zenacy.HTML.Internal.Token +import Zenacy.HTML.Internal.Types +import Control.Monad +import Control.Monad.ST +import Test.Framework + ( Test + , testGroup + ) +import Test.Framework.Providers.HUnit + ( testCase + ) +import Test.HUnit + ( assertBool + , assertEqual + , assertFailure + ) + +testToken :: Test +testToken = testGroup "Zenacy.HTML.Internal.Token" + [ testType + , testDoctype + , testStart + , testAttr + , testEnd + , testComment + , testChar + , testEof + , testCount + , testOffset + , testDrop + , testSize + , testEmit + , testIter + , testCapacity + , testStartName + , testEndName + , testPrune + ] + +testType :: Test +testType = testCase "token type" $ do + assertEqual "TEST 1" (Just tokenDoctypeType) $ + runST $ f tokenDoctypeInit + assertEqual "TEST 2" (Just tokenTagStartType) $ + runST $ f tokenTagStartInit + assertEqual "TEST 3" (Just tokenTagEndType) $ + runST $ f tokenTagEndInit + assertEqual "TEST 4" (Just tokenCommentType) $ + runST $ f tokenCommentInit + assertEqual "TEST 5" (Just tokenCharType) $ + runST $ f $ tokenCharInit (ctow 'a') + assertEqual "TEST 6" (Just tokenEOFType) $ + runST $ f tokenEOFInit + where + f g = do + b <- tokenBuffer + g b + i <- tokenFirst b + if i == 0 + then pure Nothing + else Just <$> tokenType i b + +testDoctype :: Test +testDoctype = testCase "token doctype" $ do + assertEqual "TEST 1" + (Just $ TDoctype "html" False Nothing Nothing) $ + runST $ do + t <- tokenBuffer + tokenDoctypeInit t + tokenDoctypeNameAppend (ctow 'h') t + tokenDoctypeNameAppend (ctow 't') t + tokenDoctypeNameAppend (ctow 'm') t + tokenDoctypeNameAppend (ctow 'l') t + packFirst t + assertEqual "TEST 2" + (Just $ TDoctype "html" False (Just "abc") Nothing) $ + runST $ do + t <- tokenBuffer + tokenDoctypeInit t + tokenDoctypeNameAppend (ctow 'h') t + tokenDoctypeNameAppend (ctow 't') t + tokenDoctypeNameAppend (ctow 'm') t + tokenDoctypeNameAppend (ctow 'l') t + tokenDoctypePublicIdInit t + tokenDoctypePublicIdAppend (ctow 'a') t + tokenDoctypePublicIdAppend (ctow 'b') t + tokenDoctypePublicIdAppend (ctow 'c') t + packFirst t + assertEqual "TEST 3" + (Just $ TDoctype "html" True (Just "abc") (Just "efg")) $ + runST $ do + t <- tokenBuffer + tokenDoctypeInit t + tokenDoctypeNameAppend (ctow 'h') t + tokenDoctypeNameAppend (ctow 't') t + tokenDoctypeNameAppend (ctow 'm') t + tokenDoctypeNameAppend (ctow 'l') t + tokenDoctypePublicIdInit t + tokenDoctypePublicIdAppend (ctow 'a') t + tokenDoctypePublicIdAppend (ctow 'b') t + tokenDoctypePublicIdAppend (ctow 'c') t + tokenDoctypeSystemIdInit t + tokenDoctypeSystemIdAppend (ctow 'e') t + tokenDoctypeSystemIdAppend (ctow 'f') t + tokenDoctypeSystemIdAppend (ctow 'g') t + tokenDoctypeSetForceQuirks t + packFirst t + +testStart :: Test +testStart = testCase "token start" $ do + assertEqual "TEST 1" + (Just $ TStart "abc" False []) $ + runST $ do + t <- tokenBuffer + tokenTagStartInit t + tokenTagNameAppend (ctow 'a') t + tokenTagNameAppend (ctow 'b') t + tokenTagNameAppend (ctow 'c') t + packFirst t + +testAttr :: Test +testAttr = testCase "token attr" $ do + assertEqual "TEST 1" + (Just $ TStart "abc" False [tokenAttr "id" "108"]) $ + runST $ do + t <- tokenBuffer + tokenTagStartInit t + tokenTagNameAppend (ctow 'a') t + tokenTagNameAppend (ctow 'b') t + tokenTagNameAppend (ctow 'c') t + tokenAttrInit t + tokenAttrNameAppend (ctow 'i') t + tokenAttrNameAppend (ctow 'd') t + tokenAttrValAppend (ctow '1') t + tokenAttrValAppend (ctow '0') t + tokenAttrValAppend (ctow '8') t + packFirst t + assertEqual "TEST 2" + (Just $ TStart "a" False [tokenAttr "x" ""]) $ + runST $ do + t <- tokenBuffer + tokenTagStartInit t + tokenTagNameAppend (ctow 'a') t + tokenAttrInit t + tokenAttrNameAppend (ctow 'x') t + packFirst t + assertEqual "TEST 3" + (Just $ TStart "a" False + [tokenAttr "x" "", tokenAttr "y" ""]) $ + runST $ do + t <- tokenBuffer + tokenTagStartInit t + tokenTagNameAppend (ctow 'a') t + tokenAttrInit t + tokenAttrNameAppend (ctow 'x') t + tokenAttrInit t + tokenAttrNameAppend (ctow 'y') t + packFirst t + assertEqual "TEST 4" + (Just $ TStart "div" False + [ tokenAttr "id" "menu" + , tokenAttr "hidden" "" + , tokenAttr "data" "http" + ]) $ + runST $ do + t <- tokenBuffer + tokenTagStartInit t + tokenTagNameAppend (ctow 'd') t + tokenTagNameAppend (ctow 'i') t + tokenTagNameAppend (ctow 'v') t + tokenAttrInit t + tokenAttrNameAppend (ctow 'i') t + tokenAttrNameAppend (ctow 'd') t + tokenAttrValAppend (ctow 'm') t + tokenAttrValAppend (ctow 'e') t + tokenAttrValAppend (ctow 'n') t + tokenAttrValAppend (ctow 'u') t + tokenAttrInit t + tokenAttrNameAppend (ctow 'h') t + tokenAttrNameAppend (ctow 'i') t + tokenAttrNameAppend (ctow 'd') t + tokenAttrNameAppend (ctow 'd') t + tokenAttrNameAppend (ctow 'e') t + tokenAttrNameAppend (ctow 'n') t + tokenAttrInit t + tokenAttrNameAppend (ctow 'd') t + tokenAttrNameAppend (ctow 'a') t + tokenAttrNameAppend (ctow 't') t + tokenAttrNameAppend (ctow 'a') t + tokenAttrValAppend (ctow 'h') t + tokenAttrValAppend (ctow 't') t + tokenAttrValAppend (ctow 't') t + tokenAttrValAppend (ctow 'p') t + packFirst t + +testEnd :: Test +testEnd = testCase "token end" $ do + assertEqual "TEST 1" + (Just $ TEnd "abc") $ + runST $ do + t <- tokenBuffer + tokenTagEndInit t + tokenTagNameAppend (ctow 'a') t + tokenTagNameAppend (ctow 'b') t + tokenTagNameAppend (ctow 'c') t + packFirst t + +testComment :: Test +testComment = testCase "token comment" $ do + assertEqual "TEST 1" + (Just $ TComment "abc") $ + runST $ do + t <- tokenBuffer + tokenCommentInit t + tokenCommentAppend (ctow 'a') t + tokenCommentAppend (ctow 'b') t + tokenCommentAppend (ctow 'c') t + packFirst t + +testChar :: Test +testChar = testCase "token char" $ do + assertEqual "TEST 1" + (Just $ TChar $ ctow 'a') $ + runST $ do + t <- tokenBuffer + tokenCharInit (ctow 'a') t + packFirst t + +testEof :: Test +testEof = testCase "token eof" $ do + assertEqual "TEST 1" + (Just TEOF) $ + runST $ do + t <- tokenBuffer + tokenEOFInit t + packFirst t + assertEqual "TEST 2" + True $ + runST $ do + t <- tokenBuffer + tokenEOFInit t + tokenHasEOF t + assertEqual "TEST 3" + True $ + runST $ do + t <- tokenBuffer + tokenCommentInit t + tokenTagStartInit t + tokenTagStartInit t + tokenEOFInit t + tokenHasEOF t + assertEqual "TEST 4" + False $ + runST $ do + t <- tokenBuffer + tokenCommentInit t + tokenTagStartInit t + tokenTagStartInit t + tokenHasEOF t + +testCount :: Test +testCount = testCase "token count" $ do + assertEqual "TEST 1" 0 $ + runST $ do + t <- tokenBuffer + tokenCount t + assertEqual "TEST 2" 1 $ + runST $ do + t <- tokenBuffer + tokenTagStartInit t + tokenCount t + assertEqual "TEST 3" 8 $ + runST $ do + t <- tokenBuffer + tokenDoctypeInit t + tokenTagStartInit t + tokenTagEndInit t + tokenTagStartInit t + tokenTagEndInit t + tokenCommentInit t + tokenCharInit (ctow 'a') t + tokenEOFInit t + tokenCount t + +testOffset :: Test +testOffset = testCase "token offset" $ do + assertEqual "TEST 1" [] $ + runST $ do + t <- tokenBuffer + tokenOffset t + assertEqual "TEST 2" [4] $ + runST $ do + t <- tokenBuffer + tag t "p" + tokenOffset t + assertEqual "TEST 3" [4,10] $ + runST $ do + t <- tokenBuffer + tag t "p" + tag t "div" + tokenOffset t + assertEqual "TEST 4" [4,10,16] $ + runST $ do + t <- tokenBuffer + tag t "p" + tag t "div" + tag t "a" + tokenOffset t + where + tag t x = do + tokenTagStartInit t + mapM_ (flip tokenTagNameAppend t) $ bsUnpack x + +testDrop :: Test +testDrop = testCase "token drop" $ do + assertEqual "TEST 1" ["p", "div"] $ + runST $ do + t <- tokenBuffer + tag t "p" + tag t "div" + tag t "a" + tokenDrop t + tokenOffset t >>= mapM (f t) + assertEqual "TEST 2" ["p"] $ + runST $ do + t <- tokenBuffer + tag t "p" + tag t "div" + tag t "a" + tokenDrop t + tokenDrop t + tokenOffset t >>= mapM (f t) + assertEqual "TEST 3" [] $ + runST $ do + t <- tokenBuffer + tag t "p" + tag t "div" + tag t "a" + tokenDrop t + tokenDrop t + tokenDrop t + tokenOffset t >>= mapM (f t) + assertEqual "TEST 4" ["div"] $ + runST $ do + t <- tokenBuffer + tag t "p" + tokenDrop t + tag t "div" + tag t "a" + tokenDrop t + tokenOffset t >>= mapM (f t) + assertEqual "TEST 5" [] $ + runST $ do + t <- tokenBuffer + tokenDrop t + tokenOffset t >>= mapM (f t) + assertEqual "TEST 6" [] $ + runST $ do + t <- tokenBuffer + tag t "p" + tokenDrop t + tokenOffset t >>= mapM (f t) + where + tag t x = do + tokenTagStartInit t + mapM_ (flip tokenTagNameAppend t) $ bsUnpack x + f t x = + tokenTagStartName x t >>= pure . maybe bsEmpty bsPack + +testSize :: Test +testSize = testCase "token size" $ do + assertEqual "TEST 1" Nothing $ + runST $ do + t <- tokenBuffer + sizeFirst t + assertEqual "TEST 2" (Just 11) $ + runST $ do + t <- tokenBuffer + tokenDoctypeInit t + sizeFirst t + assertEqual "TEST 3" (Just 4) $ + runST $ do + t <- tokenBuffer + tokenTagEndInit t + sizeFirst t + assertEqual "TEST 4" (Just 4) $ + runST $ do + t <- tokenBuffer + tokenCommentInit t + sizeFirst t + assertEqual "TEST 5" (Just 3) $ + runST $ do + t <- tokenBuffer + tokenCharInit (ctow 'a') t + sizeFirst t + assertEqual "TEST 6" (Just 2) $ + runST $ do + t <- tokenBuffer + tokenEOFInit t + sizeFirst t + assertEqual "TEST 7" (Just 6) $ + runST $ do + t <- tokenBuffer + tokenTagStartInit t + sizeFirst t + assertEqual "TEST 8" (Just 10) $ + runST $ do + t <- tokenBuffer + tokenTagStartInit t + tokenAttrInit t + sizeFirst t + assertEqual "TEST 9" (Just 26) $ + runST $ do + t <- tokenBuffer + tokenTagStartInit t + tokenAttrInit t + tokenAttrInit t + tokenAttrInit t + tokenAttrInit t + tokenAttrInit t + sizeFirst t + +testEmit :: Test +testEmit = testCase "token emit" $ do + assertEqual "TEST 1" ["a","b","c","d","e","f"] $ + runST $ do + t <- tokenBuffer + tokenTagStartInit t + tokenTagNameAppend (ctow 'a') t + tokenAttrInit t + tokenTagEndInit t + tokenTagNameAppend (ctow 'b') t + tokenTagStartInit t + tokenTagNameAppend (ctow 'c') t + tokenAttrInit t + tokenTagEndInit t + tokenTagNameAppend (ctow 'd') t + tokenTagStartInit t + tokenTagNameAppend (ctow 'e') t + tokenAttrInit t + tokenTagEndInit t + tokenTagNameAppend (ctow 'f') t + a <- tokenList t + pure $ map tokenName a + +testIter :: Test +testIter = testCase "token iter" $ do + assertEqual "TEST 1" 0 $ + runST $ do + tokenBuffer >>= tokenFirst + assertEqual "TEST 2" 0 $ + runST $ do + tokenBuffer >>= tokenNext + +testCapacity :: Test +testCapacity = testCase "token capacity" $ do + assertEqual "TEST 1" (100,100) $ + runST $ do + t <- tokenBuffer + tokenCapacity t + assertEqual "TEST 2" (3200,25600) $ + runST $ do + t <- tokenBuffer + forM_ [1..200] $ const $ addToken t + tokenCapacity t + where + addToken t = do + tokenTagStartInit t + forM_ [1..10] $ const $ + tokenTagNameAppend (ctow 'a') t + tokenAttrInit t + forM_ [1..10] $ const $ + tokenAttrNameAppend (ctow 'b') t + forM_ [1..40] $ const $ + tokenAttrValAppend (ctow 'c') t + tokenTagEndInit t + forM_ [1..5] $ const $ + tokenTagNameAppend (ctow 'x') t + +testStartName :: Test +testStartName = testCase "token start name" $ do + assertEqual "TEST 1" [Just "p", Just "a", Nothing, Just "div"] $ + runST $ do + t <- tokenBuffer + tokenTagStartInit t + tokenTagNameAppend (ctow 'p') t + tokenTagStartInit t + tokenTagNameAppend (ctow 'a') t + tokenTagEndInit t + tokenTagNameAppend (ctow 'a') t + tokenTagStartInit t + tokenTagNameAppend (ctow 'd') t + tokenTagNameAppend (ctow 'i') t + tokenTagNameAppend (ctow 'v') t + tokenOffset t >>= mapM (f t) + assertEqual "TEST 2" (Just "i") $ + runST $ do + t <- tokenBuffer + tokenTagStartInit t + tokenTagNameAppend (ctow 'i') t + tokenTail t >>= f t + where + f t x = + tokenTagStartName x t >>= pure . maybe Nothing (Just . bsPack) + +testEndName :: Test +testEndName = testCase "token end name" $ do + assertEqual "TEST 1" (Just "b") $ + runST $ do + t <- tokenBuffer + tokenTagEndInit t + tokenTagNameAppend (ctow 'b') t + tokenTail t >>= f t + where + f t x = + tokenTagEndName x t >>= pure . maybe Nothing (Just . bsPack) + +testPrune :: Test +testPrune = testCase "token prune" $ do + assertEqual "TEST 1" + (True, Just $ TStart "div" False + [ tokenAttr "id" "menu" + , tokenAttr "hidden" "" + , tokenAttr "data" "http" + ]) $ + runST $ do + t <- tokenBuffer + tokenTagStartInit t + tokenTagNameAppend (ctow 'd') t + tokenTagNameAppend (ctow 'i') t + tokenTagNameAppend (ctow 'v') t + tokenAttrInit t + tokenAttrNameAppend (ctow 'i') t + tokenAttrNameAppend (ctow 'd') t + tokenAttrValAppend (ctow 'm') t + tokenAttrValAppend (ctow 'e') t + tokenAttrValAppend (ctow 'n') t + tokenAttrValAppend (ctow 'u') t + tokenAttrInit t + tokenAttrNameAppend (ctow 'h') t + tokenAttrNameAppend (ctow 'i') t + tokenAttrNameAppend (ctow 'd') t + tokenAttrNameAppend (ctow 'd') t + tokenAttrNameAppend (ctow 'e') t + tokenAttrNameAppend (ctow 'n') t + tokenAttrInit t + tokenAttrNameAppend (ctow 'd') t + tokenAttrNameAppend (ctow 'a') t + tokenAttrNameAppend (ctow 't') t + tokenAttrNameAppend (ctow 'a') t + tokenAttrValAppend (ctow 'h') t + tokenAttrValAppend (ctow 't') t + tokenAttrValAppend (ctow 't') t + tokenAttrValAppend (ctow 'p') t + tokenAttrInit t + tokenAttrNameAppend (ctow 'd') t + tokenAttrNameAppend (ctow 'a') t + tokenAttrNameAppend (ctow 't') t + tokenAttrNameAppend (ctow 'a') t + tokenAttrInit t + tokenAttrNameAppend (ctow 'i') t + tokenAttrNameAppend (ctow 'd') t + tokenAttrValAppend (ctow 'x') t + i <- tokenTail t + a <- tokenAttrNamePrune i t + b <- packFirst t + pure (a, b) + assertEqual "TEST 2" + (False, Just $ TStart "div" False + [ tokenAttr "id" "1" + ]) $ + runST $ do + t <- tokenBuffer + tokenTagStartInit t + tokenTagNameAppend (ctow 'd') t + tokenTagNameAppend (ctow 'i') t + tokenTagNameAppend (ctow 'v') t + tokenAttrInit t + tokenAttrNameAppend (ctow 'i') t + tokenAttrNameAppend (ctow 'd') t + tokenAttrValAppend (ctow '1') t + tokenAttrInit t + i <- tokenTail t + a <- tokenAttrNamePrune i t + b <- packFirst t + pure (a, b) + +packFirst t = do + i <- tokenFirst t + if i == 0 + then pure Nothing + else Just <$> tokenPack i t + +sizeFirst t = do + i <- tokenFirst t + if i == 0 + then pure Nothing + else Just <$> tokenSize i t + +tokenName (TStart n _ _) = n +tokenName (TEnd n) = n +tokenName _ = "" diff --git a/test/Zenacy/HTML/Internal/Trie/Tests.hs b/test/Zenacy/HTML/Internal/Trie/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Zenacy/HTML/Internal/Trie/Tests.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Zenacy.HTML.Internal.Trie.Tests + ( testTrie + ) where + +import qualified Zenacy.HTML.Internal.Trie as Trie +import Control.Monad + ( (>=>) + ) +import Control.Monad.Writer + ( Writer(..) + , execWriter + , tell + ) +import Data.Maybe + ( fromJust + ) +import Test.Framework + ( Test + , testGroup + ) +import Test.Framework.Providers.HUnit + ( testCase + ) +import Test.HUnit + ( assertBool + , assertEqual + , assertFailure + ) +import Data.Text + ( Text + ) +import qualified Data.Text as T + ( concat + ) + +testTrie :: Test +testTrie = testGroup "Zenacy.HTML.Internal.Trie" + [ testMatch + ] + +testMatch :: Test +testMatch = testCase "trie match" $ do + assertEqual "TEST 1" Nothing $ Trie.match t0 "z" + assertEqual "TEST 2" (Just ("a", 1, "")) $ Trie.match t0 "a" + assertEqual "TEST 3" (Just ("a", 1, "y")) $ Trie.match t0 "ay" + assertEqual "TEST 4" (Just ("bbb", 5, "yyy")) $ Trie.match t2 "bbbyyy" + assertEqual "TEST 5" (Just ("ccc", 7, "yyy")) $ Trie.match t2 "cccyyy" + assertEqual "TEST 6" Nothing $ Trie.match t1 "z" + assertEqual "TEST 7" (Just ("aa", 1, "")) $ Trie.match t1 "aa" + assertEqual "TEST 8" (Just ("bb", 2, "")) $ Trie.match t1 "bb" + assertEqual "TEST 9" (Just ("a", 1, "z")) $ Trie.match t2 "az" + assertEqual "TEST 10" (Just ("aa", 2, "z")) $ Trie.match t2 "aaz" + assertEqual "TEST 11" (Just ("aaa", 3, "z")) $ Trie.match t2 "aaaz" + assertEqual "TEST 12" (Just ("bb", 4, "z")) $ Trie.match t2 "bbz" + assertEqual "TEST 13" (Just ("aaax", 6, "z")) $ Trie.match t2 "aaaxz" + +t0 = Trie.fromList + [ ("a", 1) + ] + +t1 = Trie.fromList + [ ("aa", 1) + , ("bb", 2) + ] + +t2 = Trie.fromList + [ ("a", 1) + , ("aa", 2) + , ("aaa", 3) + , ("bb", 4) + , ("bbb", 5) + , ("aaax", 6) + , ("ccc", 7) + ] diff --git a/test/Zenacy/HTML/Internal/Zip/Tests.hs b/test/Zenacy/HTML/Internal/Zip/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Zenacy/HTML/Internal/Zip/Tests.hs @@ -0,0 +1,503 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Zenacy.HTML.Internal.Zip.Tests + ( testZip + ) where + +import Zenacy.HTML +import Control.Monad + ( (>=>) + ) +import Control.Monad.Writer + ( Writer + , execWriter + , tell + ) +import Data.Maybe + ( fromJust + ) +import Test.Framework + ( Test + , testGroup + ) +import Test.Framework.Providers.HUnit + ( testCase + ) +import Test.HUnit + ( assertBool + , assertEqual + , assertFailure + ) +import Data.Text + ( Text + ) +import qualified Data.Text as T + ( concat + ) + +testZip :: Test +testZip = testGroup "Zenacy.HTML.Internal.Zip" + [ testFind + , testFirst + , testLast + , testParent + , testRoot + , testModify + , testDelete + , testNext + , testPrev + , testGet + , testInsertBefore + , testInsertAfter + , testUnzip + , testStep + , testSearch + , testContentLeft + , testContentRight + , testDropLeft + , testDropRight + , testPruneLeft + , testPruneRight + , testIndex + , testPath + , testPathFind + , testTest + , testIterModify + ] + +h :: HTMLNode +h = htmlParseEasy "

AAA

" + +z :: HTMLZipper +z = htmlZip h + +f :: Text -> HTMLZipper -> Maybe HTMLZipper +f x = htmlZipFind $ htmlElemHasName x + +n :: HTMLZipper -> Text +n = htmlElementName . htmlZipNode + +g :: HTMLZipper -> Maybe Text +g = Just . n + +testFind :: Test +testFind = testCase "zip find" $ do + assertEqual "TEST 1" (Just "html") + ((f "html" >=> g) z) + assertEqual "TEST 2" (Just "body") + ((f "html" >=> f "body" >=> g) z) + assertEqual "TEST 3" (Just "h1") + ((f "html" >=> f "body" >=> f "h1" >=> g) z) + assertEqual "TEST 4" (Just "p") + ((f "html" >=> f "body" >=> f "p" >=> g) z) + assertEqual "TEST 5" (Just "a") + ((f "html" >=> f "body" >=> f "p" >=> f "a" >=> g) z) + assertEqual "TEST 6" (Just "span") + ((f "html" >=> f "body" >=> f "p" >=> f "span" >=> g) z) + assertEqual "TEST 7" (Just "br") + ((f "html" >=> f "body" >=> f "p" >=> f "br" >=> g) z) + assertEqual "TEST 8" (Just "img") + ((f "html" >=> f "body" >=> f "p" >=> f "img" >=> g) z) + assertEqual "TEST 9" Nothing + ((f "x" >=> g) z) + +testFirst :: Test +testFirst = testCase "zip first" $ do + assertEqual "TEST 1" (Just "h1") $ + (f "html" >=> f "body" >=> htmlZipFirst >=> g) z + assertEqual "TEST 2" (Just "a") $ + (f "html" >=> f "body" >=> f "p" >=> htmlZipFirst >=> g) z + +testLast :: Test +testLast = testCase "zip last" $ do + assertEqual "TEST 1" (Just "p") $ + (f "html" >=> f "body" >=> htmlZipLast >=> g) z + assertEqual "TEST 2" (Just "img") $ + (f "html" >=> f "body" >=> f "p" >=> htmlZipLast >=> g) z + +testParent :: Test +testParent = testCase "zip parent" $ do + let p = htmlZipParent + let q = f "html" >=> f "body" >=> f "p" >=> f "br" + assertEqual "TEST 1" (Just "p") $ (q >=> p >=> g) z + assertEqual "TEST 2" (Just "body") $ (q >=> p >=> p >=> g) z + assertEqual "TEST 3" (Just "html") $ (q >=> p >=> p >=> p >=> g) z + +testRoot :: Test +testRoot = testCase "zip root" $ do + case (f "html" >=> f "body" >=> f "p" >=> f "br") z of + Nothing -> + assertFailure "TEST 1" + Just z' -> + case htmlZipNode (htmlZipRoot z') of + HTMLDocument {} -> + assertBool "TEST 2" True + _ -> + assertFailure "TEST 3" + +testModify :: Test +testModify = testCase "zip modify" $ do + case (f "html" >=> f "body" >=> f "h1") z of + Nothing -> + assertFailure "TEST 1" + Just z' -> do + let r y = htmlZipModify (\x -> x { htmlElementName = y }) + assertEqual "TEST 2" "h1" $ n z' + assertEqual "TEST 3" "h2" $ n $ r "h2" z' + +testDelete :: Test +testDelete = testCase "zip delete" $ do + let q = f "html" >=> f "body" >=> htmlZipDelete + let h' = htmlUnzip $ fromJust $ q z + assertEqual "TEST 1" "" $ htmlRender h' + +testNext :: Test +testNext = testCase "zip next" $ do + let t = htmlZipNext + let q = f "html" >=> f "body" >=> f "p" >=> htmlZipFirst + assertEqual "TEST 1" (Just "a") $ + (q >=> g) z + assertEqual "TEST 2" (Just "span") $ + (q >=> t >=> g) z + assertEqual "TEST 3" (Just "br") $ + (q >=> t >=> t >=> g) z + assertEqual "TEST 4" (Just "img") $ + (q >=> t >=> t >=> t >=> g) z + assertEqual "TEST 5" Nothing $ + (q >=> t >=> t >=> t >=> t >=> g) z + +testPrev :: Test +testPrev = testCase "zip prev" $ do + let t = htmlZipPrev + let q = f "html" >=> f "body" >=> f "p" >=> htmlZipLast + assertEqual "TEST 1" (Just "img") $ + (q >=> g) z + assertEqual "TEST 2" (Just "br") $ + (q >=> t >=> g) z + assertEqual "TEST 3" (Just "span") $ + (q >=> t >=> t >=> g) z + assertEqual "TEST 4" (Just "a") $ + (q >=> t >=> t >=> t >=> g) z + assertEqual "TEST 5" Nothing $ + (q >=> t >=> t >=> t >=> t >=> g) z + +testGet :: Test +testGet = testCase "zip get" $ do + let q = f "html" >=> f "body" >=> f "p" + assertEqual "TEST 1" (Just "a") $ + (q >=> htmlZipGet 0 >=> g) z + assertEqual "TEST 2" (Just "span") $ + (q >=> htmlZipGet 1 >=> g) z + assertEqual "TEST 3" (Just "br") $ + (q >=> htmlZipGet 2 >=> g) z + assertEqual "TEST 4" (Just "img") $ + (q >=> htmlZipGet 3 >=> g) z + assertEqual "TEST 5" Nothing $ + (q >=> htmlZipGet 4 >=> g) z + +testInsertBefore :: Test +testInsertBefore = testCase "zip insert before" $ do + let q = f "html" >=> f "body" >=> htmlZipLast + let e = htmlDefaultElement { htmlElementName = "h2" } + assertEqual "TEST 1" (Just "h2") $ + (q >=> htmlZipInsertBefore e >=> htmlZipPrev >=> g) z + +testInsertAfter :: Test +testInsertAfter = testCase "zip insert after" $ do + let q = f "html" >=> f "body" >=> htmlZipFirst + let e = htmlDefaultElement { htmlElementName = "h2" } + assertEqual "TEST 1" (Just "h2") $ + (q >=> htmlZipInsertAfter e >=> htmlZipNext >=> g) z + +testUnzip :: Test +testUnzip = testCase "zip unzip" $ do + let q = f "html" >=> f "body" >=> f "p" >=> f "a" >=> + pure . htmlZipModify (htmlElemAttrRemove "href") + let h' = htmlUnzip $ fromJust $ q z + assertEqual "TEST 1" + "\ + \

AAA

\ + \" $ + htmlRender h' + +testStep :: Test +testStep = testCase "zip step" $ do + assertEqual "TEST 1" + ["html","head","body","h1","p","a","span","br","img", + "div","p","span","a","img"] + $ w htmlZipStepNext + assertEqual "TEST 2" + ["html","body","div","p","span","img","a","p", + "img","br","span","a","h1","head"] + $ w htmlZipStepBack + where + w h' = execWriter $ f h' z + f :: (HTMLZipper -> Maybe HTMLZipper) -> HTMLZipper -> Writer [Text] HTMLZipper + f h z' = case h z' of + Nothing -> return z' + Just x -> tell [n x] >> f h x + z = htmlZip $ htmlParseEasy $ T.concat + [ "

" + , "


" + , "

" + ] + +testSearch :: Test +testSearch = testCase "zip search" $ do + assertEqual "TEST 201" "h1" $ fa (t "h1") + assertEqual "TEST 202" "a" $ fa (i "1") + assertEqual "TEST 203" "a" $ fa (i "2") + assertEqual "TEST 204" "span" $ fa (t "span") + assertEqual "TEST 205" "h1" $ fa (i "3") + assertEqual "TEST 206" "h1" $ ba (t "h1") + assertEqual "TEST 207" "a" $ ba (i "1") + assertEqual "TEST 208" "a" $ ba (i "2") + assertEqual "TEST 209" "span" $ ba (t "span") + assertEqual "TEST 210" "h1" $ ba (i "3") + assertEqual "TEST 211" "img" $ ba (i "8") + assertEqual "TEST 212" "img" $ fa (i "8") + + assertEqual "TEST 301" "h1" $ + m $ (sf (i "8") >=> sb (i "3")) z + assertEqual "TEST 302" "span" $ + m $ (sf (i "8") >=> ib (i "7")) z + assertEqual "TEST 303" "img" $ + m $ (sf (t "img") >=> sf (t "img")) z + where + sf = htmlZipSearch htmlZipStepNext + sb = htmlZipSearch htmlZipStepBack + fa h = m $ sf h z + ba h = m $ sb h z + + ib :: (HTMLZipper -> Bool) -> HTMLZipper -> Maybe HTMLZipper + ib f = htmlIterSearch htmlIterBack f . htmlIter >=> Just . htmlIterZipper + + i x = htmlElemHasAttrVal "id" x . htmlZipNode + t x = htmlElemHasName x . htmlZipNode + m = maybe "" n + z = htmlZip + . htmlParseEasy + . T.concat + $ [ "
" + , "

" + , "


" + , "

" + ] + +testContentLeft :: Test +testContentLeft = testCase "zip content left" $ do + let q x = f "html" >=> f "body" >=> f "p" >=> f x >=> pure . htmlZipContentLeft + let r x = map htmlElemName $ fromJust $ q x z + assertEqual "TEST 1" [] $ r "a" + assertEqual "TEST 2" ["a"] $ r "span" + assertEqual "TEST 3" ["a","span"] $ r "br" + assertEqual "TEST 4" ["a","span","br"] $ r "img" + +testContentRight :: Test +testContentRight = testCase "zip content right" $ do + let q x = f "html" >=> f "body" >=> f "p" >=> f x >=> pure . htmlZipContentRight + let r x = map htmlElemName $ fromJust $ q x z + assertEqual "TEST 1" ["span","br","img"] $ r "a" + assertEqual "TEST 2" ["br","img"] $ r "span" + assertEqual "TEST 3" ["img"] $ r "br" + assertEqual "TEST 4" [] $ r "img" + +testDropLeft :: Test +testDropLeft = testCase "zip drop left" $ do + let q x = f "html" >=> f "body" >=> f "p" >=> f x >=> htmlZipDropLeft + let r x = htmlRender $ htmlUnzip $ fromJust $ q x $ z + assertEqual "TEST 1" + "\ + \

AAA

\ + \" $ + r "a" + assertEqual "TEST 2" + "\ + \


\ + \" $ + r "span" + assertEqual "TEST 3" + "\ + \


\ + \" $ + r "br" + assertEqual "TEST 4" + "\ + \

\ + \" $ + r "img" + +testDropRight :: Test +testDropRight = testCase "zip drop right" $ do + let q x = f "html" >=> f "body" >=> f "p" >=> f x >=> htmlZipDropRight + let r x = htmlRender $ htmlUnzip $ fromJust $ q x $ z + assertEqual "TEST 1" + "\ + \

AAA

\ + \" $ + r "a" + assertEqual "TEST 2" + "\ + \

AAA

\ + \" $ + r "span" + assertEqual "TEST 3" + "\ + \

AAA

\ + \" $ + r "br" + assertEqual "TEST 4" + "\ + \

AAA

\ + \" $ + r "img" + +testPruneLeft :: Test +testPruneLeft = testCase "zip prune left" $ do + assertEqual "TEST 1" + "

" $ + run $ f "div" >=> f "div" >=> f "h1" >=> htmlZipPruneLeft + assertEqual "TEST 2" + "

" $ + run $ f "div" >=> f "div" >=> f "img" >=> htmlZipPruneLeft + assertEqual "TEST 3" + "

" $ + run $ f "div" >=> htmlZipFirst >=> htmlZipNext >=> htmlZipNext + >=> htmlZipPruneLeft + where + run g = htmlRender $ htmlUnzip $ fromJust $ g $ fromJust $ + (htmlZipM >=> f "html" >=> f "body" >=> htmlZipNodeM >=> htmlZipM) $ + htmlParseEasy + "
\ + \

\ + \
\ + \

\ + \
\ + \

\ + \
" + +testPruneRight :: Test +testPruneRight = testCase "zip prune right" $ do + assertEqual "TEST 1" + "

" $ + run $ f "div" >=> f "div" >=> f "h1" >=> htmlZipPruneRight + assertEqual "TEST 2" + "

" $ + run $ f "div" >=> f "div" >=> f "img" >=> htmlZipPruneRight + assertEqual "TEST 3" + "

" $ + run $ f "div" >=> f "div" >=> f "span" >=> htmlZipPruneRight + assertEqual "TEST 4" + "

" $ + run $ f "div" >=> htmlZipFirst >=> htmlZipPruneRight + where + run g = htmlRender $ htmlUnzip $ fromJust $ g $ fromJust $ + (htmlZipM >=> f "html" >=> f "body" >=> htmlZipNodeM >=> htmlZipM) $ + htmlParseEasy + "
\ + \

\ + \
\ + \

\ + \
\ + \

\ + \
" + +testIndex :: Test +testIndex = testCase "zip index" $ do + assertEqual "TEST 1" (Just 0) $ g (i "1") + assertEqual "TEST 2" (Just 0) $ g (i "2") + assertEqual "TEST 3" (Just 1) $ g (i "8") + assertEqual "TEST 4" (Just 1) $ g (i "3") + assertEqual "TEST 4" (Just 0) $ g (i "4") + assertEqual "TEST 5" (Just 3) $ g (i "5") + where + g f = maybe Nothing htmlZipIndex $ htmlZipSearch htmlZipStepNext f z + i x = htmlElemHasAttrVal "id" x . htmlZipNode + z = htmlZip + . htmlParseEasy + . T.concat + $ [ "
" + , "

" + , "


" + , "

" + ] + +testPath :: Test +testPath = testCase "zip path" $ do + assertEqual "TEST 1" (m [0,1,2,0]) $ g (i "1") + assertEqual "TEST 2" (m [0,1,3,0,0,0]) $ g (i "2") + assertEqual "TEST 3" (m [0,1,3,0,0,1]) $ g (i "8") + assertEqual "TEST 4" (m [0,1,1]) $ g (i "3") + assertEqual "TEST 4" (m [0,1,0]) $ g (i "4") + assertEqual "TEST 5" (m [0,1,2,3]) $ g (i "5") + where + m = Just . HTMLZipPath + g f = maybe Nothing (Just . htmlZipPath) $ htmlZipSearch htmlZipStepNext f z + i x = htmlElemHasAttrVal "id" x . htmlZipNode + z = htmlZip + . htmlParseEasy + . T.concat + $ [ "
" + , "

" + , "


" + , "

" + ] + +testPathFind :: Test +testPathFind = testCase "zip path find" $ do + assertEqual "TEST 1" (Just "a") $ f [0,1,2,0] + assertEqual "TEST 2" (Just "span") $ f [0,1,2,1] + assertEqual "TEST 3" (Just "span") $ f [0,1,3,0,0] + assertEqual "TEST 4" (Just "a") $ f [0,1,3,0,0,0] + assertEqual "TEST 5" (Just "img") $ f [0,1,3,0,0,1] + where + f p = htmlZipPathFind (HTMLZipPath p) z >>= g + z = htmlZip + . htmlParseEasy + . T.concat + $ [ "
" + , "

" + , "


" + , "

" + ] + +testTest :: Test +testTest = testCase "zip test" $ do + assertEqual "TEST 1" (Just True) + ((name "body" >=> frst >=> name "h1" >=> next >=> name "p" >=> tlst >=> s) z') + assertEqual "TEST 2" (Nothing) + ((name "body" >=> frst >=> name "h1" >=> next >=> name "a" >=> tlst >=> s) z') + assertEqual "TEST 3" (Nothing) + ((name "body" >=> frst >=> name "h1" >=> next >=> name "p" >=> tfst >=> s) z') + assertEqual "TEST 4" (Just "h1") $ + htmlZipM b >>= + htmlZipTestName "body" >>= + htmlZipFirst >>= + htmlZipTestName "h1" >>= \n0 -> + htmlZipNext n0 >>= + htmlZipTestName "p" >>= + htmlZipTestLast >> + pure (htmlElemName $ htmlZipNode n0) + where + b = fromJust $ htmlDocBody h + z' = htmlZip b + frst = htmlZipFirst + next = htmlZipNext + tfst = htmlZipTestFirst + tlst = htmlZipTestLast + name = htmlZipTestName + s = const $ pure True + +testIterModify :: Test +testIterModify = testCase "zip iter modify" $ do + assertEqual "TEST 1" n' (f' b') + where + b' = fromJust $ htmlDocBody h + n' = "newname" + f' = ( htmlElemName + . htmlUnzip + . htmlIterZipper + . htmlIterModify (htmlZipModify (htmlElemRename n')) + . htmlIter + . htmlZip + ) diff --git a/zenacy-html.cabal b/zenacy-html.cabal new file mode 100644 --- /dev/null +++ b/zenacy-html.cabal @@ -0,0 +1,185 @@ +cabal-version: >= 1.10 +name: + zenacy-html +version: + 2.0.0 +synopsis: + A standard compliant HTML parsing library +description: + Zenacy HTML is an HTML parsing and processing library that implements the + WHATWG HTML parsing standard. The standard is described as a state machine + that this library implements exactly as spelled out including all the error + handling, recovery, and conformance checks that makes it robust in handling + any HTML pulled from the web. In addition to parsing, the library provides + many processing features to help extract information from web pages or + rewrite them and render the modified results. +homepage: + https://github.com/mlcfp/zenacy-html +license: + MIT +license-file: + LICENSE +author: + Michael Williams +maintainer: + Michael Williams +copyright: + Copyright (C) 2015-2020 Michael P Williams +category: + Web +build-type: + Simple +extra-source-files: + README.md CHANGES.md + +source-repository head + type: git + location: https://github.com/mlcfp/zenacy-html.git + +library + hs-source-dirs: + src + exposed-modules: + Zenacy.HTML + , Zenacy.HTML.Internal.BS + , Zenacy.HTML.Internal.Buffer + , Zenacy.HTML.Internal.Char + , Zenacy.HTML.Internal.Core + , Zenacy.HTML.Internal.DOM + , Zenacy.HTML.Internal.Entity + , Zenacy.HTML.Internal.Filter + , Zenacy.HTML.Internal.HTML + , Zenacy.HTML.Internal.Image + , Zenacy.HTML.Internal.Lexer + , Zenacy.HTML.Internal.Oper + , Zenacy.HTML.Internal.Parser + , Zenacy.HTML.Internal.Query + , Zenacy.HTML.Internal.Render + , Zenacy.HTML.Internal.Token + , Zenacy.HTML.Internal.Trie + , Zenacy.HTML.Internal.Types + , Zenacy.HTML.Internal.Zip + build-depends: + base == 4.*, + bytestring >= 0.10.6.0 && < 0.11, + containers >= 0.5.7.1 && < 0.7, + data-default >= 0.7.1.1 && < 0.8, + dlist >= 0.8 && < 0.9, + extra >= 1.4 && < 1.8, + mtl >= 2.1 && < 2.3, + pretty-show >= 1.6 && < 1.11, + safe >= 0.3.14 && < 0.4, + safe-exceptions >= 0.1.5.0 && < 0.2, + text >= 1.2.2.0 && < 1.3, + transformers >= 0.5.2 && < 0.6, + vector >= 0.11 && < 0.13, + word8 >= 0.1.2 && < 0.2 + + ghc-options: + -O3 -Wall + -Wno-name-shadowing + -Wno-unused-matches + -Wno-unused-local-binds + -Wno-unused-imports + -Wno-unused-top-binds + -Wno-incomplete-patterns + default-extensions: + default-language: + Haskell2010 + +executable zenacy-html-exe + hs-source-dirs: + app + main-is: + Main.hs + other-modules: + ghc-options: + -O3 -Wall + -Wno-name-shadowing + -Wno-unused-matches + -Wno-unused-local-binds + -Wno-unused-imports + -Wno-unused-top-binds + -Wno-incomplete-patterns + -threaded -rtsopts -with-rtsopts=-N + build-depends: + base == 4.* + , bytestring + , containers + , data-default + , dlist + , extra + , pretty-show + , text + , vector + , zenacy-html + default-extensions: + default-language: + Haskell2010 + +test-suite zenacy-html-test + type: + exitcode-stdio-1.0 + hs-source-dirs: + test + main-is: + TestSuite.hs + build-depends: + base == 4.* + , bytestring + , containers + , data-default + , dlist + , extra + , HUnit + , mtl + , pretty-show + , raw-strings-qq + , test-framework + , test-framework-hunit + , text + , transformers + , zenacy-html + default-extensions: + ghc-options: + -O3 -threaded -rtsopts -with-rtsopts=-N + default-language: + Haskell2010 + other-modules: + Zenacy.HTML.Internal.Buffer.Tests + , Zenacy.HTML.Internal.Entity.Tests + , Zenacy.HTML.Internal.HTML.Tests + , Zenacy.HTML.Internal.Image.Tests + , Zenacy.HTML.Internal.Lexer.Tests + , Zenacy.HTML.Internal.Oper.Tests + , Zenacy.HTML.Internal.Parser.Tests + , Zenacy.HTML.Internal.Query.Tests + , Zenacy.HTML.Internal.Token.Tests + , Zenacy.HTML.Internal.Trie.Tests + , Zenacy.HTML.Internal.Zip.Tests + , Samples + +benchmark zenacy-html-bench + type: + exitcode-stdio-1.0 + hs-source-dirs: + bench + main-is: + BenchMain.hs + build-depends: + base == 4.* + , bytestring + , containers + , data-default + , dlist + , criterion + , pretty-show + , raw-strings-qq + , text + , zenacy-html + default-extensions: + ghc-options: + -O3 -threaded -rtsopts -with-rtsopts=-N + default-language: + Haskell2010 + other-modules: