{-|
Module: IHP.ServerSideComponent.HtmlDiff
Copyright: (c) digitally induced GmbH, 2021
Description: Provides differences and patchsets between two HTML fragments
-}
module IHP.ServerSideComponent.HtmlDiff where

import IHP.Prelude
import IHP.ServerSideComponent.HtmlParser
import qualified Data.Text as Text

data NodeOperation
    = UpdateTextContent { NodeOperation -> Text
textContent :: !Text, NodeOperation -> [Int]
path :: ![Int] }
    | ReplaceNode { NodeOperation -> Node
oldNode :: !Node, NodeOperation -> Node
newNode :: !Node, NodeOperation -> Text
newNodeHtml :: !Text, path :: ![Int] }
    | UpdateNode { NodeOperation -> [AttributeOperation]
attributeOperations :: ![AttributeOperation], path :: ![Int] }
    | UpdateComment { NodeOperation -> Text
comment :: !Text, path :: ![Int] }
    | UpdatePreEscapedTextNode { textContent :: !Text, path :: ![Int] }
    | DeleteNode { NodeOperation -> Node
node :: !Node, path :: ![Int] }
    | CreateNode { NodeOperation -> Text
html :: !Text, path :: ![Int] }
    deriving (NodeOperation -> NodeOperation -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NodeOperation -> NodeOperation -> Bool
$c/= :: NodeOperation -> NodeOperation -> Bool
== :: NodeOperation -> NodeOperation -> Bool
$c== :: NodeOperation -> NodeOperation -> Bool
Eq, Int -> NodeOperation -> ShowS
[NodeOperation] -> ShowS
NodeOperation -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NodeOperation] -> ShowS
$cshowList :: [NodeOperation] -> ShowS
show :: NodeOperation -> String
$cshow :: NodeOperation -> String
showsPrec :: Int -> NodeOperation -> ShowS
$cshowsPrec :: Int -> NodeOperation -> ShowS
Show)

data AttributeOperation
    = UpdateAttribute { AttributeOperation -> Text
attributeName :: !Text, AttributeOperation -> Text
attributeValue :: !Text }
    | AddAttribute { attributeName :: !Text, attributeValue :: !Text }
    | DeleteAttribute { attributeName :: !Text }
    deriving (AttributeOperation -> AttributeOperation -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AttributeOperation -> AttributeOperation -> Bool
$c/= :: AttributeOperation -> AttributeOperation -> Bool
== :: AttributeOperation -> AttributeOperation -> Bool
$c== :: AttributeOperation -> AttributeOperation -> Bool
Eq, Int -> AttributeOperation -> ShowS
[AttributeOperation] -> ShowS
AttributeOperation -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AttributeOperation] -> ShowS
$cshowList :: [AttributeOperation] -> ShowS
show :: AttributeOperation -> String
$cshow :: AttributeOperation -> String
showsPrec :: Int -> AttributeOperation -> ShowS
$cshowsPrec :: Int -> AttributeOperation -> ShowS
Show)

diffHtml :: Text -> Text -> Either _ [NodeOperation]
diffHtml :: Text -> Text -> Either (ParseErrorBundle Text Void) [NodeOperation]
diffHtml Text
a Text
b = do
    Node
nodeA <- Text -> Either (ParseErrorBundle Text Void) Node
parseHtml Text
a
    Node
nodeB <- Text -> Either (ParseErrorBundle Text Void) Node
parseHtml Text
b

    let ?oldHtml = Text
a
    let ?newHtml = Text
b

    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall text.
(?oldHtml::text, ?newHtml::Text) =>
Node -> Node -> [NodeOperation]
diffNodes Node
nodeA Node
nodeB)

type Path = [Int]

diffNodes :: (?oldHtml :: text, ?newHtml :: Text) => Node -> Node -> [NodeOperation]
diffNodes :: forall text.
(?oldHtml::text, ?newHtml::Text) =>
Node -> Node -> [NodeOperation]
diffNodes = forall text.
(?oldHtml::text, ?newHtml::Text) =>
[Int] -> Node -> Node -> [NodeOperation]
diffNodes' []

