{-# LANGUAGE OverloadedStrings #-}
module Web.Mangrove.Parse.Tree.Patch
(
Patch ( .. )
, TreeOutput ( .. )
, treeRemainder
, TokenizerOutputState
, InsertAt ( .. )
, TargetNode
, ReparentDepth
, packTree
, packTree_
, packTreeErrors
, packTreeErrors_
, consTreeError
, consTreeError_
, (++|)
, (|++)
, (|++|)
, mapTokenErrs
, mapTokenOut
, setDocumentQuirks
, restartParsing
, stopParsing
, insertCharacter
, insertComment
, insertComment'
, insertDoctype
, addAttribute
, createElement
, insertElement
, insertElement_
, insertNullElement
, insertNullElement_
, insertHeadElement
, insertHeadElement_
, insertForeignElement
, insertForeignNullElement
, insertFormattingElement
, reconstructFormattingElements
, closeCurrentNode
, closeCurrentNode_
, dropCurrentNode
, softCloseCurrentNode_
, closeAncestorNode_
, closeAncestorNodes_
, clearToContext
, tableContext
, tableBodyContext
, tableRowContext
, clearCount
, closeElement
, closeElements
, closePElement
, generateEndTags
, impliedEndTags
, thoroughlyImpliedEndTags
) where
import qualified Control.Applicative as A
import qualified Control.Monad as N
import qualified Control.Monad.Trans.State as N.S
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BS.L
import qualified Data.IntMap.Strict as M.I
import qualified Data.List as L
import qualified Data.Maybe as Y
import qualified Data.Text as T
import Data.Function ( (&) )
import Data.Functor ( ($>) )
import Web.Willow.DOM
import Web.Mangrove.Parse.Common.Error
import Web.Mangrove.Parse.Tokenize as Tokenize
import Web.Mangrove.Parse.Tokenize.Common
import Web.Mangrove.Parse.Tree.Common
import Web.Willow.Common.Encoding
data Patch
= ErrorList [ParseError]
| SetDocumentQuirks QuirksMode
| CloseNodes (M.I.IntMap ReparentDepth)
| SoftCloseCurrentNode
| DropCurrentNode
| InsertCharacter [ParseError] Char
| [ParseError] InsertAt T.Text
| InsertElement [ParseError] ElementParams
| InsertAndSetDocumentType [ParseError] DocumentTypeParams
| AddAttribute InsertAt AttributeParams
| RestartParsing
deriving ( Patch -> Patch -> Bool
(Patch -> Patch -> Bool) -> (Patch -> Patch -> Bool) -> Eq Patch
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Patch -> Patch -> Bool
$c/= :: Patch -> Patch -> Bool
== :: Patch -> Patch -> Bool
$c== :: Patch -> Patch -> Bool
Eq, Int -> Patch -> ShowS
[Patch] -> ShowS
Patch -> String
(Int -> Patch -> ShowS)
-> (Patch -> String) -> ([Patch] -> ShowS) -> Show Patch
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Patch] -> ShowS
$cshowList :: [Patch] -> ShowS
show :: Patch -> String
$cshow :: Patch -> String
showsPrec :: Int -> Patch -> ShowS
$cshowsPrec :: Int -> Patch -> ShowS
Show, ReadPrec [Patch]
ReadPrec Patch
Int -> ReadS Patch
ReadS [Patch]
(Int -> ReadS Patch)
-> ReadS [Patch]
-> ReadPrec Patch
-> ReadPrec [Patch]
-> Read Patch
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Patch]
$creadListPrec :: ReadPrec [Patch]
readPrec :: ReadPrec Patch
$creadPrec :: ReadPrec Patch
readList :: ReadS [Patch]
$creadList :: ReadS [Patch]
readsPrec :: Int -> ReadS Patch
$creadsPrec :: Int -> ReadS Patch
Read )
data InsertAt
= RelativeLocation ReparentDepth
| InDocument
| InHtmlElement
deriving ( InsertAt -> InsertAt -> Bool
(InsertAt -> InsertAt -> Bool)
-> (InsertAt -> InsertAt -> Bool) -> Eq InsertAt
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InsertAt -> InsertAt -> Bool
$c/= :: InsertAt -> InsertAt -> Bool
== :: InsertAt -> InsertAt -> Bool
$c== :: InsertAt -> InsertAt -> Bool
Eq, Int -> InsertAt -> ShowS
[InsertAt] -> ShowS
InsertAt -> String
(Int -> InsertAt -> ShowS)
-> (InsertAt -> String) -> ([InsertAt] -> ShowS) -> Show InsertAt
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InsertAt] -> ShowS
$cshowList :: [InsertAt] -> ShowS
show :: InsertAt -> String
$cshow :: InsertAt -> String
showsPrec :: Int -> InsertAt -> ShowS
$cshowsPrec :: Int -> InsertAt -> ShowS
Show, ReadPrec [InsertAt]
ReadPrec InsertAt
Int -> ReadS InsertAt
ReadS [InsertAt]
(Int -> ReadS InsertAt)
-> ReadS [InsertAt]
-> ReadPrec InsertAt
-> ReadPrec [InsertAt]
-> Read InsertAt
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [InsertAt]
$creadListPrec :: ReadPrec [InsertAt]
readPrec :: ReadPrec InsertAt
$creadPrec :: ReadPrec InsertAt
readList :: ReadS [InsertAt]
$creadList :: ReadS [InsertAt]
readsPrec :: Int -> ReadS InsertAt
$creadsPrec :: Int -> ReadS InsertAt
Read )
type TargetNode = Word
type ReparentDepth = Word
data TreeOutput = TreeOutput
{ TreeOutput -> [Patch]
treePatches :: [Patch]
, TreeOutput -> TokenizerOutputState
treeState :: TokenizerOutputState
}
deriving ( TreeOutput -> TreeOutput -> Bool
(TreeOutput -> TreeOutput -> Bool)
-> (TreeOutput -> TreeOutput -> Bool) -> Eq TreeOutput
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TreeOutput -> TreeOutput -> Bool
$c/= :: TreeOutput -> TreeOutput -> Bool
== :: TreeOutput -> TreeOutput -> Bool
$c== :: TreeOutput -> TreeOutput -> Bool
Eq, Int -> TreeOutput -> ShowS
[TreeOutput] -> ShowS
TreeOutput -> String
(Int -> TreeOutput -> ShowS)
-> (TreeOutput -> String)
-> ([TreeOutput] -> ShowS)
-> Show TreeOutput
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TreeOutput] -> ShowS
$cshowList :: [TreeOutput] -> ShowS
show :: TreeOutput -> String
$cshow :: TreeOutput -> String
showsPrec :: Int -> TreeOutput -> ShowS
$cshowsPrec :: Int -> TreeOutput -> ShowS
Show, ReadPrec [TreeOutput]
ReadPrec TreeOutput
Int -> ReadS TreeOutput
ReadS [TreeOutput]
(Int -> ReadS TreeOutput)
-> ReadS [TreeOutput]
-> ReadPrec TreeOutput
-> ReadPrec [TreeOutput]
-> Read TreeOutput
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [TreeOutput]
$creadListPrec :: ReadPrec [TreeOutput]
readPrec :: ReadPrec TreeOutput
$creadPrec :: ReadPrec TreeOutput
readList :: ReadS [TreeOutput]
$creadList :: ReadS [TreeOutput]
readsPrec :: Int -> ReadS TreeOutput
$creadsPrec :: Int -> ReadS TreeOutput
Read )
treeRemainder :: TreeOutput -> Maybe BS.ByteString
treeRemainder :: TreeOutput -> Maybe ByteString
treeRemainder = ((TokenizerState, ByteString) -> ByteString)
-> TokenizerOutputState -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TokenizerState, ByteString) -> ByteString
forall a b. (a, b) -> b
snd (TokenizerOutputState -> Maybe ByteString)
-> (TreeOutput -> TokenizerOutputState)
-> TreeOutput
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TreeOutput -> TokenizerOutputState
treeState
packTree :: TreeInput -> [Patch] -> TreeBuilder TreeOutput
packTree :: TreeInput -> [Patch] -> TreeBuilder TreeOutput
packTree TreeInput
t' [Patch]
ps = TreeOutput -> TreeBuilder TreeOutput
forall (m :: * -> *) a. Monad m => a -> m a
return (TreeOutput -> TreeBuilder TreeOutput)
-> TreeOutput -> TreeBuilder TreeOutput
forall a b. (a -> b) -> a -> b
$ TreeOutput :: [Patch] -> TokenizerOutputState -> TreeOutput
TreeOutput
{ treePatches :: [Patch]
treePatches = [Patch]
ps
, treeState :: TokenizerOutputState
treeState = TreeInput -> TokenizerOutputState
tokenState TreeInput
t'
}
packTree_ :: [Patch] -> TreeBuilder TreeOutput
packTree_ :: [Patch] -> TreeBuilder TreeOutput
packTree_ [Patch]
ps = TreeOutput -> TreeBuilder TreeOutput
forall (m :: * -> *) a. Monad m => a -> m a
return (TreeOutput -> TreeBuilder TreeOutput)
-> TreeOutput -> TreeBuilder TreeOutput
forall a b. (a -> b) -> a -> b
$ TreeOutput :: [Patch] -> TokenizerOutputState -> TreeOutput
TreeOutput
{ treePatches :: [Patch]
treePatches = [Patch]
ps
, treeState :: TokenizerOutputState
treeState = TokenizerOutputState
forall a. Maybe a
Nothing
}
mapTokenErrs :: ([ParseError] -> [ParseError]) -> TreeInput -> TreeInput
mapTokenErrs :: ([ParseError] -> [ParseError]) -> TreeInput -> TreeInput
mapTokenErrs [ParseError] -> [ParseError]
f TreeInput
t' = TreeInput
t'
{ tokenErrs :: [ParseError]
tokenErrs = [ParseError] -> [ParseError]
f ([ParseError] -> [ParseError]) -> [ParseError] -> [ParseError]
forall a b. (a -> b) -> a -> b
$ TreeInput -> [ParseError]
tokenErrs TreeInput
t'
}
mapTokenOut :: (Token -> Token) -> TreeInput -> TreeInput
mapTokenOut :: (Token -> Token) -> TreeInput -> TreeInput
mapTokenOut Token -> Token
f TreeInput
t' = TreeInput
t'
{ tokenOut :: Token
tokenOut = Token -> Token
f (Token -> Token) -> Token -> Token
forall a b. (a -> b) -> a -> b
$ TreeInput -> Token
tokenOut TreeInput
t'
}
packTreeErrors :: [ParseError] -> TreeInput -> TreeBuilder TreeOutput
packTreeErrors :: [ParseError] -> TreeInput -> TreeBuilder TreeOutput
packTreeErrors [ParseError]
errs TreeInput
t' = do
TreeOutput
ps <- [ParseError] -> TreeBuilder TreeOutput
packTreeErrors_ ([ParseError] -> TreeBuilder TreeOutput)
-> [ParseError] -> TreeBuilder TreeOutput
forall a b. (a -> b) -> a -> b
$ [ParseError]
errs [ParseError] -> [ParseError] -> [ParseError]
forall a. [a] -> [a] -> [a]
++ TreeInput -> [ParseError]
tokenErrs TreeInput
t'
TreeOutput -> TreeBuilder TreeOutput
forall (m :: * -> *) a. Monad m => a -> m a
return (TreeOutput -> TreeBuilder TreeOutput)
-> TreeOutput -> TreeBuilder TreeOutput
forall a b. (a -> b) -> a -> b
$ TreeOutput
ps
{ treeState :: TokenizerOutputState
treeState = TreeInput -> TokenizerOutputState
tokenState TreeInput
t'
}
packTreeErrors_ :: [ParseError] -> TreeBuilder TreeOutput
packTreeErrors_ :: [ParseError] -> TreeBuilder TreeOutput
packTreeErrors_ [] = [Patch] -> TreeBuilder TreeOutput
packTree_ []
packTreeErrors_ [ParseError]
errs = [Patch] -> TreeBuilder TreeOutput
packTree_ [[ParseError] -> Patch
ErrorList [ParseError]
errs]
consTreeError_ :: ParseError -> [Patch] -> [Patch]
consTreeError_ :: ParseError -> [Patch] -> [Patch]
consTreeError_ ParseError
err (ErrorList [ParseError]
errs:[Patch]
ps) =
[ParseError] -> Patch
ErrorList (ParseError
err ParseError -> [ParseError] -> [ParseError]
forall a. a -> [a] -> [a]
: [ParseError]
errs) Patch -> [Patch] -> [Patch]
forall a. a -> [a] -> [a]
: [Patch]
ps
consTreeError_ ParseError
err (InsertCharacter [ParseError]
errs Char
c:[Patch]
ps) =
[ParseError] -> Char -> Patch
InsertCharacter (ParseError
err ParseError -> [ParseError] -> [ParseError]
forall a. a -> [a] -> [a]
: [ParseError]
errs) Char
c Patch -> [Patch] -> [Patch]
forall a. a -> [a] -> [a]
: [Patch]
ps
consTreeError_ ParseError
err (InsertComment [ParseError]
errs InsertAt
loc Text
d:[Patch]
ps) =
[ParseError] -> InsertAt -> Text -> Patch
InsertComment (ParseError
err ParseError -> [ParseError] -> [ParseError]
forall a. a -> [a] -> [a]
: [ParseError]
errs) InsertAt
loc Text
d Patch -> [Patch] -> [Patch]
forall a. a -> [a] -> [a]
: [Patch]
ps
consTreeError_ ParseError
err (InsertElement [ParseError]
errs ElementParams
d:[Patch]
ps) =
[ParseError] -> ElementParams -> Patch
InsertElement (ParseError
err ParseError -> [ParseError] -> [ParseError]
forall a. a -> [a] -> [a]
: [ParseError]
errs) ElementParams
d Patch -> [Patch] -> [Patch]
forall a. a -> [a] -> [a]
: [Patch]
ps
consTreeError_ ParseError
err (InsertAndSetDocumentType [ParseError]
errs DocumentTypeParams
d:[Patch]
ps) =
[ParseError] -> DocumentTypeParams -> Patch
InsertAndSetDocumentType (ParseError
err ParseError -> [ParseError] -> [ParseError]
forall a. a -> [a] -> [a]
: [ParseError]
errs) DocumentTypeParams
d Patch -> [Patch] -> [Patch]
forall a. a -> [a] -> [a]
: [Patch]
ps
consTreeError_ ParseError
err [Patch]
ps = [ParseError] -> Patch
ErrorList [ParseError
err] Patch -> [Patch] -> [Patch]
forall a. a -> [a] -> [a]
: [Patch]
ps
consTreeError :: ParseError -> TreeOutput -> TreeOutput
consTreeError :: ParseError -> TreeOutput -> TreeOutput
consTreeError ParseError
err TreeOutput
out = TreeOutput
out { treePatches :: [Patch]
treePatches = ParseError -> [Patch] -> [Patch]
consTreeError_ ParseError
err ([Patch] -> [Patch]) -> [Patch] -> [Patch]
forall a b. (a -> b) -> a -> b
$ TreeOutput -> [Patch]
treePatches TreeOutput
out }
(++|) :: [Patch] -> TreeOutput -> TreeOutput
[Patch]
ps ++| :: [Patch] -> TreeOutput -> TreeOutput
++| TreeOutput
out = TreeOutput
out { treePatches :: [Patch]
treePatches = [Patch]
ps [Patch] -> [Patch] -> [Patch]
forall a. [a] -> [a] -> [a]
++ TreeOutput -> [Patch]
treePatches TreeOutput
out }
infixr 4 ++|
(|++) :: TreeOutput -> [Patch] -> TreeOutput
TreeOutput
out |++ :: TreeOutput -> [Patch] -> TreeOutput
|++ [Patch]
ps = TreeOutput
out { treePatches :: [Patch]
treePatches = TreeOutput -> [Patch]
treePatches TreeOutput
out [Patch] -> [Patch] -> [Patch]
forall a. [a] -> [a] -> [a]
++ [Patch]
ps }
infixr 4 |++
(|++|) :: TreeOutput -> TreeOutput -> TreeOutput
TreeOutput
ps |++| :: TreeOutput -> TreeOutput -> TreeOutput
|++| TreeOutput
ps' = TreeOutput
ps' { treePatches :: [Patch]
treePatches = TreeOutput -> [Patch]
treePatches TreeOutput
ps [Patch] -> [Patch] -> [Patch]
forall a. [a] -> [a] -> [a]
++ TreeOutput -> [Patch]
treePatches TreeOutput
ps' }
infixr 4 |++|
setDocumentQuirks :: QuirksMode -> TreeBuilder [Patch]
setDocumentQuirks :: QuirksMode -> TreeBuilder [Patch]
setDocumentQuirks QuirksMode
quirks = do
(TreeParserState -> TreeParserState)
-> StateT TreeParserState (Parser [TreeInput]) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
N.S.modify ((TreeParserState -> TreeParserState)
-> StateT TreeParserState (Parser [TreeInput]) ())
-> (TreeParserState -> TreeParserState)
-> StateT TreeParserState (Parser [TreeInput]) ()
forall a b. (a -> b) -> a -> b
$ \TreeParserState
state -> TreeParserState
state
{ quirksMode :: QuirksMode
quirksMode = QuirksMode
quirks
}
[Patch] -> TreeBuilder [Patch]
forall (m :: * -> *) a. Monad m => a -> m a
return [QuirksMode -> Patch
SetDocumentQuirks QuirksMode
quirks]
clear :: ([ElementParams] -> Word) -> TreeBuilder [Patch]
clear :: ([ElementParams] -> Word) -> TreeBuilder [Patch]
clear [ElementParams] -> Word
f = do
TreeParserState
state <- StateT TreeParserState (Parser [TreeInput]) TreeParserState
forall (m :: * -> *) s. Monad m => StateT s m s
N.S.get
Word -> TreeBuilder [Patch]
clearCount (Word -> TreeBuilder [Patch])
-> ([(NodeIndex, ElementParams)] -> Word)
-> [(NodeIndex, ElementParams)]
-> TreeBuilder [Patch]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ElementParams] -> Word
f ([ElementParams] -> Word)
-> ([(NodeIndex, ElementParams)] -> [ElementParams])
-> [(NodeIndex, ElementParams)]
-> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((NodeIndex, ElementParams) -> ElementParams)
-> [(NodeIndex, ElementParams)] -> [ElementParams]
forall a b. (a -> b) -> [a] -> [b]
map (NodeIndex, ElementParams) -> ElementParams
forall a b. (a, b) -> b
snd ([(NodeIndex, ElementParams)] -> TreeBuilder [Patch])
-> [(NodeIndex, ElementParams)] -> TreeBuilder [Patch]
forall a b. (a -> b) -> a -> b
$ TreeParserState -> [(NodeIndex, ElementParams)]
openElements TreeParserState
state
clearCount :: Word -> TreeBuilder [Patch]
clearCount :: Word -> TreeBuilder [Patch]
clearCount Word
0 = [Patch] -> TreeBuilder [Patch]
forall (m :: * -> *) a. Monad m => a -> m a
return []
clearCount Word
l = Word -> Word -> TreeBuilder [Patch]
closeAncestorNodes_ Word
0 Word
l
clearToContext :: [ElementName] -> TreeBuilder [Patch]
clearToContext :: [Text] -> TreeBuilder [Patch]
clearToContext [Text]
ns = ([ElementParams] -> Word) -> TreeBuilder [Patch]
clear [ElementParams] -> Word
forall p. (Num p, Enum p) => [ElementParams] -> p
countToContext
where countToContext :: [ElementParams] -> p
countToContext [] = p
0
countToContext (ElementParams
d:[ElementParams]
ds) = if Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (ElementParams -> Text
elementName ElementParams
d) [Text]
ns Bool -> Bool -> Bool
&& ElementParams -> Maybe Text
elementNamespace ElementParams
d Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
htmlNamespace
then p
0
else p -> p
forall a. Enum a => a -> a
succ (p -> p) -> p -> p
forall a b. (a -> b) -> a -> b
$ [ElementParams] -> p
countToContext [ElementParams]
ds
tableContext :: [ElementName]
tableContext :: [Text]
tableContext =
[ Text
"table"
, Text
"template"
, Text
"html"
]
tableBodyContext :: [ElementName]
tableBodyContext :: [Text]
tableBodyContext =
[ Text
"tbody"
, Text
"tfoot"
, Text
"thead"
, Text
"template"
, Text
"html"
]
tableRowContext :: [ElementName]
tableRowContext :: [Text]
tableRowContext =
[ Text
"tr"
, Text
"template"
, Text
"html"
]
closeElement :: ElementName -> TreeBuilder [Patch]
closeElement :: Text -> TreeBuilder [Patch]
closeElement = [Text] -> TreeBuilder [Patch]
closeElements ([Text] -> TreeBuilder [Patch])
-> (Text -> [Text]) -> Text -> TreeBuilder [Patch]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [])
closeElements :: [ElementName] -> TreeBuilder [Patch]
closeElements :: [Text] -> TreeBuilder [Patch]
closeElements [Text]
names = ([ElementParams] -> Word) -> TreeBuilder [Patch]
clear [ElementParams] -> Word
forall p. (Num p, Enum p) => [ElementParams] -> p
countToElement
where countToElement :: [ElementParams] -> p
countToElement [] = p
0
countToElement (ElementParams
d:[ElementParams]
ds) = if Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (ElementParams -> Text
elementName ElementParams
d) [Text]
names Bool -> Bool -> Bool
&& ElementParams -> Maybe Text
elementNamespace ElementParams
d Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
htmlNamespace
then p
1
else p -> p
forall a. Enum a => a -> a
succ (p -> p) -> p -> p
forall a b. (a -> b) -> a -> b
$ [ElementParams] -> p
countToElement [ElementParams]
ds
closeCurrentNode :: TreeInput -> TreeBuilder TreeOutput
closeCurrentNode :: TreeInput -> TreeBuilder TreeOutput
closeCurrentNode TreeInput
t' = do
[Patch]
close <- TreeBuilder [Patch]
closeCurrentNode_
TreeParserState
state <- StateT TreeParserState (Parser [TreeInput]) TreeParserState
forall (m :: * -> *) s. Monad m => StateT s m s
N.S.get
TreeOutput -> TreeBuilder TreeOutput
forall (m :: * -> *) a. Monad m => a -> m a
return (TreeOutput -> TreeBuilder TreeOutput)
-> TreeOutput -> TreeBuilder TreeOutput
forall a b. (a -> b) -> a -> b
$ TreeOutput :: [Patch] -> TokenizerOutputState -> TreeOutput
TreeOutput
{ treePatches :: [Patch]
treePatches = (ParseError -> [Patch] -> [Patch])
-> [Patch] -> [ParseError] -> [Patch]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ParseError -> [Patch] -> [Patch]
consTreeError_ [Patch]
close ([ParseError] -> [Patch]) -> [ParseError] -> [Patch]
forall a b. (a -> b) -> a -> b
$ TreeInput -> [ParseError]
tokenErrs TreeInput
t'
, treeState :: TokenizerOutputState
treeState = TreeInput -> TokenizerOutputState
tokenState (TreeInput -> TokenizerOutputState)
-> ((TokenParserState -> TokenParserState) -> TreeInput)
-> (TokenParserState -> TokenParserState)
-> TokenizerOutputState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TreeInput -> (TokenParserState -> TokenParserState) -> TreeInput
mapTokenState TreeInput
t' ((TokenParserState -> TokenParserState) -> TokenizerOutputState)
-> (TokenParserState -> TokenParserState) -> TokenizerOutputState
forall a b. (a -> b) -> a -> b
$ TreeParserState -> TokenParserState -> TokenParserState
resetNamespace TreeParserState
state
}
where resetNamespace :: TreeParserState -> TokenParserState -> TokenParserState
resetNamespace TreeParserState
state TokenParserState
tokState = TokenParserState
tokState
{ currentNodeNamespace :: Maybe Text
currentNodeNamespace = [(NodeIndex, ElementParams)] -> Maybe (NodeIndex, ElementParams)
forall a. [a] -> Maybe a
Y.listToMaybe (TreeParserState -> [(NodeIndex, ElementParams)]
openElements TreeParserState
state) Maybe (NodeIndex, ElementParams)
-> ((NodeIndex, ElementParams) -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ElementParams -> Maybe Text
elementNamespace (ElementParams -> Maybe Text)
-> ((NodeIndex, ElementParams) -> ElementParams)
-> (NodeIndex, ElementParams)
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NodeIndex, ElementParams) -> ElementParams
forall a b. (a, b) -> b
snd
}
closeCurrentNode_ :: TreeBuilder [Patch]
closeCurrentNode_ :: TreeBuilder [Patch]
closeCurrentNode_ = Word -> TreeBuilder [Patch]
closeAncestorNode_ Word
0
dropCurrentNode :: TreeBuilder [Patch]
dropCurrentNode :: TreeBuilder [Patch]
dropCurrentNode = TreeBuilder [Patch]
closeCurrentNode_ TreeBuilder [Patch] -> [Patch] -> TreeBuilder [Patch]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [Patch
DropCurrentNode]
softCloseCurrentNode_ :: [Patch]
softCloseCurrentNode_ :: [Patch]
softCloseCurrentNode_ = [Patch
SoftCloseCurrentNode]
closeAncestorNode_ :: TargetNode -> TreeBuilder [Patch]
closeAncestorNode_ :: Word -> TreeBuilder [Patch]
closeAncestorNode_ = (Word -> Word -> TreeBuilder [Patch])
-> Word -> Word -> TreeBuilder [Patch]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Word -> Word -> TreeBuilder [Patch]
closeAncestorNodes_ Word
1
closeAncestorNodes_ :: TargetNode -> ReparentDepth -> TreeBuilder [Patch]
closeAncestorNodes_ :: Word -> Word -> TreeBuilder [Patch]
closeAncestorNodes_ Word
l Word
d = do
TreeParserState
state <- StateT TreeParserState (Parser [TreeInput]) TreeParserState
forall (m :: * -> *) s. Monad m => StateT s m s
N.S.get
let ([(NodeIndex, ElementParams)]
es1, [(NodeIndex, ElementParams)]
es2) = Int
-> [(NodeIndex, ElementParams)]
-> ([(NodeIndex, ElementParams)], [(NodeIndex, ElementParams)])
forall a. Int -> [a] -> ([a], [a])
splitAt (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
l) ([(NodeIndex, ElementParams)]
-> ([(NodeIndex, ElementParams)], [(NodeIndex, ElementParams)]))
-> [(NodeIndex, ElementParams)]
-> ([(NodeIndex, ElementParams)], [(NodeIndex, ElementParams)])
forall a b. (a -> b) -> a -> b
$ TreeParserState -> [(NodeIndex, ElementParams)]
openElements TreeParserState
state
d' :: Int
d' = Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
d
TreeParserState -> StateT TreeParserState (Parser [TreeInput]) ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
N.S.put (TreeParserState -> StateT TreeParserState (Parser [TreeInput]) ())
-> TreeParserState
-> StateT TreeParserState (Parser [TreeInput]) ()
forall a b. (a -> b) -> a -> b
$ TreeParserState
state
{ openElements :: [(NodeIndex, ElementParams)]
openElements = [(NodeIndex, ElementParams)]
es1 [(NodeIndex, ElementParams)]
-> [(NodeIndex, ElementParams)] -> [(NodeIndex, ElementParams)]
forall a. [a] -> [a] -> [a]
++ Int -> [(NodeIndex, ElementParams)] -> [(NodeIndex, ElementParams)]
forall a. Int -> [a] -> [a]
drop Int
d' [(NodeIndex, ElementParams)]
es2
}
[Patch] -> TreeBuilder [Patch]
forall (m :: * -> *) a. Monad m => a -> m a
return [IntMap Word -> Patch
CloseNodes (IntMap Word -> Patch) -> (Int -> IntMap Word) -> Int -> Patch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word -> IntMap Word
forall a. Int -> a -> IntMap a
M.I.singleton (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
l) (Word -> IntMap Word) -> (Int -> Word) -> Int -> IntMap Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> (Int -> Int) -> Int -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
d' (Int -> Patch) -> Int -> Patch
forall a b. (a -> b) -> a -> b
$ [(NodeIndex, ElementParams)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(NodeIndex, ElementParams)]
es2]
closePElement :: TreeBuilder [Patch]
closePElement :: TreeBuilder [Patch]
closePElement = do
[Patch]
generate <- [Text] -> TreeBuilder [Patch]
generateEndTags ([Text] -> TreeBuilder [Patch]) -> [Text] -> TreeBuilder [Patch]
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> [Text]
forall a. Eq a => a -> [a] -> [a]
L.delete Text
"p" [Text]
impliedEndTags
Maybe ElementParams
current <- TreeBuilder (Maybe ElementParams)
currentNode
let errF :: [Patch] -> [Patch]
errF = if Bool -> (ElementParams -> Bool) -> Maybe ElementParams -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Text -> ElementParams -> Bool
nodeIsElement Text
"p") Maybe ElementParams
current
then [Patch] -> [Patch]
forall a. a -> a
id
else ParseError -> [Patch] -> [Patch]
consTreeError_ ParseError
UnexpectedElementWithImpliedEndTag
[Patch]
p <- Text -> TreeBuilder [Patch]
closeElement Text
"p"
[Patch] -> TreeBuilder [Patch]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Patch] -> TreeBuilder [Patch]) -> [Patch] -> TreeBuilder [Patch]
forall a b. (a -> b) -> a -> b
$ [Patch]
generate [Patch] -> [Patch] -> [Patch]
forall a. [a] -> [a] -> [a]
++ [Patch] -> [Patch]
errF [Patch]
p
generateEndTags :: [ElementName] -> TreeBuilder [Patch]
generateEndTags :: [Text] -> TreeBuilder [Patch]
generateEndTags [Text]
tags = ([ElementParams] -> Word) -> TreeBuilder [Patch]
clear [ElementParams] -> Word
forall p. (Num p, Enum p) => [ElementParams] -> p
countImpliable
where countImpliable :: [ElementParams] -> p
countImpliable [] = p
0
countImpliable (ElementParams
d:[ElementParams]
ds) = if Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (ElementParams -> Text
elementName ElementParams
d) [Text]
tags
then p -> p
forall a. Enum a => a -> a
succ (p -> p) -> p -> p
forall a b. (a -> b) -> a -> b
$ [ElementParams] -> p
countImpliable [ElementParams]
ds
else p
0
impliedEndTags :: [ElementName]
impliedEndTags :: [Text]
impliedEndTags =
[ Text
"dd"
, Text
"dt"
, Text
"li"
, Text
"optgroup"
, Text
"option"
, Text
"p"
, Text
"rb"
, Text
"rp"
, Text
"rt"
, Text
"rtc"
]
thoroughlyImpliedEndTags :: [ElementName]
thoroughlyImpliedEndTags :: [Text]
thoroughlyImpliedEndTags =
[ Text
"caption"
, Text
"colgroup"
, Text
"tbody"
, Text
"td"
, Text
"tfoot"
, Text
"th"
, Text
"thead"
, Text
"tr"
] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
impliedEndTags
createElement :: ElementParams -> TreeBuilder (NodeIndex, ElementParams)
createElement :: ElementParams -> TreeBuilder (NodeIndex, ElementParams)
createElement ElementParams
d = do
TreeParserState
state <- StateT TreeParserState (Parser [TreeInput]) TreeParserState
forall (m :: * -> *) s. Monad m => StateT s m s
N.S.get
let index :: NodeIndex
index = TreeParserState -> NodeIndex
elementIndex TreeParserState
state
TreeParserState -> StateT TreeParserState (Parser [TreeInput]) ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
N.S.put (TreeParserState -> StateT TreeParserState (Parser [TreeInput]) ())
-> TreeParserState
-> StateT TreeParserState (Parser [TreeInput]) ()
forall a b. (a -> b) -> a -> b
$ TreeParserState
state
{ elementIndex :: NodeIndex
elementIndex = NodeIndex -> NodeIndex
forall a. Enum a => a -> a
succ NodeIndex
index
}
(NodeIndex, ElementParams)
-> TreeBuilder (NodeIndex, ElementParams)
forall (m :: * -> *) a. Monad m => a -> m a
return (NodeIndex
index, ElementParams
d)
insertCharacter :: TreeInput -> TreeBuilder TreeOutput
insertCharacter :: TreeInput -> TreeBuilder TreeOutput
insertCharacter TreeInput
t' = case TreeInput -> Token
tokenOut TreeInput
t' of
Character Char
c -> TreeOutput -> TreeBuilder TreeOutput
forall (m :: * -> *) a. Monad m => a -> m a
return (TreeOutput -> TreeBuilder TreeOutput)
-> TreeOutput -> TreeBuilder TreeOutput
forall a b. (a -> b) -> a -> b
$ TreeOutput :: [Patch] -> TokenizerOutputState -> TreeOutput
TreeOutput
{ treePatches :: [Patch]
treePatches = [[ParseError] -> Char -> Patch
InsertCharacter (TreeInput -> [ParseError]
tokenErrs TreeInput
t') Char
c]
, treeState :: TokenizerOutputState
treeState = TreeInput -> TokenizerOutputState
tokenState TreeInput
t'
}
Token
_ -> TreeBuilder TreeOutput
forall (f :: * -> *) a. Alternative f => f a
A.empty
insertComment :: TreeInput -> TreeBuilder TreeOutput
= InsertAt -> TreeInput -> TreeBuilder TreeOutput
insertComment' (InsertAt -> TreeInput -> TreeBuilder TreeOutput)
-> InsertAt -> TreeInput -> TreeBuilder TreeOutput
forall a b. (a -> b) -> a -> b
$ Word -> InsertAt
RelativeLocation Word
0
insertComment' :: InsertAt -> TreeInput -> TreeBuilder TreeOutput
InsertAt
at TreeInput
t' = case TreeInput -> Token
tokenOut TreeInput
t' of
Tokenize.Comment Text
c -> TreeOutput -> TreeBuilder TreeOutput
forall (m :: * -> *) a. Monad m => a -> m a
return (TreeOutput -> TreeBuilder TreeOutput)
-> TreeOutput -> TreeBuilder TreeOutput
forall a b. (a -> b) -> a -> b
$ TreeOutput :: [Patch] -> TokenizerOutputState -> TreeOutput
TreeOutput
{ treePatches :: [Patch]
treePatches = [[ParseError] -> InsertAt -> Text -> Patch
InsertComment (TreeInput -> [ParseError]
tokenErrs TreeInput
t') InsertAt
at Text
c]
, treeState :: TokenizerOutputState
treeState = TreeInput -> TokenizerOutputState
tokenState TreeInput
t'
}
Token
_ -> TreeBuilder TreeOutput
forall (f :: * -> *) a. Alternative f => f a
A.empty
insertDoctype :: TreeInput -> TreeBuilder TreeOutput
insertDoctype :: TreeInput -> TreeBuilder TreeOutput
insertDoctype TreeInput
t' = case TreeInput -> Token
tokenOut TreeInput
t' of
Doctype DoctypeParams
d ->
let system :: Maybe Text
system = DoctypeParams -> Maybe Text
doctypeSystemId DoctypeParams
d
legacy :: Bool
legacy
| DoctypeParams -> Maybe Text
doctypeName DoctypeParams
d Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"html" = Bool
True
| Maybe Text -> Bool
forall a. Maybe a -> Bool
Y.isJust (Maybe Text -> Bool) -> Maybe Text -> Bool
forall a b. (a -> b) -> a -> b
$ DoctypeParams -> Maybe Text
doctypePublicId DoctypeParams
d = Bool
True
| Maybe Text -> Bool
forall a. Maybe a -> Bool
Y.isJust Maybe Text
system Bool -> Bool -> Bool
&& Maybe Text
system Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"about:legacy-compat" = Bool
True
| Bool
otherwise = Bool
False
errs' :: [ParseError]
errs'
| Bool
legacy = ParseError
LegacyDoctype ParseError -> [ParseError] -> [ParseError]
forall a. a -> [a] -> [a]
: TreeInput -> [ParseError]
tokenErrs TreeInput
t'
| Bool
otherwise = TreeInput -> [ParseError]
tokenErrs TreeInput
t'
in TreeInput -> [Patch] -> TreeBuilder TreeOutput
packTree TreeInput
t' [[ParseError] -> DocumentTypeParams -> Patch
InsertAndSetDocumentType [ParseError]
errs' (DocumentTypeParams -> Patch) -> DocumentTypeParams -> Patch
forall a b. (a -> b) -> a -> b
$ TreeInput -> DocumentTypeParams
tokenDocumentType TreeInput
t']
Token
_ -> TreeBuilder TreeOutput
forall (f :: * -> *) a. Alternative f => f a
A.empty
insertElement :: TreeInput -> TreeBuilder TreeOutput
insertElement :: TreeInput -> TreeBuilder TreeOutput
insertElement = Text -> TreeInput -> TreeBuilder TreeOutput
insertForeignElement Text
htmlNamespace
insertElement_ :: TagParams -> TreeBuilder [Patch]
insertElement_ :: TagParams -> TreeBuilder [Patch]
insertElement_ TagParams
d = TreeOutput -> [Patch]
treePatches (TreeOutput -> [Patch])
-> TreeBuilder TreeOutput -> TreeBuilder [Patch]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TreeInput -> TreeBuilder TreeOutput
insertElement ([ParseError] -> Token -> TreeInput
dummyToken [] (Token -> TreeInput) -> Token -> TreeInput
forall a b. (a -> b) -> a -> b
$ TagParams -> Token
StartTag TagParams
d)
insertForeignElement :: Namespace -> TreeInput -> TreeBuilder TreeOutput
insertForeignElement :: Text -> TreeInput -> TreeBuilder TreeOutput
insertForeignElement Text
ns TreeInput
t' = case TreeInput -> Token
tokenOut TreeInput
t' of
StartTag TagParams
d -> do
let d' :: ElementParams
d' = Maybe Text -> TagParams -> ElementParams
packNodeData (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
ns) TagParams
d
errs' :: [ParseError]
errs'
| TagParams -> Bool
tagIsSelfClosing TagParams
d = ParseError
NonVoidHtmlElementStartTagWithTrailingSolidus ParseError -> [ParseError] -> [ParseError]
forall a. a -> [a] -> [a]
: TreeInput -> [ParseError]
tokenErrs TreeInput
t'
| Bool
otherwise = TreeInput -> [ParseError]
tokenErrs TreeInput
t'
(NodeIndex, ElementParams)
e <- ElementParams -> TreeBuilder (NodeIndex, ElementParams)
createElement ElementParams
d'
(TreeParserState -> TreeParserState)
-> StateT TreeParserState (Parser [TreeInput]) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
N.S.modify ((TreeParserState -> TreeParserState)
-> StateT TreeParserState (Parser [TreeInput]) ())
-> (TreeParserState -> TreeParserState)
-> StateT TreeParserState (Parser [TreeInput]) ()
forall a b. (a -> b) -> a -> b
$ \TreeParserState
state -> TreeParserState
state
{ openElements :: [(NodeIndex, ElementParams)]
openElements = (NodeIndex, ElementParams)
e (NodeIndex, ElementParams)
-> [(NodeIndex, ElementParams)] -> [(NodeIndex, ElementParams)]
forall a. a -> [a] -> [a]
: TreeParserState -> [(NodeIndex, ElementParams)]
openElements TreeParserState
state
}
TreeOutput -> TreeBuilder TreeOutput
forall (m :: * -> *) a. Monad m => a -> m a
return (TreeOutput -> TreeBuilder TreeOutput)
-> TreeOutput -> TreeBuilder TreeOutput
forall a b. (a -> b) -> a -> b
$ TreeOutput :: [Patch] -> TokenizerOutputState -> TreeOutput
TreeOutput
{ treePatches :: [Patch]
treePatches = [[ParseError] -> ElementParams -> Patch
InsertElement [ParseError]
errs' (ElementParams -> Patch) -> ElementParams -> Patch
forall a b. (a -> b) -> a -> b
$ ElementParams -> ElementParams
adjustAttributes ElementParams
d']
, treeState :: TokenizerOutputState
treeState = TreeInput -> TokenizerOutputState
tokenState (TreeInput -> TokenizerOutputState)
-> TreeInput -> TokenizerOutputState
forall a b. (a -> b) -> a -> b
$ TreeInput -> (TokenParserState -> TokenParserState) -> TreeInput
mapTokenState TreeInput
t' TokenParserState -> TokenParserState
setNamespace
}
Token
_ -> TreeBuilder TreeOutput
forall (f :: * -> *) a. Alternative f => f a
A.empty
where adjustAttributes :: ElementParams -> ElementParams
adjustAttributes
| Text
ns Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
htmlNamespace = ElementParams -> ElementParams
forall a. a -> a
id
| Bool
otherwise = ElementParams -> ElementParams
adjustForeignAttributes
setNamespace :: TokenParserState -> TokenParserState
setNamespace TokenParserState
state = TokenParserState
state
{ currentNodeNamespace :: Maybe Text
currentNodeNamespace = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
ns
}
insertNullElement :: TreeInput -> TreeBuilder TreeOutput
insertNullElement :: TreeInput -> TreeBuilder TreeOutput
insertNullElement = Text -> TreeInput -> TreeBuilder TreeOutput
insertForeignNullElement Text
htmlNamespace
insertNullElement_ :: TagParams -> TreeBuilder [Patch]
insertNullElement_ :: TagParams -> TreeBuilder [Patch]
insertNullElement_ TagParams
d = TreeOutput -> [Patch]
treePatches (TreeOutput -> [Patch])
-> TreeBuilder TreeOutput -> TreeBuilder [Patch]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TreeInput -> TreeBuilder TreeOutput
insertNullElement ([ParseError] -> Token -> TreeInput
dummyToken [] (Token -> TreeInput) -> Token -> TreeInput
forall a b. (a -> b) -> a -> b
$ TagParams -> Token
StartTag TagParams
d)
insertForeignNullElement :: Namespace -> TreeInput -> TreeBuilder TreeOutput
insertForeignNullElement :: Text -> TreeInput -> TreeBuilder TreeOutput
insertForeignNullElement Text
ns TreeInput
t' = case TreeInput -> Token
tokenOut TreeInput
t' of
StartTag TagParams
d -> TreeOutput -> TreeBuilder TreeOutput
forall (m :: * -> *) a. Monad m => a -> m a
return (TreeOutput -> TreeBuilder TreeOutput)
-> TreeOutput -> TreeBuilder TreeOutput
forall a b. (a -> b) -> a -> b
$ TreeOutput :: [Patch] -> TokenizerOutputState -> TreeOutput
TreeOutput
{ treePatches :: [Patch]
treePatches =
[ [ParseError] -> ElementParams -> Patch
InsertElement (TreeInput -> [ParseError]
tokenErrs TreeInput
t') (ElementParams -> Patch)
-> (ElementParams -> ElementParams) -> ElementParams -> Patch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ElementParams -> ElementParams
adjustAttributes (ElementParams -> Patch) -> ElementParams -> Patch
forall a b. (a -> b) -> a -> b
$ Maybe Text -> TagParams -> ElementParams
packNodeData (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
ns) TagParams
d
, IntMap Word -> Patch
CloseNodes (IntMap Word -> Patch) -> IntMap Word -> Patch
forall a b. (a -> b) -> a -> b
$ Int -> Word -> IntMap Word
forall a. Int -> a -> IntMap a
M.I.singleton Int
0 Word
1
]
, treeState :: TokenizerOutputState
treeState = TreeInput -> TokenizerOutputState
tokenState TreeInput
t'
}
Token
_ -> TreeBuilder TreeOutput
forall (f :: * -> *) a. Alternative f => f a
A.empty
where adjustAttributes :: ElementParams -> ElementParams
adjustAttributes
| Text
ns Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
htmlNamespace = ElementParams -> ElementParams
forall a. a -> a
id
| Bool
otherwise = ElementParams -> ElementParams
adjustForeignAttributes
insertHeadElement :: TreeInput -> TreeBuilder TreeOutput
insertHeadElement :: TreeInput -> TreeBuilder TreeOutput
insertHeadElement TreeInput
t' = do
(TreeParserState -> TreeParserState)
-> StateT TreeParserState (Parser [TreeInput]) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
N.S.modify ((TreeParserState -> TreeParserState)
-> StateT TreeParserState (Parser [TreeInput]) ())
-> (TreeParserState -> TreeParserState)
-> StateT TreeParserState (Parser [TreeInput]) ()
forall a b. (a -> b) -> a -> b
$ \TreeParserState
state -> TreeParserState
state
{ headElementPointer :: Maybe NodeIndex
headElementPointer = NodeIndex -> Maybe NodeIndex
forall a. a -> Maybe a
Just (NodeIndex -> Maybe NodeIndex) -> NodeIndex -> Maybe NodeIndex
forall a b. (a -> b) -> a -> b
$ TreeParserState -> NodeIndex
elementIndex TreeParserState
state
}
TreeInput -> TreeBuilder TreeOutput
insertElement TreeInput
t'
insertHeadElement_ :: TagParams -> TreeBuilder [Patch]
insertHeadElement_ :: TagParams -> TreeBuilder [Patch]
insertHeadElement_ TagParams
d = do
(TreeParserState -> TreeParserState)
-> StateT TreeParserState (Parser [TreeInput]) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
N.S.modify ((TreeParserState -> TreeParserState)
-> StateT TreeParserState (Parser [TreeInput]) ())
-> (TreeParserState -> TreeParserState)
-> StateT TreeParserState (Parser [TreeInput]) ()
forall a b. (a -> b) -> a -> b
$ \TreeParserState
state -> TreeParserState
state
{ headElementPointer :: Maybe NodeIndex
headElementPointer = NodeIndex -> Maybe NodeIndex
forall a. a -> Maybe a
Just (NodeIndex -> Maybe NodeIndex) -> NodeIndex -> Maybe NodeIndex
forall a b. (a -> b) -> a -> b
$ TreeParserState -> NodeIndex
elementIndex TreeParserState
state
}
TagParams -> TreeBuilder [Patch]
insertElement_ TagParams
d
addAttribute :: InsertAt -> NodeIndex -> BasicAttribute -> TreeBuilder [Patch]
addAttribute :: InsertAt -> NodeIndex -> BasicAttribute -> TreeBuilder [Patch]
addAttribute InsertAt
at NodeIndex
i (Text
name, Text
value) = do
TreeParserState
state <- StateT TreeParserState (Parser [TreeInput]) TreeParserState
forall (m :: * -> *) s. Monad m => StateT s m s
N.S.get
let ([(NodeIndex, ElementParams)]
es1, [(NodeIndex, ElementParams)]
es2) = ((NodeIndex, ElementParams) -> Bool)
-> [(NodeIndex, ElementParams)]
-> ([(NodeIndex, ElementParams)], [(NodeIndex, ElementParams)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.break (NodeIndex -> NodeIndex -> Bool
forall a. Eq a => a -> a -> Bool
(==) NodeIndex
i (NodeIndex -> Bool)
-> ((NodeIndex, ElementParams) -> NodeIndex)
-> (NodeIndex, ElementParams)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NodeIndex, ElementParams) -> NodeIndex
forall a b. (a, b) -> a
fst) ([(NodeIndex, ElementParams)]
-> ([(NodeIndex, ElementParams)], [(NodeIndex, ElementParams)]))
-> [(NodeIndex, ElementParams)]
-> ([(NodeIndex, ElementParams)], [(NodeIndex, ElementParams)])
forall a b. (a -> b) -> a -> b
$ TreeParserState -> [(NodeIndex, ElementParams)]
openElements TreeParserState
state
case [(NodeIndex, ElementParams)]
es2 of
((NodeIndex
_, ElementParams
e):[(NodeIndex, ElementParams)]
es') | Bool -> Bool
not (Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Text
name ([Text] -> Bool)
-> (AttributeMap -> [Text]) -> AttributeMap -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AttributeParams -> Text) -> [AttributeParams] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map AttributeParams -> Text
attrName ([AttributeParams] -> [Text])
-> (AttributeMap -> [AttributeParams]) -> AttributeMap -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttributeMap -> [AttributeParams]
toAttrList (AttributeMap -> Bool) -> AttributeMap -> Bool
forall a b. (a -> b) -> a -> b
$ ElementParams -> AttributeMap
elementAttributes ElementParams
e) -> do
TreeParserState -> StateT TreeParserState (Parser [TreeInput]) ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
N.S.put (TreeParserState -> StateT TreeParserState (Parser [TreeInput]) ())
-> TreeParserState
-> StateT TreeParserState (Parser [TreeInput]) ()
forall a b. (a -> b) -> a -> b
$ TreeParserState
state
{ openElements :: [(NodeIndex, ElementParams)]
openElements = [(NodeIndex, ElementParams)]
es1 [(NodeIndex, ElementParams)]
-> [(NodeIndex, ElementParams)] -> [(NodeIndex, ElementParams)]
forall a. [a] -> [a] -> [a]
++ (NodeIndex
i, ElementParams -> ElementParams
addAttributeData ElementParams
e) (NodeIndex, ElementParams)
-> [(NodeIndex, ElementParams)] -> [(NodeIndex, ElementParams)]
forall a. a -> [a] -> [a]
: [(NodeIndex, ElementParams)]
es'
}
[Patch] -> TreeBuilder [Patch]
forall (m :: * -> *) a. Monad m => a -> m a
return [InsertAt -> AttributeParams -> Patch
AddAttribute InsertAt
at AttributeParams
attr]
[(NodeIndex, ElementParams)]
_ -> [Patch] -> TreeBuilder [Patch]
forall (m :: * -> *) a. Monad m => a -> m a
return []
where addAttributeData :: ElementParams -> ElementParams
addAttributeData ElementParams
d = ElementParams
d
{ elementAttributes :: AttributeMap
elementAttributes = AttributeParams -> AttributeMap -> AttributeMap
insertAttribute AttributeParams
attr (AttributeMap -> AttributeMap) -> AttributeMap -> AttributeMap
forall a b. (a -> b) -> a -> b
$ ElementParams -> AttributeMap
elementAttributes ElementParams
d
}
attr :: AttributeParams
attr = AttributeParams
emptyAttributeParams
{ attrName :: Text
attrName = Text
name
, attrValue :: Text
attrValue = Text
value
}
insertFormattingElement :: TreeInput -> TreeBuilder TreeOutput
insertFormattingElement :: TreeInput -> TreeBuilder TreeOutput
insertFormattingElement TreeInput
t' = do
TreeOutput
insert <- TreeInput -> TreeBuilder TreeOutput
insertElement TreeInput
t'
TreeParserState
state <- StateT TreeParserState (Parser [TreeInput]) TreeParserState
forall (m :: * -> *) s. Monad m => StateT s m s
N.S.get
case [(NodeIndex, ElementParams)] -> Maybe (NodeIndex, ElementParams)
forall a. [a] -> Maybe a
Y.listToMaybe ([(NodeIndex, ElementParams)] -> Maybe (NodeIndex, ElementParams))
-> [(NodeIndex, ElementParams)] -> Maybe (NodeIndex, ElementParams)
forall a b. (a -> b) -> a -> b
$ TreeParserState -> [(NodeIndex, ElementParams)]
openElements TreeParserState
state of
Just (NodeIndex, ElementParams)
e -> case TreeInput -> Token
tokenOut TreeInput
t' of
StartTag TagParams
d -> TreeParserState -> StateT TreeParserState (Parser [TreeInput]) ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
N.S.put (TreeParserState -> StateT TreeParserState (Parser [TreeInput]) ())
-> TreeParserState
-> StateT TreeParserState (Parser [TreeInput]) ()
forall a b. (a -> b) -> a -> b
$ TreeParserState
state
{ activeFormattingElements :: [[(NodeIndex, TagParams)]]
activeFormattingElements =
(NodeIndex, TagParams)
-> [[(NodeIndex, TagParams)]] -> [[(NodeIndex, TagParams)]]
forall a.
(a, TagParams) -> [[(a, TagParams)]] -> [[(a, TagParams)]]
pushFormattingElement ((NodeIndex, ElementParams) -> NodeIndex
forall a b. (a, b) -> a
fst (NodeIndex, ElementParams)
e, TagParams
d) ([[(NodeIndex, TagParams)]] -> [[(NodeIndex, TagParams)]])
-> [[(NodeIndex, TagParams)]] -> [[(NodeIndex, TagParams)]]
forall a b. (a -> b) -> a -> b
$ TreeParserState -> [[(NodeIndex, TagParams)]]
activeFormattingElements TreeParserState
state
}
Token
_ -> () -> StateT TreeParserState (Parser [TreeInput]) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe (NodeIndex, ElementParams)
Nothing -> () -> StateT TreeParserState (Parser [TreeInput]) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
TreeOutput -> TreeBuilder TreeOutput
forall (m :: * -> *) a. Monad m => a -> m a
return TreeOutput
insert
where pushFormattingElement :: (a, TagParams) -> [[(a, TagParams)]] -> [[(a, TagParams)]]
pushFormattingElement (a, TagParams)
e [] = [[(a, TagParams)
e]]
pushFormattingElement (a, TagParams)
e ([(a, TagParams)]
fs:[[(a, TagParams)]]
fss) = ((a, TagParams)
e (a, TagParams) -> [(a, TagParams)] -> [(a, TagParams)]
forall a. a -> [a] -> [a]
: [(a, TagParams)]
fs') [(a, TagParams)] -> [[(a, TagParams)]] -> [[(a, TagParams)]]
forall a. a -> [a] -> [a]
: [[(a, TagParams)]]
fss
where fs' :: [(a, TagParams)]
fs' = case ((a, TagParams) -> Bool) -> [(a, TagParams)] -> [Int]
forall a. (a -> Bool) -> [a] -> [Int]
L.findIndices (TagParams -> Bool
equalElement (TagParams -> Bool)
-> ((a, TagParams) -> TagParams) -> (a, TagParams) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, TagParams) -> TagParams
forall a b. (a, b) -> b
snd) [(a, TagParams)]
fs of
(Int
_:Int
_:Int
i:[Int]
is) -> case [Int] -> [(a, TagParams)] -> [[(a, TagParams)]]
forall a. [Int] -> [a] -> [[a]]
splitAts (Int
i Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
is) [(a, TagParams)]
fs of
[] -> []
([(a, TagParams)]
ds:[[(a, TagParams)]]
dss) -> [(a, TagParams)]
ds [(a, TagParams)] -> [(a, TagParams)] -> [(a, TagParams)]
forall a. [a] -> [a] -> [a]
++ ([(a, TagParams)] -> [(a, TagParams)])
-> [[(a, TagParams)]] -> [(a, TagParams)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> [(a, TagParams)] -> [(a, TagParams)]
forall a. Int -> [a] -> [a]
drop Int
1) [[(a, TagParams)]]
dss
[Int]
_ -> [(a, TagParams)]
fs
splitAts :: [Int] -> [a] -> [[a]]
splitAts [] [a]
dss = [[a]
dss]
splitAts (Int
i:[Int]
is) [a]
dss =
let ([a]
ds', [a]
dss') = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
i [a]
dss
in [a]
ds' [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [Int] -> [a] -> [[a]]
splitAts ((Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Num a => a -> a -> a
`subtract` Int
i) [Int]
is) [a]
dss'
equalElement :: TagParams -> Bool
equalElement TagParams
e' =
TagParams -> Text
tagName ((a, TagParams) -> TagParams
forall a b. (a, b) -> b
snd (a, TagParams)
e) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== TagParams -> Text
tagName TagParams
e'
Bool -> Bool -> Bool
&& TagParams -> HashMap Text Text
tagAttributes ((a, TagParams) -> TagParams
forall a b. (a, b) -> b
snd (a, TagParams)
e) HashMap Text Text -> HashMap Text Text -> Bool
forall a. Eq a => a -> a -> Bool
== TagParams -> HashMap Text Text
tagAttributes TagParams
e'
reconstructFormattingElements :: TreeBuilder [Patch]
reconstructFormattingElements :: TreeBuilder [Patch]
reconstructFormattingElements = do
TreeParserState
state <- StateT TreeParserState (Parser [TreeInput]) TreeParserState
forall (m :: * -> *) s. Monad m => StateT s m s
N.S.get
let open :: [NodeIndex]
open = ((NodeIndex, ElementParams) -> NodeIndex)
-> [(NodeIndex, ElementParams)] -> [NodeIndex]
forall a b. (a -> b) -> [a] -> [b]
map (NodeIndex, ElementParams) -> NodeIndex
forall a b. (a, b) -> a
fst ([(NodeIndex, ElementParams)] -> [NodeIndex])
-> [(NodeIndex, ElementParams)] -> [NodeIndex]
forall a b. (a -> b) -> a -> b
$ TreeParserState -> [(NodeIndex, ElementParams)]
openElements TreeParserState
state
([(NodeIndex, TagParams)]
es, [[(NodeIndex, TagParams)]]
ess) = case TreeParserState -> [[(NodeIndex, TagParams)]]
activeFormattingElements TreeParserState
state of
[] -> ([], [])
([(NodeIndex, TagParams)]
es':[[(NodeIndex, TagParams)]]
ess') -> ([(NodeIndex, TagParams)]
es', [[(NodeIndex, TagParams)]]
ess')
([(NodeIndex, TagParams)]
toRebuild, [(NodeIndex, TagParams)]
alreadyOpened) = ((NodeIndex, TagParams) -> Bool)
-> [(NodeIndex, TagParams)]
-> ([(NodeIndex, TagParams)], [(NodeIndex, TagParams)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\(NodeIndex
i, TagParams
_) -> NodeIndex -> [NodeIndex] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem NodeIndex
i [NodeIndex]
open) [(NodeIndex, TagParams)]
es
TreeParserState -> StateT TreeParserState (Parser [TreeInput]) ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
N.S.put (TreeParserState -> StateT TreeParserState (Parser [TreeInput]) ())
-> TreeParserState
-> StateT TreeParserState (Parser [TreeInput]) ()
forall a b. (a -> b) -> a -> b
$ TreeParserState
state
{ activeFormattingElements :: [[(NodeIndex, TagParams)]]
activeFormattingElements = [(NodeIndex, TagParams)]
alreadyOpened [(NodeIndex, TagParams)]
-> [[(NodeIndex, TagParams)]] -> [[(NodeIndex, TagParams)]]
forall a. a -> [a] -> [a]
: [[(NodeIndex, TagParams)]]
ess
}
([Patch] -> (NodeIndex, TagParams) -> TreeBuilder [Patch])
-> [Patch] -> [(NodeIndex, TagParams)] -> TreeBuilder [Patch]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
N.foldM [Patch] -> (NodeIndex, TagParams) -> TreeBuilder [Patch]
forall a. [Patch] -> (a, TagParams) -> TreeBuilder [Patch]
reconstruct [] ([(NodeIndex, TagParams)] -> TreeBuilder [Patch])
-> [(NodeIndex, TagParams)] -> TreeBuilder [Patch]
forall a b. (a -> b) -> a -> b
$ [(NodeIndex, TagParams)] -> [(NodeIndex, TagParams)]
forall a. [a] -> [a]
reverse [(NodeIndex, TagParams)]
toRebuild
where reconstruct :: [Patch] -> (a, TagParams) -> TreeBuilder [Patch]
reconstruct [Patch]
pss (a
_, TagParams
d) = do
[Patch]
ps <- TreeOutput -> [Patch]
treePatches (TreeOutput -> [Patch])
-> TreeBuilder TreeOutput -> TreeBuilder [Patch]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TreeInput -> TreeBuilder TreeOutput
insertFormattingElement ([ParseError] -> Token -> TreeInput
dummyToken [] (Token -> TreeInput) -> Token -> TreeInput
forall a b. (a -> b) -> a -> b
$ TagParams -> Token
StartTag TagParams
d)
[Patch] -> TreeBuilder [Patch]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Patch] -> TreeBuilder [Patch]) -> [Patch] -> TreeBuilder [Patch]
forall a b. (a -> b) -> a -> b
$ [Patch]
pss [Patch] -> [Patch] -> [Patch]
forall a. [a] -> [a] -> [a]
++ [Patch]
ps
restartParsing :: BS.L.ByteString -> TreeBuilder TreeOutput
restartParsing :: ByteString -> TreeBuilder TreeOutput
restartParsing ByteString
initial = do
TreeParserState -> StateT TreeParserState (Parser [TreeInput]) ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
N.S.put (TreeParserState -> StateT TreeParserState (Parser [TreeInput]) ())
-> TreeParserState
-> StateT TreeParserState (Parser [TreeInput]) ()
forall a b. (a -> b) -> a -> b
$ TreeState -> TreeParserState
treeParserState TreeState
defState
TreeOutput -> TreeBuilder TreeOutput
forall (m :: * -> *) a. Monad m => a -> m a
return (TreeOutput -> TreeBuilder TreeOutput)
-> TreeOutput -> TreeBuilder TreeOutput
forall a b. (a -> b) -> a -> b
$ TreeOutput :: [Patch] -> TokenizerOutputState -> TreeOutput
TreeOutput
{ treePatches :: [Patch]
treePatches = [Patch
RestartParsing]
, treeState :: TokenizerOutputState
treeState = (TokenizerState, ByteString) -> TokenizerOutputState
forall a. a -> Maybe a
Just (TokenizerState
tokState, ByteString -> ByteString
BS.L.toStrict ByteString
initial)
}
where updateDecoder :: TreeState -> TokenizerState
updateDecoder TreeState
state = TreeState -> TokenizerState
tokenizerState TreeState
state TokenizerState
-> (TokenizerState -> TokenizerState) -> TokenizerState
forall a b. a -> (a -> b) -> b
&
case TokenizerState
-> Either (Either SnifferEnvironment Encoding) (Maybe DecoderState)
decoderState_ (TokenizerState
-> Either
(Either SnifferEnvironment Encoding) (Maybe DecoderState))
-> TokenizerState
-> Either (Either SnifferEnvironment Encoding) (Maybe DecoderState)
forall a b. (a -> b) -> a -> b
$ TreeState -> TokenizerState
tokenizerState TreeState
state of
Left Either SnifferEnvironment Encoding
initialize -> Either SnifferEnvironment (Maybe Encoding)
-> TokenizerState -> TokenizerState
tokenizerEncoding (Either SnifferEnvironment (Maybe Encoding)
-> TokenizerState -> TokenizerState)
-> Either SnifferEnvironment (Maybe Encoding)
-> TokenizerState
-> TokenizerState
forall a b. (a -> b) -> a -> b
$ (Encoding -> Maybe Encoding)
-> Either SnifferEnvironment Encoding
-> Either SnifferEnvironment (Maybe Encoding)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Encoding -> Maybe Encoding
forall a. a -> Maybe a
Just Either SnifferEnvironment Encoding
initialize
Right Maybe DecoderState
decState -> Either SnifferEnvironment (Maybe Encoding)
-> TokenizerState -> TokenizerState
tokenizerEncoding (Either SnifferEnvironment (Maybe Encoding)
-> TokenizerState -> TokenizerState)
-> (Maybe Encoding -> Either SnifferEnvironment (Maybe Encoding))
-> Maybe Encoding
-> TokenizerState
-> TokenizerState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Encoding -> Either SnifferEnvironment (Maybe Encoding)
forall a b. b -> Either a b
Right (Maybe Encoding -> TokenizerState -> TokenizerState)
-> Maybe Encoding -> TokenizerState -> TokenizerState
forall a b. (a -> b) -> a -> b
$ (DecoderState -> Encoding) -> Maybe DecoderState -> Maybe Encoding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DecoderState -> Encoding
decoderEncoding Maybe DecoderState
decState
defState :: TreeState
defState = TreeState
defaultTreeState
tokState :: TokenizerState
tokState = TreeState -> TokenizerState
updateDecoder TreeState
defState
stopParsing :: TreeInput -> TreeBuilder TreeOutput
stopParsing :: TreeInput -> TreeBuilder TreeOutput
stopParsing TreeInput
t' = ([ElementParams] -> Word) -> TreeBuilder [Patch]
clear (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word)
-> ([ElementParams] -> Int) -> [ElementParams] -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ElementParams] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) TreeBuilder [Patch]
-> ([Patch] -> TreeBuilder TreeOutput) -> TreeBuilder TreeOutput
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TreeInput -> [Patch] -> TreeBuilder TreeOutput
packTree TreeInput
t'