XmlDiff.hs revision 5b55761e0df088c5b41183fb83106bfd02a61fa2
f062ed7bd262a37a909dd77ce5fc23b446818823fieldingModule : $Header$
f062ed7bd262a37a909dd77ce5fc23b446818823fieldingDescription : compute xml diffs
b99dbaab171d91e1b664397cc40e039d0c087c65fieldingCopyright : (c) Christian Maeder, DFKI GmbH 2011
f062ed7bd262a37a909dd77ce5fc23b446818823fieldingLicense : GPLv2 or higher, see LICENSE.txt
2d2eda71267231c2526be701fe655db125852c1ffieldingMaintainer : Christian.Maeder@dfki.de
2d2eda71267231c2526be701fe655db125852c1ffieldingStability : provisional
2d2eda71267231c2526be701fe655db125852c1ffieldingPortability : portable
2d2eda71267231c2526be701fe655db125852c1ffieldingimport Common.Utils as Utils
f062ed7bd262a37a909dd77ce5fc23b446818823fieldingimport Common.Lib.MapSet (setToMap)
f062ed7bd262a37a909dd77ce5fc23b446818823fieldingimport qualified Data.Set as Set
f062ed7bd262a37a909dd77ce5fc23b446818823fieldingimport qualified Data.Map as Map
f062ed7bd262a37a909dd77ce5fc23b446818823fielding{- for elements, whose order does not matter, use the given attribute keys to
f062ed7bd262a37a909dd77ce5fc23b446818823fieldingdetermine their equality. -}
f062ed7bd262a37a909dd77ce5fc23b446818823fielding-- keep track of the nth element with a given tag
64185f9824e42f21ca7b9ae6c004484215c031a7rbbtype Count = Map.Map QName Int
f062ed7bd262a37a909dd77ce5fc23b446818823fielding{- we assume an element contains other elements and no text entries or just a
f062ed7bd262a37a909dd77ce5fc23b446818823fieldingsingle text content -}
f062ed7bd262a37a909dd77ce5fc23b446818823fieldingxmlDiff :: UnordTags -> [Step] -> Count -> [Content] -> [Content] -> [Change]
2d2eda71267231c2526be701fe655db125852c1ffieldingxmlDiff m stps em old new = case (old, filter validContent new) of
f062ed7bd262a37a909dd77ce5fc23b446818823fielding ([], []) -> []
f062ed7bd262a37a909dd77ce5fc23b446818823fielding ([], ns) ->
f062ed7bd262a37a909dd77ce5fc23b446818823fielding [Change (Add Append $ map contentToAddChange ns) $ pathToExpr stps]
f062ed7bd262a37a909dd77ce5fc23b446818823fielding (os, []) -> removeIns stps em os
f062ed7bd262a37a909dd77ce5fc23b446818823fielding (o : os, ns@(n : rt)) ->
f062ed7bd262a37a909dd77ce5fc23b446818823fielding if validContent o then
2d2eda71267231c2526be701fe655db125852c1ffielding let en = elName e
2d2eda71267231c2526be701fe655db125852c1ffielding atts = elAttribs e
f062ed7bd262a37a909dd77ce5fc23b446818823fielding cs = elContent e
f062ed7bd262a37a909dd77ce5fc23b446818823fielding (nm, nstps) = extendPath en em stps
f062ed7bd262a37a909dd77ce5fc23b446818823fielding downDiffs = xmlElemDiff m nstps atts cs
2d2eda71267231c2526be701fe655db125852c1ffielding restDiffs = xmlDiff m stps nm os
f062ed7bd262a37a909dd77ce5fc23b446818823fielding rmO = Change Remove (pathToExpr nstps) : restDiffs ns
f062ed7bd262a37a909dd77ce5fc23b446818823fielding in case Map.lookup en m of
f062ed7bd262a37a909dd77ce5fc23b446818823fielding Nothing -> case n of
2d2eda71267231c2526be701fe655db125852c1ffielding Elem e2 | elName e2 == en ->
2d2eda71267231c2526be701fe655db125852c1ffielding downDiffs e2
2d2eda71267231c2526be701fe655db125852c1ffielding ++ restDiffs rt
2d2eda71267231c2526be701fe655db125852c1ffielding Just ats -> let
fcc25eda7b150e226d3c1cdaea66a943d3fdee4erbb (mns, rns) = partition (matchElems en $
b980ad7fdc218b4855cde9f75a747527f50c554dwrowe Map.intersection (attrMap atts) $ setToMap ats) ns
ab5581cc78e9d865b0a6ab1404c53347b3276968rbb in case mns of
92f3af936ce61f25358a3ee4f28df2f6d62040dfdreid Elem mn : rm -> downDiffs mn
fcc25eda7b150e226d3c1cdaea66a943d3fdee4erbb ++ restDiffs (rm ++ rns)
fd0edaa8e3d4dd67d0604ccef2e96b071db96643fielding XML.Text cd -> let inText = cdData cd in case n of
2d2eda71267231c2526be701fe655db125852c1ffielding XML.Text cd2 | trim inText == trim nText
2d2eda71267231c2526be701fe655db125852c1ffielding -> xmlDiff m stps em os rt
2d2eda71267231c2526be701fe655db125852c1ffielding | otherwise -> Change (Update nText) (pathToExpr stps)
2d2eda71267231c2526be701fe655db125852c1ffielding : xmlDiff m stps em os rt
61fd0cab072a05b855cbef9c585702401ac5ae29rbb where nText = cdData cd2
61fd0cab072a05b855cbef9c585702401ac5ae29rbb _ -> error "xmldiff2"
61fd0cab072a05b855cbef9c585702401ac5ae29rbb _ -> error "xmldiff"
61fd0cab072a05b855cbef9c585702401ac5ae29rbb else xmlDiff m stps em os ns
2d2eda71267231c2526be701fe655db125852c1ffieldingremoveIns :: [Step] -> Count -> [Content] -> [Change]
2d2eda71267231c2526be701fe655db125852c1ffieldingremoveIns stps em cs = case cs of
2d2eda71267231c2526be701fe655db125852c1ffielding c : rs -> case c of
61fd0cab072a05b855cbef9c585702401ac5ae29rbb Elem e -> let
61fd0cab072a05b855cbef9c585702401ac5ae29rbb (nm, nstps) = extendPath (elName e) em stps
61fd0cab072a05b855cbef9c585702401ac5ae29rbb in Change Remove (pathToExpr nstps) : removeIns stps nm rs
61fd0cab072a05b855cbef9c585702401ac5ae29rbb _ -> removeIns stps em rs
2d2eda71267231c2526be701fe655db125852c1ffieldingattrMap :: [Attr] -> Map.Map QName String
2d2eda71267231c2526be701fe655db125852c1ffieldingattrMap = Map.fromList . map (\ a -> (attrKey a, attrVal a))
bfb62a96023822c56c9120e4ee627d4091cc59c2rbbmatchElems :: QName -> Map.Map QName String -> Content -> Bool
61fd0cab072a05b855cbef9c585702401ac5ae29rbbmatchElems en atts c = case c of
61fd0cab072a05b855cbef9c585702401ac5ae29rbb Elem e | elName e == en
61fd0cab072a05b855cbef9c585702401ac5ae29rbb && Map.isSubmapOfBy (==) atts (attrMap $ elAttribs e) -> True
61fd0cab072a05b855cbef9c585702401ac5ae29rbb _ -> False
61fd0cab072a05b855cbef9c585702401ac5ae29rbbxmlElemDiff :: UnordTags -> [Step] -> [Attr] -> [Content] -> Element -> [Change]
3d96ee83babeec32482c9082c9426340cee8c44dwrowexmlElemDiff m nPath atts cs e2 = xmlAttrDiff nPath atts (elAttribs e2)
2d2eda71267231c2526be701fe655db125852c1ffielding ++ xmlDiff m nPath Map.empty cs (elContent e2)
61fd0cab072a05b855cbef9c585702401ac5ae29rbbxmlAttrDiff :: [Step] -> [Attr] -> [Attr] -> [Change]
61fd0cab072a05b855cbef9c585702401ac5ae29rbbxmlAttrDiff p a1 a2 = let
61fd0cab072a05b855cbef9c585702401ac5ae29rbb m1 = attrMap a1
61fd0cab072a05b855cbef9c585702401ac5ae29rbb m2 = attrMap a2
2d2eda71267231c2526be701fe655db125852c1ffielding addAttrStep a = pathToExpr $ Step Attribute (NameTest $ qName a) [] : p
3d96ee83babeec32482c9082c9426340cee8c44dwrowe in map (Change Remove . addAttrStep . fst) rms
2d2eda71267231c2526be701fe655db125852c1ffielding ++ map (\ (a, (_, v)) -> Change (Update v) $ addAttrStep a) inter
2d2eda71267231c2526be701fe655db125852c1ffielding ++ if null ins then [] else
2d2eda71267231c2526be701fe655db125852c1ffielding [Change (Add Append $ map (AddAttr . uncurry Attr) ins) $ pathToExpr p]
000b67449410515eac43e76ef6667915bfd4d2abgsteinpathToExpr :: [Step] -> Expr
2d2eda71267231c2526be701fe655db125852c1ffieldingpathToExpr = PathExpr Nothing . Path True . reverse
2d2eda71267231c2526be701fe655db125852c1ffieldingextendPath :: QName -> Count -> [Step] -> (Count, [Step])
61fd0cab072a05b855cbef9c585702401ac5ae29rbbextendPath en em stps = let
61fd0cab072a05b855cbef9c585702401ac5ae29rbb nm = Map.insertWith (+) en 1 em
61fd0cab072a05b855cbef9c585702401ac5ae29rbb nstps = Step Child (NameTest $ qName en) [PrimExpr Number $ show i] : stps
7bdef86e15d47d16dcbe7a5611683191774bd5fbgstein in (nm, nstps)
7bdef86e15d47d16dcbe7a5611683191774bd5fbgstein-- steps and predicates are reversed!
7bdef86e15d47d16dcbe7a5611683191774bd5fbgsteinaddPathNumber :: Int -> [Step] -> [Step]
61fd0cab072a05b855cbef9c585702401ac5ae29rbbaddPathNumber i stps =
61fd0cab072a05b855cbef9c585702401ac5ae29rbb let e = PrimExpr Number $ show i
61fd0cab072a05b855cbef9c585702401ac5ae29rbb in case stps of
61fd0cab072a05b855cbef9c585702401ac5ae29rbb Step a n es : rs -> Step a n (e : es) : rs
3d96ee83babeec32482c9082c9426340cee8c44dwrowevalidContent :: Content -> Bool
7bdef86e15d47d16dcbe7a5611683191774bd5fbgsteinvalidContent c = case c of
61fd0cab072a05b855cbef9c585702401ac5ae29rbb XML.Text t | all isSpace $ cdData t -> False
61fd0cab072a05b855cbef9c585702401ac5ae29rbb CRef _ -> False -- we cannot handle this
61fd0cab072a05b855cbef9c585702401ac5ae29rbbcontentToAddChange :: Content -> AddChange
61fd0cab072a05b855cbef9c585702401ac5ae29rbbcontentToAddChange c = case c of
61fd0cab072a05b855cbef9c585702401ac5ae29rbb Elem e -> AddElem e
61fd0cab072a05b855cbef9c585702401ac5ae29rbb XML.Text t -> AddText $ cdData t
3d96ee83babeec32482c9082c9426340cee8c44dwrowe CRef s -> AddText s
c9a95767fbf0f5fb0976a06b97a256033925e433rbbmkXQName :: String -> QName
c9a95767fbf0f5fb0976a06b97a256033925e433rbbmkXQName s = (unqual s) { qPrefix = Just xupdateS }
c9a95767fbf0f5fb0976a06b97a256033925e433rbbchangeToXml :: Change -> Element
c9a95767fbf0f5fb0976a06b97a256033925e433rbbchangeToXml (Change csel pth) = let
c9a95767fbf0f5fb0976a06b97a256033925e433rbb sel = add_attr (mkAttr selectS $ show pth)
c9a95767fbf0f5fb0976a06b97a256033925e433rbb in case csel of
c9a95767fbf0f5fb0976a06b97a256033925e433rbb Add _ as -> sel
c9a95767fbf0f5fb0976a06b97a256033925e433rbb . node (mkXQName appendS) $ map addsToXml as
c9a95767fbf0f5fb0976a06b97a256033925e433rbb Remove -> sel $ node (mkXQName removeS) ()
c9a95767fbf0f5fb0976a06b97a256033925e433rbb Update s -> sel $ node (mkXQName updateS) s
c9a95767fbf0f5fb0976a06b97a256033925e433rbb _ -> error "changeToXml"
61fd0cab072a05b855cbef9c585702401ac5ae29rbbaddsToXml :: AddChange -> Content
61fd0cab072a05b855cbef9c585702401ac5ae29rbbaddsToXml a = case a of
61fd0cab072a05b855cbef9c585702401ac5ae29rbb AddElem e -> Elem e
61fd0cab072a05b855cbef9c585702401ac5ae29rbb AddAttr (Attr k v) -> Elem
61fd0cab072a05b855cbef9c585702401ac5ae29rbb . add_attr (mkNameAttr $ qName k) $ node (mkXQName attributeS) v
61fd0cab072a05b855cbef9c585702401ac5ae29rbb AddText s -> mkText s
61fd0cab072a05b855cbef9c585702401ac5ae29rbb _ -> error "addsToXml"
61fd0cab072a05b855cbef9c585702401ac5ae29rbbmkMods :: [Change] -> Element
3d96ee83babeec32482c9082c9426340cee8c44dwrowemkMods = node (mkXQName "modifications") . map changeToXml