diffNodes' :: (?oldHtml :: text, ?newHtml :: Text) => Path -> Node -> Node -> [NodeOperation]
diffNodes' :: forall text.
(?oldHtml::text, ?newHtml::Text) =>
[Int] -> Node -> Node -> [NodeOperation]
diffNodes' [Int]
path TextNode { $sel:textContent:Node :: Node -> Text
textContent = Text
oldTextContent } TextNode { $sel:textContent:Node :: Node -> Text
textContent = Text
newTextContent } =
        if Text
oldTextContent forall a. Eq a => a -> a -> Bool
== Text
newTextContent
            then []
            else [UpdateTextContent { $sel:textContent:UpdateTextContent :: Text
textContent = Text
newTextContent, [Int]
path :: [Int]
$sel:path:UpdateTextContent :: [Int]
path }]
diffNodes' [Int]
path CommentNode { $sel:comment:Node :: Node -> Text
comment = Text
oldComment } CommentNode { $sel:comment:Node :: Node -> Text
comment = Text
newComment } =
        if Text
oldComment forall a. Eq a => a -> a -> Bool
== Text
newComment
            then []
            else [UpdateComment { $sel:comment:UpdateTextContent :: Text
comment = Text
newComment, [Int]
path :: [Int]
$sel:path:UpdateTextContent :: [Int]
path }]
diffNodes' [Int]
path PreEscapedTextNode { $sel:textContent:Node :: Node -> Text
textContent = Text
oldTextContent } PreEscapedTextNode { $sel:textContent:Node :: Node -> Text
textContent = Text
newTextContent } =
        if Text
oldTextContent forall a. Eq a => a -> a -> Bool
== Text
newTextContent
            then []
            else [UpdatePreEscapedTextNode { $sel:textContent:UpdateTextContent :: Text
textContent = Text
newTextContent, [Int]
path :: [Int]
$sel:path:UpdateTextContent :: [Int]
path }]
diffNodes' [Int]
path oldNode :: Node
oldNode@(Node { $sel:tagName:Node :: Node -> Text
tagName = Text
oldTagName, $sel:attributes:Node :: Node -> [Attribute]
attributes = [Attribute]
oldAttributes, $sel:children:Node :: Node -> [Node]
children = [Node]
oldChildren }) newNode :: Node
newNode@(Node { $sel:tagName:Node :: Node -> Text
tagName = Text
newTagName, $sel:attributes:Node :: Node -> [Attribute]
attributes = [Attribute]
newAttributes, $sel:children:Node :: Node -> [Node]
children = [Node]
newChildren }) =
    if Text
oldTagName forall a. Eq a => a -> a -> Bool
== Text
newTagName
        then
            let
                attributeOperations :: [AttributeOperation]
attributeOperations = [Attribute] -> [Attribute] -> [AttributeOperation]
diffAttributes [Attribute]
oldAttributes [Attribute]
newAttributes
                childrenNodeOperations :: [NodeOperation]
childrenNodeOperations = forall text.
(?oldHtml::text, ?newHtml::Text) =>
[Int] -> Node -> Node -> [NodeOperation]
diffNodes' [Int]
path Children { $sel:children:Node :: [Node]
children = [Node]
oldChildren } Children { $sel:children:Node :: [Node]
children = [Node]
newChildren }
            in forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
                    if forall value. IsEmpty value => value -> Bool
isEmpty [AttributeOperation]
attributeOperations
                        then []
                        else [UpdateNode { [AttributeOperation]
attributeOperations :: [AttributeOperation]
$sel:attributeOperations:UpdateTextContent :: [AttributeOperation]
attributeOperations, [Int]
path :: [Int]
$sel:path:UpdateTextContent :: [Int]
path }]
                    , [NodeOperation]
