XUpdate.hs revision fe4d24dddce1322bd8dd24debcca4fec950eb873
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederModule : $Header$
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederDescription : analyse xml update input
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederCopyright : (c) Christian Maeder, DFKI GmbH 2010
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederLicense : similar to LGPL, see HetCATS/LICENSE.txt or LIZENZ.txt
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederMaintainer : Christian.Maeder@dfki.de
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederStability : provisional
96e54b22ad432d658ba790f3800ee8ea2657449fChristian MaederPortability : portable
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maedercollect xupdate information
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder-- | possible insertions
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maederdata AddChange
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder = AddElem Element
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder | AddAttr Attr
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder | AddText String
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder | AddComment String
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder | AddPI String String
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maederinstance Show AddChange where
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder show c = case c of
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder AddElem e -> showElement e
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder AddAttr a -> showAttr a
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder AddText s -> show s
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder AddComment s -> "<!--" ++ s ++ "-->"
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder AddPI n s -> "<?" ++ n ++ " " ++ s ++ "?>"
b82427a46050fa32553e722daedf6a364a14f217Christian Maeder ValueOf -> valueOfS
b82427a46050fa32553e722daedf6a364a14f217Christian MaedervalueOfS :: String
b82427a46050fa32553e722daedf6a364a14f217Christian MaedervalueOfS = "value-of"
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian Maederdata Insert = Before | After | Append deriving Show
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian MaedershowInsert :: Insert -> String
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian MaedershowInsert i = let s = map toLower $ show i in case i of
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian Maeder _ -> "insert-" ++ s
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maederdata ChangeSel
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian Maeder = Add Insert [AddChange]
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder | Update String
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder | Rename String
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder | Variable String
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maederinstance Show ChangeSel where
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder show c = case c of
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian Maeder Add i cs -> showInsert i ++ concatMap (('\n' :) . show) cs
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder Update s -> '=' : s
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder Rename s -> s
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder Variable s -> '$' : s
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maederdata Change = Change ChangeSel Expr
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maederinstance Show Change where
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder show (Change c p) =
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder show p ++ ":" ++ show c
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederanaXUpdates :: Monad m => String -> m [Change]
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederanaXUpdates input = case parseXMLDoc input of
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder Nothing -> fail "cannot parse xupdate file"
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian Maeder Just e -> mapM anaXUpdate $ elChildren e
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder{- the input element is expected to be one of
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder xupdate:insert-before
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder xupdate:insert-after
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder xupdate:append
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder xupdate:remove
96e54b22ad432d658ba790f3800ee8ea2657449fChristian Maeder xupdate:update
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederisXUpdateQN :: QName -> Bool
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederisXUpdateQN = (Just "xupdate" ==) . qPrefix
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederhasLocalQN :: String -> QName -> Bool
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederhasLocalQN s = (== s) . qName
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederisElementQN :: QName -> Bool
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederisElementQN = hasLocalQN "element"
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederisAttributeQN :: QName -> Bool
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederisAttributeQN = hasLocalQN "attribute"
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederisTextQN :: QName -> Bool
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederisTextQN = hasLocalQN "text"
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederisAddQN :: QName -> Bool
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederisAddQN q = any (flip isPrefixOf $ qName q) ["insert", "append"]
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederisRemoveQN :: QName -> Bool
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederisRemoveQN = hasLocalQN "remove"
b82427a46050fa32553e722daedf6a364a14f217Christian Maeder-- | extract the non-empty attribute value
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian MaedergetAttrVal :: Monad m => String -> Element -> m String
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian MaedergetAttrVal n e =
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder (\ s -> if null s
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder then failX ("missing " ++ n ++ " attribute") $ elName e
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder else return s)
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder . fromMaybe "" $ findAttr (unqual n) e
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian MaedergetSelectAttr :: Monad m => Element -> m String
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaedergetSelectAttr = getAttrVal "select"
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian MaedergetNameAttr :: Monad m => Element -> m String
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaedergetNameAttr = getAttrVal "name"
b82427a46050fa32553e722daedf6a364a14f217Christian Maeder-- | convert a string to a qualified name by splitting at the colon
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maederstr2QName :: String -> QName
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maederstr2QName str = let (ft, rt) = break (== ':') str in
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder _ : l@(_ : _) -> (unqual l) { qPrefix = Just ft }
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder _ -> unqual str
b82427a46050fa32553e722daedf6a364a14f217Christian Maeder-- | extract text and check for no other children
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian MaedergetText :: Monad m => Element -> m String
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian MaedergetText e = let s = trim $ strContent e in
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder if null s then fail $ "empty text: " ++ showElement e else
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder case elChildren e of
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder [] -> return s
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder c : _ -> failX "unexpected child" $ elName c
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian MaederanaXUpdate :: Monad m => Element -> m Change
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian MaederanaXUpdate e = let
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian Maeder u = qName q in
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder if isXUpdateQN q then do
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder sel <- getSelectAttr e
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder case parseExpr sel of
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder Left _ -> fail $ "unparsable xpath: " ++ sel
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder Right p -> case () of
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian Maeder _ | isRemoveQN q -> noContent e $ Change Remove p
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder | hasLocalQN "variable" q -> do
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder vn <- getNameAttr e
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian Maeder noContent e $ Change (Variable vn) p
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian Maeder _ -> case lookup u [("update", Update), ("rename", Rename)] of
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder s <- getText e
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian Maeder return $ Change (c s) p
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian Maeder Nothing -> case lookup u $ map (\ i -> (showInsert i, i))
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian Maeder [Before, After, Append] of
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian Maeder cs <- mapM addXElem $ elChildren e
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian Maeder let ps = getPaths p
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian Maeder if all ((== TElement) . finalPrincipalNodeType) ps then
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian Maeder return $ Change (Add i cs) p
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian Maeder else fail $ "expecting element path: " ++ sel
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian Maeder Nothing -> failX "no xupdate modification" q
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder else failX "no xupdate qualified element" q
b82427a46050fa32553e722daedf6a364a14f217Christian Maeder-- | partitions additions and ignores comments, pi, and value-of
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederpartitionAddChanges :: [AddChange] -> ([Attr], [Content])
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederpartitionAddChanges = foldr (\ c (as, cs) -> case c of
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder AddAttr a -> (a : as, cs)
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder AddElem e -> (as, Elem e : cs)
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder AddText s -> (as, mkText s : cs)
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder _ -> (as, cs)) ([], [])
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederfailX :: Monad m => String -> QName -> m a
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederfailX str q = fail $ str ++ ": " ++ showQName q
b82427a46050fa32553e722daedf6a364a14f217Christian Maeder-- | check if the element contains no other content
b82427a46050fa32553e722daedf6a364a14f217Christian MaedernoContent :: Monad m => Element -> a -> m a
b82427a46050fa32553e722daedf6a364a14f217Christian MaedernoContent e a = case elContent e of
b82427a46050fa32553e722daedf6a364a14f217Christian Maeder [] -> return a
b82427a46050fa32553e722daedf6a364a14f217Christian Maeder c : _ -> fail $ "unexpected content: " ++ showContent c
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederaddXElem :: Monad m => Element -> m AddChange
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederaddXElem e = let q = elName e in
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder if isXUpdateQN q then case () of
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder _ | isTextQN q -> liftM AddText $ getText e
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder | hasLocalQN "comment" q -> liftM AddComment $ getText e
b82427a46050fa32553e722daedf6a364a14f217Christian Maeder | hasLocalQN valueOfS q -> noContent e ValueOf
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder n <- getNameAttr e
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder let qn = str2QName n
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder _ | isAttributeQN q ->
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder liftM (AddAttr . Attr qn) $ getText e
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder | isElementQN q -> do
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder es <- mapM addXElem $ elChildren e
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder let (as, cs) = partitionAddChanges es
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder return $ AddElem $ add_attrs as $ node qn cs
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder | hasLocalQN pIS q -> liftM (AddPI n) $ getText e
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder _ -> failX "unknown change" q
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder else failX "no xupdate element" q
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder xupdate:element
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder xupdate:attribute
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maederxupdate:element may contain xupdate:attribute elements and further
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maederxupdate:element or xupdate:text elements.