XmlDiff.hs

{- |
Module      :  $Header$
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