-- Example application: querying and transformation of XML data import XML import Control.SetFunctions entry1 :: XmlExp entry1 = xml "entry" [xml "name" [xtxt "Hanus"], xml "first" [xtxt "Michael"], xml "phone" [xtxt "+49-431-8807271"], xml "email" [xtxt "mh@informatik.uni-kiel.de"], xml "email" [xtxt "hanus@email.uni-kiel.de"] ] entry2 :: XmlExp entry2 = xml "entry" [xml "name" [xtxt "Smith"], xml "first" [xtxt "William"], xml "nickname" [xtxt "Bill"], xml "phone" [xtxt "+1-987-742-9388"] ] entry3 :: XmlExp entry3 = xml "entry" [xml "name" [xtxt "Hanus"], xml "first" [xtxt "Michael"], XElem "phone" [("place","office")] [xtxt "+49-431-8807271"], xml "email" [xtxt "mh@informatik.uni-kiel.de"], xml "email" [xtxt "hanus@email.uni-kiel.de"] ] entry4 :: XmlExp entry4 = xml "entry" [xml "phone" [xtxt "+1-987-742-9388"], xml "name" [xtxt "Smith"], xml "first" [xtxt "William"], xml "nickname" [xtxt "Bill"] ] -- Representation of the contacts data: contacts :: XmlExp contacts = xml "contacts" [entry1, entry2] getNamePhone1 :: XmlExp -> String getNamePhone1 (xml "entry" ([xml "name" [xtxt name], _, xml "phone" [xtxt phone]] ++ _)) = name ++ ": " ++ phone getNamePhone2 :: XmlExp -> String getNamePhone2 (xml "entry" ([xml "name" [xtxt name], _, _, xml "phone" [xtxt phone]] ++ _)) = name ++ ": " ++ phone -- Extract the name and phone field from an entry: getNamePhone :: XmlExp -> String getNamePhone (xml "entry" (with [xml "name" [xtxt name], xml "phone" [xtxt phone]])) = name ++ ": " ++ phone with :: Data a => [a] -> [a] with [] = _ with (x:xs) = _ ++ x : with xs xml' :: String -> [XmlExp] -> XmlExp xml' tag xmls = XElem tag _ xmls -- Extract the name and phone field from an entry: getNamePhone' :: XmlExp -> String getNamePhone' (xml "entry" (with [xml' "name" [xtxt name], xml' "phone" [xtxt phone]])) = name ++ ": " ++ phone -- Extract the name and phone field in any order from an entry: getAnyNamePhone :: XmlExp -> String getAnyNamePhone (xml "entry" (with (anyOrder [xml "name" [xtxt name], xml "phone" [xtxt phone]]))) = name ++ ": " ++ phone anyOrder :: [a] -> [a] anyOrder [] = [] anyOrder (x:xs) = insert (anyOrder xs) where insert zs = x : zs insert (z:zs) = z : insert zs -- Extract the name and phone field in any order in some entry -- at a deep position: getDeepNamePhone :: XmlExp -> String getDeepNamePhone (deepXml "entry" (with (anyOrder [xml "name" [xtxt name], xml "phone" [xtxt phone]]))) = name ++ ": " ++ phone deepXml :: String -> [XmlExp] -> XmlExp deepXml tag elems = xml' tag elems deepXml tag elems = xml' _ (_ ++ [deepXml tag elems] ++ _) -- Get all email addresses in a document: getEmail :: XmlExp -> String getEmail (deepXml "email" [xtxt email]) = email allEmails :: XmlExp -> [String] allEmails xe = sortValues ((set1 getEmail) xe) -- Extract the name and phone field from an entry: getNamePhoneWithoutEmail :: XmlExp -> String getNamePhoneWithoutEmail (deepXml "entry" (withOthers [xml "name" [xtxt name], xml "phone" [xtxt phone]] others)) | "email" `noTagOf` others = name ++ ": " ++ phone noTagOf :: String -> [XmlExp] -> Bool noTagOf tag = all ((/= tag) . tagOf) withOthers :: Data a => [a] -> [a] -> [a] withOthers xs ys = withAcc [] xs ys where -- accumulate all remaining elements in last argument withAcc prevs [] others | others === prevs ++ suffix = suffix where suffix free withAcc prevs (z:zs) others = prefix ++ [z] ++ withAcc (prevs ++ prefix) zs others where prefix free --------------------------------------------------------------------- -- Transformation: -- Create new XML document and full name of a contact: transPhone :: XmlExp -> XmlExp transPhone (deepXml "entry" (with (anyOrder [xml' "name" [xtxt name], xml' "first" [xtxt first], xml' "phone" phone]))) = xml "phonename" [xml "phone" phone, xml "fullname" [xtxt $ first ++ " " ++ name]] phoneTable :: XmlExp phoneTable = xml "table" (sortValues ((set1 transPhone) contacts)) -- Get a name together with the number of their email addresses: getEmails :: XmlExp -> (String,Int) getEmails (deepXml "entry" (withOthers [xml "name" [xtxt name]] os)) = (name, length (sortValues ((set1 emailOf) os))) where emailOf (with [xml "email" email]) = email getAllEmailNumbers :: [(String,Int)] getAllEmailNumbers = sortValues ((set1 getEmails) contacts)