childrenNodeOperations
                    ]

        else [ReplaceNode { Node
oldNode :: Node
$sel:oldNode:UpdateTextContent :: Node
oldNode, Node
newNode :: Node
$sel:newNode:UpdateTextContent :: Node
newNode, $sel:newNodeHtml:UpdateTextContent :: Text
newNodeHtml = Node -> Text -> Text
nodeOuterHtml Node
newNode ?newHtml::Text
?newHtml, [Int]
path :: [Int]
$sel:path:UpdateTextContent :: [Int]
path }]
diffNodes' [Int]
path Children { $sel:children:Node :: Node -> [Node]
children = [Node]
oldChildren } Children { $sel:children:Node :: Node -> [Node]
children = [Node]
newChildren } =
        let
            patchElements :: [Node] -> [Node] -> Int -> [NodeOperation]
            patchElements :: [Node] -> [Node] -> Int -> [NodeOperation]
patchElements (Node
new:Node
nextNewNode:[Node]
newRest) (Node
old:[Node]
oldRest) !Int
index | (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Node
new Node -> Node -> Bool
`isNodeEqIgnoringPosition` Node
old) Bool -> Bool -> Bool
&& (Node
old Node -> Node -> Bool
`isNodeEqIgnoringPosition` Node
nextNewNode) = [ CreateNode { $sel:html:UpdateTextContent :: Text
html = Node -> Text -> Text
nodeOuterHtml Node
new ?newHtml::Text
?newHtml, $sel:path:UpdateTextContent :: [Int]
path = (Int
indexforall a. a -> [a] -> [a]
:[Int]
path) } ] forall a. Semigroup a => a -> a -> a
<> ([Node] -> [Node] -> Int -> [NodeOperation]
patchElements ([Node]
newRest) ([Node]
oldRest) (Int
index forall a. Num a => a -> a -> a
+ Int
2)) -- [A, C <old>] -> [A, B <new>, C <nextNewNode>]
            patchElements (Node
new:[Node]
newRest) (Node
old:Node
nextOld:[Node]
oldRest) !Int
index | (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Node
new Node -> Node -> Bool
`isNodeEqIgnoringPosition` Node
old) Bool -> Bool -> Bool
&& (Node
new Node -> Node -> Bool
`isNodeEqIgnoringPosition` Node
nextOld) = [ DeleteNode { $sel:node:UpdateTextContent :: Node
node = Node
old, $sel:path:UpdateTextContent :: [Int]
path = (Int
indexforall a. a -> [a] -> [a]
:[Int]
path) } ] forall a. Semigroup a => a -> a -> a
<> ([Node] -> [Node] -> Int -> [NodeOperation]
patchElements ([Node]
newRest) ([Node]
oldRest) (Int
index forall a. Num a => a -> a -> a
+ Int
1)) -- [A, B <old>, C <nextOldNode> ] -> [A, C <new>]
            patchElements (Node
new:[Node]
newRest) (Node
old:[Node]
oldRest) !Int
index = (forall text.
(?oldHtml::text, ?newHtml::Text) =>
[Int] -> Node -> Node -> [NodeOperation]
diffNodes' (Int
indexforall a. a -> [a] -> [a]
:[Int]
path) Node
old Node
new) forall a. Semigroup a => a -> a -> a
<> ([Node] -> [Node] -> Int -> [NodeOperation]
patchElements [Node]
newRest [Node]
oldRest (Int
index forall a. Num a => a -> a -> a
+ Int
1))
            patchElements (Node
new:[Node]
newRest) [] !Int
index = [ CreateNode { $sel:html:UpdateTextContent :: Text
html = Node -> Text -> Text
nodeOuterHtml Node
new ?newHtml::Text
?newHtml, $sel:path:UpdateTextContent :: [Int]
path = (Int
indexforall a. a -> [a] -> [a]
:[Int]
path) } ] forall a. Semigroup a => a -> a -> a
<> ([Node] -> [Node] -> Int -> [NodeOperation]
patchElements [Node]
newRest [] (Int
index forall a. Num a => a -> a -> a
+ Int
1))
            patchElements [] (Node
old:[Node]
oldRest) !Int
index = [ DeleteNode { $sel:node:UpdateTextContent :: Node
node = Node
old, $sel:path:UpdateTextContent :: [Int]
path = (Int
indexforall a. a -> [a] -> [a]
:[Int]
path) } ] forall a. Semigroup a => a -> a -> a
<> ([Node] -> [Node] -> Int -> [NodeOperation]
patchElements [] [Node]
oldRest (Int
index forall a. Num a => a -> a -> a
+ Int
1))
            patchElements [] [] Int
