module Web.Mangrove.Parse.Tree.Patch.Fold
( buildTree
) where
import qualified Data.Bifunctor as F.B
import qualified Data.Either as E
import qualified Data.HashMap.Strict as M
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 Web.Willow.DOM
import Web.Mangrove.Parse.Common.Error
import Web.Mangrove.Parse.Tree.Common hiding ( Token ( .. ) )
import Web.Mangrove.Parse.Tree.Patch
buildTree :: [Patch] -> Tree
buildTree :: [Patch] -> Tree
buildTree = ([Tree], [Patch]) -> Tree
buildTree' (([Tree], [Patch]) -> Tree)
-> ([Patch] -> ([Tree], [Patch])) -> [Patch] -> Tree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Patch] -> ([Tree], [Patch])
foldPatchset
where buildTree' :: ([Tree], [Patch]) -> Tree
buildTree' ([Tree]
ts, []) = Tree
emptyTree
{ node :: Node
node = QuirksMode -> Node
Document QuirksMode
mode'
, children :: [Tree]
children = [Tree]
ts'
}
where ([Tree]
ms, [Tree]
ts') = (Tree -> Bool) -> [Tree] -> ([Tree], [Tree])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (\Tree
t -> Node -> Maybe NodeType
nodeType (Tree -> Node
node Tree
t) Maybe NodeType -> Maybe NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType -> Maybe NodeType
forall a. a -> Maybe a
Just NodeType
DocumentNode) [Tree]
ts
mode' :: QuirksMode
mode' = (QuirksMode -> QuirksMode -> QuirksMode)
-> QuirksMode -> [QuirksMode] -> QuirksMode
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr QuirksMode -> QuirksMode -> QuirksMode
forall a. Ord a => a -> a -> a
max QuirksMode
NoQuirks ([QuirksMode] -> QuirksMode) -> [QuirksMode] -> QuirksMode
forall a b. (a -> b) -> a -> b
$ (Tree -> Maybe QuirksMode) -> [Tree] -> [QuirksMode]
forall a b. (a -> Maybe b) -> [a] -> [b]
Y.mapMaybe (Node -> Maybe QuirksMode
getQuirksMode (Node -> Maybe QuirksMode)
-> (Tree -> Node) -> Tree -> Maybe QuirksMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree -> Node
node) [Tree]
ms
getQuirksMode :: Node -> Maybe QuirksMode
getQuirksMode (Document QuirksMode
mode) = QuirksMode -> Maybe QuirksMode
forall a. a -> Maybe a
Just QuirksMode
mode
getQuirksMode Node
_ = Maybe QuirksMode
forall a. Maybe a
Nothing
buildTree' ([Tree]
_, Patch
RestartParsing : [Patch]
ps) = ([Tree], [Patch]) -> Tree
buildTree' (([Tree], [Patch]) -> Tree) -> ([Tree], [Patch]) -> Tree
forall a b. (a -> b) -> a -> b
$ [Patch] -> ([Tree], [Patch])
foldPatchset [Patch]
ps
buildTree' ([Tree]
ts, [Patch]
ps) = ([Tree], [Patch]) -> Tree
buildTree' (([Tree], [Patch]) -> Tree)
-> (([Tree], [Patch]) -> ([Tree], [Patch]))
-> ([Tree], [Patch])
-> Tree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Tree] -> [Tree]) -> ([Tree], [Patch]) -> ([Tree], [Patch])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
F.B.first ([Tree]
ts [Tree] -> [Tree] -> [Tree]
forall a. [a] -> [a] -> [a]
++) (([Tree], [Patch]) -> Tree) -> ([Tree], [Patch]) -> Tree
forall a b. (a -> b) -> a -> b
$ [Patch] -> ([Tree], [Patch])
foldPatchset [Patch]
ps
foldPatchset :: [Patch] -> ([Tree], [Patch])
foldPatchset :: [Patch] -> ([Tree], [Patch])
foldPatchset [Patch]
ps = ([Either ([ParseError], Char) (InsertAt, Tree)] -> [Tree])
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
-> ([Tree], [Patch])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
F.B.first ([Either ([ParseError], Char) Tree] -> [Tree]
joinTexts ([Either ([ParseError], Char) Tree] -> [Tree])
-> ([Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) Tree])
-> [Either ([ParseError], Char) (InsertAt, Tree)]
-> [Tree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either ([ParseError], Char) (InsertAt, Tree)
-> Maybe (Either ([ParseError], Char) Tree))
-> [Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) Tree]
forall a b. (a -> Maybe b) -> [a] -> [b]
Y.mapMaybe Either ([ParseError], Char) (InsertAt, Tree)
-> Maybe (Either ([ParseError], Char) Tree)
forall a a b. Either a (a, b) -> Maybe (Either a b)
filterNull) (([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
-> ([Tree], [Patch]))
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
-> ([Tree], [Patch])
forall a b. (a -> b) -> a -> b
$ Bool
-> [Patch]
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
foldPatchset' Bool
False [Patch]
ps
where
filterNull :: Either a (a, b) -> Maybe (Either a b)
filterNull (Right (a
_, b
t)) = Either a b -> Maybe (Either a b)
forall a. a -> Maybe a
Just (Either a b -> Maybe (Either a b))
-> Either a b -> Maybe (Either a b)
forall a b. (a -> b) -> a -> b
$ b -> Either a b
forall a b. b -> Either a b
Right b
t
filterNull (Left a
c) = Either a b -> Maybe (Either a b)
forall a. a -> Maybe a
Just (Either a b -> Maybe (Either a b))
-> Either a b -> Maybe (Either a b)
forall a b. (a -> b) -> a -> b
$ a -> Either a b
forall a b. a -> Either a b
Left a
c
foldPatchset'
:: Bool
-> [Patch]
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
foldPatchset' :: Bool
-> [Patch]
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
foldPatchset' Bool
_ [] = ([], [])
foldPatchset' Bool
isInner (ErrorList [ParseError]
_:[Patch]
ps) = Bool
-> [Patch]
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
foldPatchset' Bool
isInner [Patch]
ps
foldPatchset' Bool
False (CloseNodes IntMap ReparentDepth
_:[Patch]
ps) = Bool
-> [Patch]
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
foldPatchset' Bool
False [Patch]
ps
foldPatchset' Bool
False (Patch
SoftCloseCurrentNode:[Patch]
ps) = Bool
-> [Patch]
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
foldPatchset' Bool
False [Patch]
ps
foldPatchset' Bool
False (Patch
DropCurrentNode:[Patch]
ps) = Bool
-> [Patch]
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
foldPatchset' Bool
False [Patch]
ps
foldPatchset' Bool
False (Patch
RestartParsing:[Patch]
ps) = Bool
-> [Patch]
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
foldPatchset' Bool
False [Patch]
ps
foldPatchset' Bool
True ps :: [Patch]
ps@(Patch
DropCurrentNode:[Patch]
_) = ([], [Patch]
ps)
foldPatchset' Bool
True ps :: [Patch]
ps@(Patch
RestartParsing:[Patch]
_) = ([], [Patch]
ps)
foldPatchset' Bool
True (p :: Patch
p@(CloseNodes IntMap ReparentDepth
ls):[Patch]
ps) = case IntMap ReparentDepth -> (ReparentDepth, IntMap ReparentDepth)
decrementReparenting IntMap ReparentDepth
ls of
(ReparentDepth, IntMap ReparentDepth)
_ | IntMap ReparentDepth -> Bool
forall a. IntMap a -> Bool
M.I.null IntMap ReparentDepth
ls -> Bool
-> [Patch]
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
foldPatchset' Bool
True [Patch]
ps
(ReparentDepth
0, IntMap ReparentDepth
toFloat) -> case [Patch]
ps of
[] -> ([], [Patch
p])
(CloseNodes IntMap ReparentDepth
ls':[Patch]
ps') ->
Bool
-> [Patch]
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
foldPatchset' Bool
True ([Patch]
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch]))
-> [Patch]
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
forall a b. (a -> b) -> a -> b
$ IntMap ReparentDepth -> Patch
CloseNodes ((ReparentDepth -> ReparentDepth -> ReparentDepth)
-> IntMap ReparentDepth
-> IntMap ReparentDepth
-> IntMap ReparentDepth
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
M.I.unionWith ReparentDepth -> ReparentDepth -> ReparentDepth
forall a. Num a => a -> a -> a
(+) IntMap ReparentDepth
ls IntMap ReparentDepth
ls') Patch -> [Patch] -> [Patch]
forall a. a -> [a] -> [a]
: [Patch]
ps'
(Patch
DropCurrentNode:[Patch]
ps') ->
([], Patch
DropCurrentNode Patch -> [Patch] -> [Patch]
forall a. a -> [a] -> [a]
: IntMap ReparentDepth -> Patch
CloseNodes IntMap ReparentDepth
toFloat Patch -> [Patch] -> [Patch]
forall a. a -> [a] -> [a]
: [Patch]
ps')
(Patch
RestartParsing:[Patch]
_) ->
([], [Patch]
ps)
(p' :: Patch
p'@InsertElement{}:[Patch]
ps') ->
Bool
-> [Patch]
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
foldPatchset' Bool
True ([Patch]
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch]))
-> [Patch]
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
forall a b. (a -> b) -> a -> b
$ Patch
p' Patch -> [Patch] -> [Patch]
forall a. a -> [a] -> [a]
: IntMap ReparentDepth -> Patch
CloseNodes (IntMap ReparentDepth -> IntMap ReparentDepth
incrementReparenting IntMap ReparentDepth
ls) Patch -> [Patch] -> [Patch]
forall a. a -> [a] -> [a]
: [Patch]
ps'
(Patch
p':[Patch]
ps') ->
Bool
-> [Patch]
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
foldPatchset' Bool
True ([Patch]
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch]))
-> [Patch]
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
forall a b. (a -> b) -> a -> b
$ Patch
p' Patch -> [Patch] -> [Patch]
forall a. a -> [a] -> [a]
: Patch
p Patch -> [Patch] -> [Patch]
forall a. a -> [a] -> [a]
: [Patch]
ps'
(ReparentDepth, IntMap ReparentDepth)
_ -> ([], Patch
p Patch -> [Patch] -> [Patch]
forall a. a -> [a] -> [a]
: [Patch]
ps)
foldPatchset' Bool
isInner (SetDocumentQuirks QuirksMode
mode:[Patch]
ps) =
([Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) (InsertAt, Tree)])
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
F.B.first ((InsertAt, Tree) -> Either ([ParseError], Char) (InsertAt, Tree)
forall a b. b -> Either a b
Right (InsertAt
InDocument, QuirksMode -> Tree
packQuirks QuirksMode
mode) Either ([ParseError], Char) (InsertAt, Tree)
-> [Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) (InsertAt, Tree)]
forall a. a -> [a] -> [a]
:) (([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch]))
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
forall a b. (a -> b) -> a -> b
$ Bool
-> [Patch]
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
foldPatchset' Bool
isInner [Patch]
ps
foldPatchset' Bool
isInner (InsertAndSetDocumentType [ParseError]
_ DocumentTypeParams
d:[Patch]
ps) =
([Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) (InsertAt, Tree)])
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
F.B.first ((InsertAt, Tree) -> Either ([ParseError], Char) (InsertAt, Tree)
forall a b. b -> Either a b
Right (InsertAt
InDocument, DocumentTypeParams -> Tree
packDoctype DocumentTypeParams
d) Either ([ParseError], Char) (InsertAt, Tree)
-> [Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) (InsertAt, Tree)]
forall a. a -> [a] -> [a]
:) (([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch]))
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
forall a b. (a -> b) -> a -> b
$ Bool
-> [Patch]
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
foldPatchset' Bool
isInner [Patch]
ps
foldPatchset' Bool
isInner (InsertComment [ParseError]
_ InsertAt
loc Text
txt:[Patch]
ps) =
([Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) (InsertAt, Tree)])
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
F.B.first ((InsertAt, Tree) -> Either ([ParseError], Char) (InsertAt, Tree)
forall a b. b -> Either a b
Right (InsertAt
loc, Text -> Tree
packComment Text
txt) Either ([ParseError], Char) (InsertAt, Tree)
-> [Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) (InsertAt, Tree)]
forall a. a -> [a] -> [a]
:) (([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch]))
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
forall a b. (a -> b) -> a -> b
$ Bool
-> [Patch]
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
foldPatchset' Bool
isInner [Patch]
ps
foldPatchset' Bool
isInner (AddAttribute InsertAt
loc AttributeParams
attr:[Patch]
ps) =
([Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) (InsertAt, Tree)])
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
F.B.first ((InsertAt, Tree) -> Either ([ParseError], Char) (InsertAt, Tree)
forall a b. b -> Either a b
Right (InsertAt
loc, AttributeParams -> Tree
packAttribute AttributeParams
attr) Either ([ParseError], Char) (InsertAt, Tree)
-> [Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) (InsertAt, Tree)]
forall a. a -> [a] -> [a]
:) (([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch]))
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
forall a b. (a -> b) -> a -> b
$ Bool
-> [Patch]
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
foldPatchset' Bool
isInner [Patch]
ps
foldPatchset' Bool
isInner (InsertCharacter [ParseError]
errs Char
h:[Patch]
ps) =
([Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) (InsertAt, Tree)])
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
F.B.first (([ParseError], Char)
-> Either ([ParseError], Char) (InsertAt, Tree)
forall a b. a -> Either a b
Left ([ParseError]
errs, Char
h) Either ([ParseError], Char) (InsertAt, Tree)
-> [Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) (InsertAt, Tree)]
forall a. a -> [a] -> [a]
:) (([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch]))
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
forall a b. (a -> b) -> a -> b
$ Bool
-> [Patch]
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
foldPatchset' Bool
isInner [Patch]
ps
foldPatchset' Bool
True (Patch
SoftCloseCurrentNode:[Patch]
ps) =
([Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) (InsertAt, Tree)])
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
F.B.first ((Either ([ParseError], Char) (InsertAt, Tree)
-> Either ([ParseError], Char) (InsertAt, Tree))
-> [Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) (InsertAt, Tree)]
forall a b. (a -> b) -> [a] -> [b]
map Either ([ParseError], Char) (InsertAt, Tree)
-> Either ([ParseError], Char) (InsertAt, Tree)
forall a.
Either (a, Char) (InsertAt, Tree)
-> Either (a, Char) (InsertAt, Tree)
floatTrees) (([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch]))
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
forall a b. (a -> b) -> a -> b
$ Bool
-> [Patch]
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
foldPatchset' Bool
True [Patch]
ps
where floatTrees :: Either (a, Char) (InsertAt, Tree)
-> Either (a, Char) (InsertAt, Tree)
floatTrees t' :: Either (a, Char) (InsertAt, Tree)
t'@(Right (RelativeLocation ReparentDepth
l, Tree
t))
| Node -> Maybe NodeType
nodeType (Tree -> Node
node Tree
t) Maybe NodeType -> Maybe NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType -> Maybe NodeType
forall a. a -> Maybe a
Just NodeType
ElementNode = Either (a, Char) (InsertAt, Tree)
t'
| Bool
otherwise = (InsertAt, Tree) -> Either (a, Char) (InsertAt, Tree)
forall a b. b -> Either a b
Right (ReparentDepth -> InsertAt
RelativeLocation (ReparentDepth -> InsertAt) -> ReparentDepth -> InsertAt
forall a b. (a -> b) -> a -> b
$ ReparentDepth -> ReparentDepth
forall a. Enum a => a -> a
succ ReparentDepth
l, Tree
t)
floatTrees (Left (a
_, Char
c)) = (InsertAt, Tree) -> Either (a, Char) (InsertAt, Tree)
forall a b. b -> Either a b
Right (ReparentDepth -> InsertAt
RelativeLocation ReparentDepth
1, Tree
emptyTree
{ node :: Node
node = Text -> Node
Text (Text -> Node) -> Text -> Node
forall a b. (a -> b) -> a -> b
$ Char -> Text
T.singleton Char
c
})
floatTrees Either (a, Char) (InsertAt, Tree)
t' = Either (a, Char) (InsertAt, Tree)
t'
foldPatchset' Bool
isInner (InsertElement [ParseError]
_ ElementParams
tag:[Patch]
ps) =
let ([Either ([ParseError], Char) (InsertAt, Tree)]
ts, [Patch]
ps') = Bool
-> [Patch]
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
foldPatchset' Bool
True [Patch]
ps
([Either ([ParseError], Char) Tree]
ts', [Either ([ParseError], Char) (InsertAt, Tree)]
bubble) = [Either ([ParseError], Char) (InsertAt, Tree)]
-> [InsertAt]
-> ([Either ([ParseError], Char) Tree],
[Either ([ParseError], Char) (InsertAt, Tree)])
filterFloaters [Either ([ParseError], Char) (InsertAt, Tree)]
ts ([InsertAt]
-> ([Either ([ParseError], Char) Tree],
[Either ([ParseError], Char) (InsertAt, Tree)]))
-> [InsertAt]
-> ([Either ([ParseError], Char) Tree],
[Either ([ParseError], Char) (InsertAt, Tree)])
forall a b. (a -> b) -> a -> b
$ Bool -> ElementParams -> [InsertAt]
floatsElement Bool
isInner ElementParams
tag
([Either ([ParseError], Char) Tree]
attrs, [Either ([ParseError], Char) Tree]
ts'') = (Either ([ParseError], Char) Tree -> Bool)
-> [Either ([ParseError], Char) Tree]
-> ([Either ([ParseError], Char) Tree],
[Either ([ParseError], Char) Tree])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition Either ([ParseError], Char) Tree -> Bool
forall a. Either a Tree -> Bool
isAttribute [Either ([ParseError], Char) Tree]
ts'
tag' :: ElementParams
tag' = ElementParams
tag
{ elementAttributes :: AttributeMap
elementAttributes = AttributeMap -> AttributeMap -> AttributeMap
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
M.union (ElementParams -> AttributeMap
elementAttributes ElementParams
tag) (AttributeMap -> AttributeMap)
-> ([AttributeParams] -> AttributeMap)
-> [AttributeParams]
-> AttributeMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
[AttributeParams] -> AttributeMap
fromAttrList ([AttributeParams] -> AttributeMap)
-> [AttributeParams] -> AttributeMap
forall a b. (a -> b) -> a -> b
$ (Either ([ParseError], Char) Tree -> Maybe AttributeParams)
-> [Either ([ParseError], Char) Tree] -> [AttributeParams]
forall a b. (a -> Maybe b) -> [a] -> [b]
Y.mapMaybe Either ([ParseError], Char) Tree -> Maybe AttributeParams
forall a. Either a Tree -> Maybe AttributeParams
toAttribute [Either ([ParseError], Char) Tree]
attrs
}
this :: Either a (InsertAt, Tree)
this = (InsertAt, Tree) -> Either a (InsertAt, Tree)
forall a b. b -> Either a b
Right (ReparentDepth -> InsertAt
RelativeLocation ReparentDepth
0, ElementParams -> [Tree] -> Tree
packElement ElementParams
tag' ([Tree] -> Tree) -> [Tree] -> Tree
forall a b. (a -> b) -> a -> b
$ [Either ([ParseError], Char) Tree] -> [Tree]
joinTexts [Either ([ParseError], Char) Tree]
ts'')
in case [Patch]
ps' of
[] -> (Either ([ParseError], Char) (InsertAt, Tree)
forall a. Either a (InsertAt, Tree)
this Either ([ParseError], Char) (InsertAt, Tree)
-> [Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) (InsertAt, Tree)]
forall a. a -> [a] -> [a]
: [Either ([ParseError], Char) (InsertAt, Tree)]
bubble, [])
(Patch
DropCurrentNode:[Patch]
ps'') -> ([Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) (InsertAt, Tree)])
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
F.B.first ([Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) (InsertAt, Tree)]
forall a. [a] -> [a] -> [a]
++ [Either ([ParseError], Char) (InsertAt, Tree)]
bubble) (([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch]))
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
forall a b. (a -> b) -> a -> b
$ Bool
-> [Patch]
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
foldPatchset' Bool
True [Patch]
ps''
(CloseNodes IntMap ReparentDepth
ls:[Patch]
ps'') ->
let (ReparentDepth
here, IntMap ReparentDepth
toFloat) = IntMap ReparentDepth -> (ReparentDepth, IntMap ReparentDepth)
decrementReparenting IntMap ReparentDepth
ls
ls' :: IntMap ReparentDepth
ls' = case ReparentDepth
here of
ReparentDepth
l | ReparentDepth
l ReparentDepth -> ReparentDepth -> Bool
forall a. Ord a => a -> a -> Bool
>= ReparentDepth
2 -> (ReparentDepth -> ReparentDepth -> ReparentDepth)
-> Key
-> ReparentDepth
-> IntMap ReparentDepth
-> IntMap ReparentDepth
forall a. (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a
M.I.insertWith ReparentDepth -> ReparentDepth -> ReparentDepth
forall a. Num a => a -> a -> a
(+) Key
0 (ReparentDepth -> ReparentDepth
forall a. Enum a => a -> a
pred ReparentDepth
l) IntMap ReparentDepth
toFloat
ReparentDepth
_ -> IntMap ReparentDepth
toFloat
([Either ([ParseError], Char) (InsertAt, Tree)]
out, [Patch]
trail) = Bool
-> [Patch]
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
foldPatchset' Bool
True ([Patch]
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch]))
-> [Patch]
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
forall a b. (a -> b) -> a -> b
$ IntMap ReparentDepth -> Patch
CloseNodes IntMap ReparentDepth
ls' Patch -> [Patch] -> [Patch]
forall a. a -> [a] -> [a]
: [Patch]
ps''
in (Either ([ParseError], Char) (InsertAt, Tree)
forall a. Either a (InsertAt, Tree)
this Either ([ParseError], Char) (InsertAt, Tree)
-> [Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) (InsertAt, Tree)]
forall a. a -> [a] -> [a]
: [Either ([ParseError], Char) (InsertAt, Tree)]
bubble [Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) (InsertAt, Tree)]
forall a. [a] -> [a] -> [a]
++ [Either ([ParseError], Char) (InsertAt, Tree)]
out, [Patch]
trail)
(Patch
RestartParsing:[Patch]
_) -> ([], [Patch]
ps')
[Patch]
_ ->
let ([Either ([ParseError], Char) (InsertAt, Tree)]
out, [Patch]
trail) = Bool
-> [Patch]
-> ([Either ([ParseError], Char) (InsertAt, Tree)], [Patch])
foldPatchset' Bool
True [Patch]
ps'
cleaned :: [Either ([ParseError], Char) (InsertAt, Tree)]
cleaned = (Either ([ParseError], Char) Tree
-> Either ([ParseError], Char) (InsertAt, Tree))
-> [Either ([ParseError], Char) Tree]
-> [Either ([ParseError], Char) (InsertAt, Tree)]
forall a b. (a -> b) -> [a] -> [b]
map ((Tree -> (InsertAt, Tree))
-> Either ([ParseError], Char) Tree
-> Either ([ParseError], Char) (InsertAt, Tree)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Tree -> (InsertAt, Tree))
-> Either ([ParseError], Char) Tree
-> Either ([ParseError], Char) (InsertAt, Tree))
-> (Tree -> (InsertAt, Tree))
-> Either ([ParseError], Char) Tree
-> Either ([ParseError], Char) (InsertAt, Tree)
forall a b. (a -> b) -> a -> b
$ \Tree
c -> (ReparentDepth -> InsertAt
RelativeLocation ReparentDepth
0, Tree
c)) [Either ([ParseError], Char) Tree]
ts''
in ([Either ([ParseError], Char) (InsertAt, Tree)]
cleaned [Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) (InsertAt, Tree)]
forall a. [a] -> [a] -> [a]
++ [Either ([ParseError], Char) (InsertAt, Tree)]
out [Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) (InsertAt, Tree)]
forall a. [a] -> [a] -> [a]
++ [Either ([ParseError], Char) (InsertAt, Tree)]
bubble, [Patch]
trail)
where isAttribute :: Either a Tree -> Bool
isAttribute (Right Tree
tok) = Node -> Maybe NodeType
nodeType (Tree -> Node
node Tree
tok) Maybe NodeType -> Maybe NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType -> Maybe NodeType
forall a. a -> Maybe a
Just NodeType
AttributeNode
isAttribute (Left a
_) = Bool
False
toAttribute :: Either a Tree -> Maybe AttributeParams
toAttribute (Right Tree
tok) = case Tree -> Node
node Tree
tok of
Attribute AttributeParams
attr -> AttributeParams -> Maybe AttributeParams
forall a. a -> Maybe a
Just AttributeParams
attr
Node
_ -> Maybe AttributeParams
forall a. Maybe a
Nothing
toAttribute (Left a
_) = Maybe AttributeParams
forall a. Maybe a
Nothing
filterFloaters
:: [Either ([ParseError], Char) (InsertAt, Tree)]
-> [InsertAt]
-> ([Either ([ParseError], Char) Tree], [Either ([ParseError], Char) (InsertAt, Tree)])
filterFloaters :: [Either ([ParseError], Char) (InsertAt, Tree)]
-> [InsertAt]
-> ([Either ([ParseError], Char) Tree],
[Either ([ParseError], Char) (InsertAt, Tree)])
filterFloaters [Either ([ParseError], Char) (InsertAt, Tree)]
ts [InsertAt]
here = ([Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) Tree])
-> ([Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) (InsertAt, Tree)])
-> ([Either ([ParseError], Char) (InsertAt, Tree)],
[Either ([ParseError], Char) (InsertAt, Tree)])
-> ([Either ([ParseError], Char) Tree],
[Either ([ParseError], Char) (InsertAt, Tree)])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
F.B.bimap
((Either ([ParseError], Char) (InsertAt, Tree)
-> Either ([ParseError], Char) Tree)
-> [Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) Tree]
forall a b. (a -> b) -> [a] -> [b]
map ((Either ([ParseError], Char) (InsertAt, Tree)
-> Either ([ParseError], Char) Tree)
-> [Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) Tree])
-> (Either ([ParseError], Char) (InsertAt, Tree)
-> Either ([ParseError], Char) Tree)
-> [Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) Tree]
forall a b. (a -> b) -> a -> b
$ ((InsertAt, Tree) -> Tree)
-> Either ([ParseError], Char) (InsertAt, Tree)
-> Either ([ParseError], Char) Tree
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
F.B.second (InsertAt, Tree) -> Tree
forall a b. (a, b) -> b
snd)
((Either ([ParseError], Char) (InsertAt, Tree)
-> Either ([ParseError], Char) (InsertAt, Tree))
-> [Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) (InsertAt, Tree)]
forall a b. (a -> b) -> [a] -> [b]
map ((Either ([ParseError], Char) (InsertAt, Tree)
-> Either ([ParseError], Char) (InsertAt, Tree))
-> [Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) (InsertAt, Tree)])
-> (((InsertAt, Tree) -> (InsertAt, Tree))
-> Either ([ParseError], Char) (InsertAt, Tree)
-> Either ([ParseError], Char) (InsertAt, Tree))
-> ((InsertAt, Tree) -> (InsertAt, Tree))
-> [Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) (InsertAt, Tree)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((InsertAt, Tree) -> (InsertAt, Tree))
-> Either ([ParseError], Char) (InsertAt, Tree)
-> Either ([ParseError], Char) (InsertAt, Tree)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((InsertAt, Tree) -> (InsertAt, Tree))
-> [Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) (InsertAt, Tree)])
-> ((InsertAt, Tree) -> (InsertAt, Tree))
-> [Either ([ParseError], Char) (InsertAt, Tree)]
-> [Either ([ParseError], Char) (InsertAt, Tree)]
forall a b. (a -> b) -> a -> b
$ (InsertAt -> InsertAt) -> (InsertAt, Tree) -> (InsertAt, Tree)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
F.B.first InsertAt -> InsertAt
decrementTarget) (([Either ([ParseError], Char) (InsertAt, Tree)],
[Either ([ParseError], Char) (InsertAt, Tree)])
-> ([Either ([ParseError], Char) Tree],
[Either ([ParseError], Char) (InsertAt, Tree)]))
-> ([Either ([ParseError], Char) (InsertAt, Tree)],
[Either ([ParseError], Char) (InsertAt, Tree)])
-> ([Either ([ParseError], Char) Tree],
[Either ([ParseError], Char) (InsertAt, Tree)])
forall a b. (a -> b) -> a -> b
$
(Either ([ParseError], Char) (InsertAt, Tree) -> Bool)
-> [Either ([ParseError], Char) (InsertAt, Tree)]
-> ([Either ([ParseError], Char) (InsertAt, Tree)],
[Either ([ParseError], Char) (InsertAt, Tree)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition Either ([ParseError], Char) (InsertAt, Tree) -> Bool
forall a b. Either a (InsertAt, b) -> Bool
isHere [Either ([ParseError], Char) (InsertAt, Tree)]
ts
where decrementTarget :: InsertAt -> InsertAt
decrementTarget InsertAt
loc = case InsertAt
loc of
RelativeLocation ReparentDepth
0 -> InsertAt
loc
RelativeLocation ReparentDepth
i -> ReparentDepth -> InsertAt
RelativeLocation (ReparentDepth -> InsertAt) -> ReparentDepth -> InsertAt
forall a b. (a -> b) -> a -> b
$ ReparentDepth -> ReparentDepth
forall a. Enum a => a -> a
pred ReparentDepth
i
InsertAt
_ -> InsertAt
loc
isHere :: Either a (InsertAt, b) -> Bool
isHere (Right (InsertAt
l, b
_)) = InsertAt -> [InsertAt] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem InsertAt
l [InsertAt]
here
isHere (Left a
_) = Bool
True
floatsElement
:: Bool
-> ElementParams
-> [InsertAt]
floatsElement :: Bool -> ElementParams -> [InsertAt]
floatsElement Bool
isInner ElementParams
d
| ElementParams -> Text
elementName ElementParams
d Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Text
T.pack String
"html" Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isInner = [ReparentDepth -> InsertAt
RelativeLocation ReparentDepth
0, InsertAt
InHtmlElement]
| Bool
otherwise = [ReparentDepth -> InsertAt
RelativeLocation ReparentDepth
0]
incrementReparenting :: M.I.IntMap ReparentDepth -> M.I.IntMap ReparentDepth
incrementReparenting :: IntMap ReparentDepth -> IntMap ReparentDepth
incrementReparenting = (Key -> Key) -> IntMap ReparentDepth -> IntMap ReparentDepth
forall a. (Key -> Key) -> IntMap a -> IntMap a
M.I.mapKeys Key -> Key
forall a. Enum a => a -> a
succ
decrementReparenting :: M.I.IntMap ReparentDepth -> (ReparentDepth, M.I.IntMap ReparentDepth)
decrementReparenting :: IntMap ReparentDepth -> (ReparentDepth, IntMap ReparentDepth)
decrementReparenting IntMap ReparentDepth
ls = (ReparentDepth -> Maybe ReparentDepth -> ReparentDepth
forall a. a -> Maybe a -> a
Y.fromMaybe ReparentDepth
0 (Maybe ReparentDepth -> ReparentDepth)
-> Maybe ReparentDepth -> ReparentDepth
forall a b. (a -> b) -> a -> b
$ Key -> IntMap ReparentDepth -> Maybe ReparentDepth
forall a. Key -> IntMap a -> Maybe a
M.I.lookup Key
0 IntMap ReparentDepth
ls, (Key -> Key) -> IntMap ReparentDepth -> IntMap ReparentDepth
forall a. (Key -> Key) -> IntMap a -> IntMap a
M.I.mapKeys Key -> Key
forall a. Enum a => a -> a
pred (IntMap ReparentDepth -> IntMap ReparentDepth)
-> IntMap ReparentDepth -> IntMap ReparentDepth
forall a b. (a -> b) -> a -> b
$ Key -> IntMap ReparentDepth -> IntMap ReparentDepth
forall a. Key -> IntMap a -> IntMap a
M.I.delete Key
0 IntMap ReparentDepth
ls)
joinTexts :: [Either ([ParseError], Char) Tree] -> [Tree]
joinTexts :: [Either ([ParseError], Char) Tree] -> [Tree]
joinTexts [] = []
joinTexts (Right Tree
t : [Either ([ParseError], Char) Tree]
xs) = Tree
t Tree -> [Tree] -> [Tree]
forall a. a -> [a] -> [a]
: [Either ([ParseError], Char) Tree] -> [Tree]
joinTexts [Either ([ParseError], Char) Tree]
xs
joinTexts (Left ([ParseError], Char)
c : [Either ([ParseError], Char) Tree]
xs) = Tree
txt' Tree -> [Tree] -> [Tree]
forall a. a -> [a] -> [a]
: [Either ([ParseError], Char) Tree] -> [Tree]
joinTexts [Either ([ParseError], Char) Tree]
xs'
where ([Either ([ParseError], Char) Tree]
cs', [Either ([ParseError], Char) Tree]
xs') = (Either ([ParseError], Char) Tree -> Bool)
-> [Either ([ParseError], Char) Tree]
-> ([Either ([ParseError], Char) Tree],
[Either ([ParseError], Char) Tree])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Either ([ParseError], Char) Tree -> Bool
forall a b. Either a b -> Bool
E.isLeft [Either ([ParseError], Char) Tree]
xs
cs :: [([ParseError], Char)]
cs = (Either ([ParseError], Char) Tree -> ([ParseError], Char))
-> [Either ([ParseError], Char) Tree] -> [([ParseError], Char)]
forall a b. (a -> b) -> [a] -> [b]
map ((([ParseError], Char) -> ([ParseError], Char))
-> (Tree -> ([ParseError], Char))
-> Either ([ParseError], Char) Tree
-> ([ParseError], Char)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([ParseError], Char) -> ([ParseError], Char)
forall a. a -> a
id ((Tree -> ([ParseError], Char))
-> Either ([ParseError], Char) Tree -> ([ParseError], Char))
-> (Tree -> ([ParseError], Char))
-> Either ([ParseError], Char) Tree
-> ([ParseError], Char)
forall a b. (a -> b) -> a -> b
$ String -> Tree -> ([ParseError], Char)
forall a. HasCallStack => String -> a
error String
"unexpected 'Right' after @span isLeft@") [Either ([ParseError], Char) Tree]
cs'
([[ParseError]]
_, String
txt) = [([ParseError], Char)] -> ([[ParseError]], String)
forall a b. [(a, b)] -> ([a], [b])
unzip ([([ParseError], Char)] -> ([[ParseError]], String))
-> [([ParseError], Char)] -> ([[ParseError]], String)
forall a b. (a -> b) -> a -> b
$ ([ParseError], Char)
c ([ParseError], Char)
-> [([ParseError], Char)] -> [([ParseError], Char)]
forall a. a -> [a] -> [a]
: [([ParseError], Char)]
cs
txt' :: Tree
txt' = Tree
emptyTree
{ node :: Node
node = Text -> Node
Text (Text -> Node) -> Text -> Node
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
txt
}
packQuirks :: QuirksMode -> Tree
packQuirks :: QuirksMode -> Tree
packQuirks QuirksMode
mode = Tree
emptyTree
{ node :: Node
node = QuirksMode -> Node
Document QuirksMode
mode
}
packComment :: T.Text -> Tree
Text
txt = Tree
emptyTree
{ node :: Node
node = Text -> Node
Comment Text
txt
}
packDoctype :: DocumentTypeParams -> Tree
packDoctype :: DocumentTypeParams -> Tree
packDoctype DocumentTypeParams
dtd = Tree
emptyTree
{ node :: Node
node = DocumentTypeParams -> Node
DocumentType DocumentTypeParams
dtd
}
packElement :: ElementParams -> [Tree] -> Tree
packElement :: ElementParams -> [Tree] -> Tree
packElement ElementParams
tag [Tree]
childTrees
| Text -> ElementParams -> Bool
nodeIsElement (String -> Text
T.pack String
"template") ElementParams
tag = Tree
emptyTree
{ node :: Node
node = Node
e
, children :: [Tree]
children = [Tree
emptyTree
{ node :: Node
node = Node
DocumentFragment
, children :: [Tree]
children = [Tree]
childTrees
}]
}
| Bool
otherwise = Tree
emptyTree
{ node :: Node
node = Node
e
, children :: [Tree]
children = [Tree]
childTrees
}
where e :: Node
e = ElementParams -> Node
Element ElementParams
tag
packAttribute :: AttributeParams -> Tree
packAttribute :: AttributeParams -> Tree
packAttribute AttributeParams
attr = Tree
emptyTree
{ node :: Node
node = AttributeParams -> Node
Attribute AttributeParams
attr
}