XmlDiff.hs revision 57dc8a87418e235e3d0621fb90728054044a9ef9
e9458b1a7a19a63aa4c179f9ab20f4d50681c168Jens ElknerModule : $Header$
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaederDescription : compute xml diffs
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaederCopyright : (c) Christian Maeder, DFKI GmbH 2011
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaederLicense : GPLv2 or higher, see LICENSE.txt
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaederMaintainer : Christian.Maeder@dfki.de
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaederStability : provisional
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaederPortability : portable
89026e63176e6e40c7be1bbc542326f0d29d8108Christian Maederimport qualified Data.Set as Set
89026e63176e6e40c7be1bbc542326f0d29d8108Christian Maederimport qualified Data.Map as Map
770abb9d4554f378acbae393b25f8687eeeb3ad0Christian Maeder{- for elements, whose order does not matter, use the given attribute keys to
770abb9d4554f378acbae393b25f8687eeeb3ad0Christian Maederdetermine their equality. -}
770abb9d4554f378acbae393b25f8687eeeb3ad0Christian Maedertype UnordTags = Map.Map QName (Set.Set QName)
770abb9d4554f378acbae393b25f8687eeeb3ad0Christian MaederxmlDiff :: UnordTags -> [Step] -> Int -> [Content] -> [Content] -> [Change]
770abb9d4554f378acbae393b25f8687eeeb3ad0Christian MaederxmlDiff m pth i old new = let
770abb9d4554f378acbae393b25f8687eeeb3ad0Christian Maeder np = addPathNumber (i + 1) pth
770abb9d4554f378acbae393b25f8687eeeb3ad0Christian Maeder pe = pathToExpr np
770abb9d4554f378acbae393b25f8687eeeb3ad0Christian Maeder in case (old, filter validContent new) of
770abb9d4554f378acbae393b25f8687eeeb3ad0Christian Maeder ([], []) -> []
770abb9d4554f378acbae393b25f8687eeeb3ad0Christian Maeder [Change (Add Append $ map contentToAddChange ns) pe]
770abb9d4554f378acbae393b25f8687eeeb3ad0Christian Maeder (os, []) -> map
770abb9d4554f378acbae393b25f8687eeeb3ad0Christian Maeder (\ (_, j) -> Change Remove $ pathToExpr $ addPathNumber (i + j) pth)
770abb9d4554f378acbae393b25f8687eeeb3ad0Christian Maeder (o : os, ns@(n : rt)) -> let
770abb9d4554f378acbae393b25f8687eeeb3ad0Christian Maeder restDiffs = xmlDiff m pth (i + 1) os
89026e63176e6e40c7be1bbc542326f0d29d8108Christian Maeder rmO = Change Remove pe : restDiffs ns
79e28be65fd0bc65adf266d5ae4f6deb92546bf7Christian Maeder in if validContent o then
89026e63176e6e40c7be1bbc542326f0d29d8108Christian Maeder let en = elName e
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian Maeder atts = elAttribs e
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian Maeder cs = elContent e
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian Maeder nPath = extendPath en np
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian Maeder in case Map.lookup en m of
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian Maeder Nothing -> case n of
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian Maeder Elem e2 | elName e2 == en ->
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian Maeder xmlElemDiff m nPath atts cs e2
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian Maeder ++ restDiffs rt
89026e63176e6e40c7be1bbc542326f0d29d8108Christian Maeder Just ats -> let
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian Maeder (mns, rns) = partition (matchElems en $
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian Maeder Map.intersection (attrMap atts) $ setToMap ats) ns
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian Maeder in case mns of
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian Maeder Elem mn : rm -> xmlElemDiff m nPath atts cs mn
89026e63176e6e40c7be1bbc542326f0d29d8108Christian Maeder ++ restDiffs (rm ++ rns)
89026e63176e6e40c7be1bbc542326f0d29d8108Christian Maeder XML.Text cd -> case n of
89026e63176e6e40c7be1bbc542326f0d29d8108Christian Maeder XML.Text cd2 | trim (cdData cd) == trim nText
89026e63176e6e40c7be1bbc542326f0d29d8108Christian Maeder -> restDiffs rt
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian Maeder | otherwise -> Change (Update nText) pe : restDiffs rt
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian Maeder where nText = cdData cd2
89026e63176e6e40c7be1bbc542326f0d29d8108Christian Maeder else restDiffs ns
89026e63176e6e40c7be1bbc542326f0d29d8108Christian MaederattrMap :: [Attr] -> Map.Map QName String
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian MaederattrMap = Map.fromList . map (\ a -> (attrKey a, attrVal a))
89026e63176e6e40c7be1bbc542326f0d29d8108Christian MaedermatchElems :: QName -> Map.Map QName String -> Content -> Bool
89026e63176e6e40c7be1bbc542326f0d29d8108Christian MaedermatchElems en atts c = case c of
79e28be65fd0bc65adf266d5ae4f6deb92546bf7Christian Maeder Elem e | elName e == en
89026e63176e6e40c7be1bbc542326f0d29d8108Christian Maeder && Map.isSubmapOfBy (==) atts (attrMap $ elAttribs e) -> True
89026e63176e6e40c7be1bbc542326f0d29d8108Christian MaederxmlElemDiff :: UnordTags -> [Step] -> [Attr] -> [Content] -> Element -> [Change]
89026e63176e6e40c7be1bbc542326f0d29d8108Christian MaederxmlElemDiff m nPath atts cs e2 = xmlAttrDiff nPath atts (elAttribs e2)
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian Maeder ++ xmlDiff m nPath 0 cs (elContent e2)
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian MaederxmlAttrDiff :: [Step] -> [Attr] -> [Attr] -> [Change]
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian MaederxmlAttrDiff p a1 a2 = let
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian Maeder m1 = attrMap a1
57dc8a87418e235e3d0621fb90728054044a9ef9Christian Maeder m2 = attrMap a2
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian Maeder inter = Map.toList $ Map.filter (uncurry (/=))
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian Maeder addAttrStep a = pathToExpr $ Step Attribute (NameTest $ qName a) [] : p
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian Maeder in map (Change Remove . addAttrStep . fst) rms
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian Maeder ++ map (\ (a, (_, v)) -> Change (Update v) $ addAttrStep a) inter
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian Maeder ++ if null ins then [] else
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian Maeder [Change (Add Append $ map (AddAttr . uncurry Attr) ins) $ pathToExpr p]
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian MaederpathToExpr :: [Step] -> Expr
1ba51e89f63278f541a547315926a05f92c676ffChristian MaederpathToExpr = PathExpr Nothing . Path True . reverse
89026e63176e6e40c7be1bbc542326f0d29d8108Christian MaederextendPath :: QName -> [Step] -> [Step]
89026e63176e6e40c7be1bbc542326f0d29d8108Christian MaederextendPath q = (Step Child (NameTest $ qName q) [] :)
89026e63176e6e40c7be1bbc542326f0d29d8108Christian Maeder-- steps and predicates are reversed!
79e28be65fd0bc65adf266d5ae4f6deb92546bf7Christian MaederaddPathNumber :: Int -> [Step] -> [Step]
79e28be65fd0bc65adf266d5ae4f6deb92546bf7Christian MaederaddPathNumber i stps =
79e28be65fd0bc65adf266d5ae4f6deb92546bf7Christian Maeder let e = PrimExpr Number $ show i
79e28be65fd0bc65adf266d5ae4f6deb92546bf7Christian Maeder in case stps of
89026e63176e6e40c7be1bbc542326f0d29d8108Christian Maeder Step a n es : rs -> Step a n (e : es) : rs
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaedervalidContent :: Content -> Bool
89026e63176e6e40c7be1bbc542326f0d29d8108Christian MaedervalidContent c = case c of
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian Maeder XML.Text t | all isSpace $ cdData t -> False
89026e63176e6e40c7be1bbc542326f0d29d8108Christian Maeder CRef _ -> False -- we cannot handle this
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaedercontentToAddChange :: Content -> AddChange
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaedercontentToAddChange c = case c of
57dc8a87418e235e3d0621fb90728054044a9ef9Christian Maeder Elem e -> AddElem e
57dc8a87418e235e3d0621fb90728054044a9ef9Christian Maeder XML.Text t -> AddText $ cdData t
57dc8a87418e235e3d0621fb90728054044a9ef9Christian Maeder CRef s -> AddText s
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaedermkXQName :: String -> QName
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaedermkXQName s = (unqual s) { qPrefix = Just xupdateS }
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaederchangeToXml :: Change -> Element
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaederchangeToXml (Change csel pth) = let
89026e63176e6e40c7be1bbc542326f0d29d8108Christian Maeder sel = add_attr (mkAttr selectS $ show pth)
57dc8a87418e235e3d0621fb90728054044a9ef9Christian Maeder in case csel of
57dc8a87418e235e3d0621fb90728054044a9ef9Christian Maeder Add _ as -> sel
89026e63176e6e40c7be1bbc542326f0d29d8108Christian Maeder . node (mkXQName appendS) $ map addsToXml as
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian Maeder Remove -> sel $ node (mkXQName removeS) ()
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian Maeder Update s -> sel $ node (mkXQName updateS) s
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian Maeder _ -> error "changeToXml"
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian MaederaddsToXml :: AddChange -> Content
5b55761e0df088c5b41183fb83106bfd02a61fa2Christian MaederaddsToXml a = case a of
89026e63176e6e40c7be1bbc542326f0d29d8108Christian Maeder AddElem e -> Elem e
89026e63176e6e40c7be1bbc542326f0d29d8108Christian Maeder AddAttr (Attr k v) -> Elem
57dc8a87418e235e3d0621fb90728054044a9ef9Christian Maeder . add_attr (mkNameAttr $ qName k) $ node (mkXQName attributeS) v
57dc8a87418e235e3d0621fb90728054044a9ef9Christian Maeder AddText s -> mkText s
89026e63176e6e40c7be1bbc542326f0d29d8108Christian Maeder _ -> error "addsToXml"
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaedermkMods :: [Change] -> Element
89026e63176e6e40c7be1bbc542326f0d29d8108Christian MaedermkMods = node (mkXQName "modifications") . map changeToXml