_ = []
        in
            [Node] -> [Node] -> Int -> [NodeOperation]
patchElements [Node]
newChildren [Node]
oldChildren Int
0
diffNodes' [Int]
path Node
oldNode Node
newNode = [ReplaceNode { Node
oldNode :: Node
$sel:oldNode:UpdateTextContent :: Node
oldNode, Node
newNode :: Node
$sel:newNode:UpdateTextContent :: Node
newNode, $sel:newNodeHtml:UpdateTextContent :: Text
newNodeHtml = Node -> Text -> Text
nodeOuterHtml Node
newNode ?newHtml::Text
?newHtml, [Int]
path :: [Int]
$sel:path:UpdateTextContent :: [Int]
path }]


diffAttributes :: [Attribute] -> [Attribute] -> [AttributeOperation]
diffAttributes :: [Attribute] -> [Attribute] -> [AttributeOperation]
diffAttributes [Attribute]
old [Attribute]
new = [AttributeOperation]
addOrUpdateAttributes forall a. Semigroup a => a -> a -> a
<> [AttributeOperation]
deleteAttributes
    where
        addOrUpdateAttributes :: [AttributeOperation]
        addOrUpdateAttributes :: [AttributeOperation]
addOrUpdateAttributes =
                [Attribute]
new
                forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a b. (a -> b) -> [a] -> [b]
map ([Attribute] -> Attribute -> Maybe Attribute
matchAttribute [Attribute]
old)
                forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a b. [a] -> [b] -> [(a, b)]
zip [Attribute]
new
                forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Attribute, Maybe Attribute) -> Maybe AttributeOperation
diffMatchedAttribute

        deleteAttributes :: [AttributeOperation]
        deleteAttributes :: [AttributeOperation]
deleteAttributes =
                [Attribute]
old
                forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a b. (a -> b) -> [a] -> [b]
map ([Attribute] -> Attribute -> Maybe Attribute
matchAttribute [Attribute]
new)
                forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a b. [a] -> [b] -> [(a, b)]
zip [Attribute]
old
                forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a. (a -> Bool) -> [a] -> [a]
filter (\(Attribute
_, Maybe Attribute
newAttribute) -> forall a. Maybe a -> Bool
isNothing Maybe Attribute
newAttribute)
                forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a b. (a -> b) -> [a] -> [b]
map (\(Attribute { Text
$sel:attributeName:Attribute :: Attribute -> Text
attributeName :: Text
attributeName }, Maybe Attribute
_) -> DeleteAttribute { Text
attributeName :: Text
$sel:attributeName:UpdateAttribute :: Text
attributeName })

        diffMatchedAttribute :: (Attribute, Maybe Attribute) -> Maybe AttributeOperation
        diffMatchedAttribute :: (Attribute, Maybe Attribute) -> Maybe AttributeOperation
