{- |

Module : ./Common/XmlDiff.hs

Description : compute xml diffs

Copyright : (c) Christian Maeder, DFKI GmbH 2011

License : GPLv2 or higher, see LICENSE.txt

Maintainer : Christian.Maeder@dfki.de

Stability : provisional

Portability : portable

-}

module Common.XmlDiff where

import Common.ToXml

import Common.Utils as Utils

import Common.XPath

import Common.XUpdate

import Common.Lib.MapSet (setToMap)

import Data.List

import qualified Data.Set as Set

import qualified Data.Map as Map

import Text.XML.Light as XML

hetsTags :: UnordTags

hetsTags = Map.fromList

$ map (\ (e, as) -> (unqual e, Set.fromList $ map unqual as))

[ ("DGNode", ["name"])

, ("DGLink", ["linkid", "source", "target"])

, ("Axiom", [])

, ("Theorem", []) ]

{- for symbols the order matters. For axioms and theorems the names should be

stored separately -}

hetsXmlChanges :: Element -> Element -> [Change]

hetsXmlChanges e1 e2 = xmlDiff hetsTags [] Map.empty

[Elem $ cleanUpElem e1]

[Elem $ cleanUpElem e2]

hetsXmlDiff :: Element -> Element -> Element

hetsXmlDiff e = mkMods . hetsXmlChanges e

{- for elements, whose order does not matter, use the given attribute keys to

determine their equality. An empty set indicates an element that only contains

text to be compared. -}

type UnordTags = Map.Map QName (Set.Set QName)

-- keep track of the nth element with a given tag

type Count = Map.Map QName Int

{- we assume an element contains other elements and no text entries or just a

single text content -}

xmlDiff :: UnordTags -> [Step] -> Count -> [Content] -> [Content] -> [Change]

xmlDiff m stps em old new = case (old, filter validContent new) of

([], []) -> []

([], ns) ->

[Change (Add Append $ map contentToAddChange ns) $ pathToExpr stps]

(os, []) -> removeIns stps em os

(o : os, ns@(n : rt)) ->

if validContent o then

case o of

Elem e ->

let en = elName e

atts = elAttribs e

cs = elContent e

(nm, nstps) = extendPath en em stps

downDiffs = xmlElemDiff m nstps atts cs

restDiffs = xmlDiff m stps nm os

rmO = Change Remove (pathToExpr nstps) : restDiffs ns

in case Map.lookup en m of

Nothing -> case n of

Elem e2 | elName e2 == en ->

downDiffs e2

++ restDiffs rt

_ -> rmO

Just ats -> let

(mns, rns) = partition (matchElems en (strContent e) $

Map.intersection (attrMap atts) $ setToMap ats) ns

in case mns of

Elem mn : rm -> downDiffs mn

++ restDiffs (rm ++ rns)

_ -> rmO

XML.Text cd -> let inText = cdData cd in case n of

XML.Text cd2 | trim inText == trim nText

-> xmlDiff m stps em os rt

| otherwise -> Change (Update nText) (pathToExpr stps)

: xmlDiff m stps em os rt

where nText = cdData cd2

_ -> error "xmldiff2"

_ -> error "xmldiff"

else xmlDiff m stps em os ns

removeIns :: [Step] -> Count -> [Content] -> [Change]

removeIns stps em cs = case cs of

[] -> []

c : rs -> case c of

Elem e -> let

(nm, nstps) = extendPath (elName e) em stps

in Change Remove (pathToExpr nstps) : removeIns stps nm rs

_ -> Change (Update "") (pathToExpr stps) : removeIns stps em rs

-- does not work for multiple text entries

attrMap :: [Attr] -> Map.Map QName String

attrMap = Map.fromList . map (\ a -> (attrKey a, attrVal a))

matchElems :: QName -> String -> Map.Map QName String -> Content -> Bool

matchElems en t atts c = case c of

Elem e -> elName e == en

&& if Map.null atts then null (elChildren e) && strContent e == t else

Map.isSubmapOfBy (==) atts (attrMap $ elAttribs e)

_ -> False

xmlElemDiff :: UnordTags -> [Step] -> [Attr] -> [Content] -> Element -> [Change]

xmlElemDiff m nPath atts cs e2 = xmlAttrDiff nPath atts (elAttribs e2)

++ xmlDiff m nPath Map.empty cs (elContent e2)

xmlAttrDiff :: [Step] -> [Attr] -> [Attr] -> [Change]

xmlAttrDiff p a1 a2 = let

m1 = attrMap a1

m2 = attrMap a2

rms = Map.toList $ Map.difference m1 m2

ins = Map.toList $ Map.difference m2 m1

inter = Map.toList $ Map.filter (uncurry (/=))

$ Map.intersectionWith (,) m1 m2

addAttrStep a = pathToExpr $ Step Attribute (NameTest $ qName a) [] : p

in map (Change Remove . addAttrStep . fst) rms

++ map (\ (a, (_, v)) -> Change (Update v) $ addAttrStep a) inter

++ if null ins then [] else

[Change (Add Append $ map (AddAttr . uncurry Attr) ins) $ pathToExpr p]

pathToExpr :: [Step] -> Expr

pathToExpr = PathExpr Nothing . Path True . reverse

extendPath :: QName -> Count -> [Step] -> (Count, [Step])

extendPath en em stps = let

nm = Map.insertWith (+) en 1 em

i = Map.findWithDefault 1 en nm

nstps = Step Child (NameTest $ qName en) [PrimExpr Number $ show i] : stps

in (nm, nstps)

-- steps and predicates are reversed!

addPathNumber :: Int -> [Step] -> [Step]

addPathNumber i stps =

let e = PrimExpr Number $ show i

in case stps of

[] -> []

Step a n es : rs -> Step a n (e : es) : rs

contentToAddChange :: Content -> AddChange

contentToAddChange c = case c of

Elem e -> AddElem e

XML.Text t -> AddText $ cdData t

CRef s -> AddText s

mkXQName :: String -> QName

mkXQName s = (unqual s) { qPrefix = Just xupdateS }

changeToXml :: Change -> Element

changeToXml (Change csel pth) = let

sel = add_attr (mkAttr selectS $ show pth)

in case csel of

Add i as -> sel

. node (mkXQName $ showInsert i) $ map addsToXml as

Remove -> sel $ node (mkXQName removeS) ()

Update s -> sel $ node (mkXQName updateS) s

_ -> error "changeToXml"

addsToXml :: AddChange -> Content

addsToXml a = case a of

AddElem e -> Elem $ cleanUpElem e

AddAttr (Attr k v) -> Elem

. add_attr (mkNameAttr $ qName k) $ node (mkXQName attributeS) v

AddText s -> mkText s

_ -> error "addsToXml"

mkMods :: [Change] -> Element

mkMods = node (mkXQName "modifications") . map changeToXml