diffMatchedAttribute (Attribute { Text
attributeName :: Text
$sel:attributeName:Attribute :: Attribute -> Text
attributeName, $sel:attributeValue:Attribute :: Attribute -> Text
attributeValue = Text
newValue }, Just Attribute { $sel:attributeValue:Attribute :: Attribute -> Text
attributeValue = Text
oldValue }) | Text
newValue forall a. Eq a => a -> a -> Bool
== Text
oldValue = forall a. Maybe a
Nothing
        diffMatchedAttribute (Attribute { Text
attributeName :: Text
$sel:attributeName:Attribute :: Attribute -> Text
attributeName, $sel:attributeValue:Attribute :: Attribute -> Text
attributeValue = Text
newValue }, Just Attribute { $sel:attributeValue:Attribute :: Attribute -> Text
attributeValue = Text
oldValue }) = forall a. a -> Maybe a
Just UpdateAttribute { Text
attributeName :: Text
$sel:attributeName:UpdateAttribute :: Text
attributeName, $sel:attributeValue:UpdateAttribute :: Text
attributeValue = Text
newValue }
        diffMatchedAttribute (Attribute { Text
attributeName :: Text
$sel:attributeName:Attribute :: Attribute -> Text
attributeName, Text
attributeValue :: Text
$sel:attributeValue:Attribute :: Attribute -> Text
attributeValue }, Maybe Attribute
Nothing) = forall a. a -> Maybe a
Just AddAttribute { Text
attributeName :: Text
$sel:attributeName:UpdateAttribute :: Text
attributeName, Text
attributeValue :: Text
$sel:attributeValue:UpdateAttribute :: Text
attributeValue }

        -- | Finds an attribute in 'old' with the same attribute name
        matchAttribute :: [Attribute] -> Attribute -> Maybe Attribute
        matchAttribute :: [Attribute] -> Attribute -> Maybe Attribute
matchAttribute [Attribute]
attributes Attribute { Text
attributeName :: Text
$sel:attributeName:Attribute :: Attribute -> Text
attributeName } = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Attribute { $sel:attributeName:Attribute :: Attribute -> Text
attributeName = Text
attributeName' } -> Text
attributeName forall a. Eq a => a -> a -> Bool
== Text
attributeName' ) [Attribute]
attributes

-- | Grabs the entire HTML string corresponding to the node boundaries.
--
-- Node boundaries are only stored for 'Node'. Other nodes ('TextNode', etc) don't store start/end offset, so we render
-- them by ourselves.
nodeOuterHtml :: Node -> Text -> Text
nodeOuterHtml :: Node -> Text -> Text
nodeOuterHtml Node { Int
$sel:startOffset:Node :: Node -> Int
startOffset :: Int
startOffset, Int
$sel:endOffset:Node :: Node -> Int
endOffset :: Int
endOffset } Text
html = Text
html
        forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Int -> Text -> Text
Text.drop Int
startOffset
        forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Int -> Text -> Text
Text.take (Int
endOffset forall a. Num a => a -> a -> a
- Int
startOffset)
-- Assuming chars are already escaped, because that's what HSX produces
nodeOuterHtml TextNode { Text
textContent :: Text
$sel:textContent:Node :: Node -> Text
textContent } Text
_ = Text
textContent
nodeOuterHtml PreEscapedTextNode { Text
textContent :: Text
$sel:textContent:Node :: Node -> Text
textContent } Text
_ = Text
textContent
nodeOuterHtml Children { [Node]
children :: [Node]
$sel:children:Node :: Node -> [Node]
children } Text
html = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Node -> Text -> Text
`nodeOuterHtml` Text
html) [Node]
children
nodeOuterHtml CommentNode { Text
comment :: Text
$sel:comment:Node :: Node -> Text
comment } Text
_ = Text
"<!--" forall a. Semigroup a => a -> a -> a
<> Text
comment forall a. Semigroup a => a -> a -> a
<> Text
"-->"

isNodeEqIgnoringPosition :: Node -> Node -> Bool
isNodeEqIgnoringPosition :: Node -> Node -> Bool
isNodeEqIgnoringPosition a :: Node
a@(Node {}) b :: Node
b@(Node {}) = (Node
a { $sel:startOffset:Node :: Int
startOffset = Int
0, $sel:endOffset:Node :: Int
endOffset = Int
0 }) forall a. Eq a => a -> a -> Bool
== (Node
b { $sel:startOffset:Node :: Int
startOffset = Int
0, $sel:endOffset:Node :: Int
endOffset = Int
0 })
isNodeEqIgnoringPosition Node
a Node
b = Node
a forall a. Eq a => a -> a -> Bool
== Node
b