{-
-- Representation of XML documents:
data XmlExp = XText String
            | XElem String [(String,String)] [XmlExp]

-- Use abbreviations:
xtxt :: String -> XmlExp
xtxt s = XText s

xml :: String -> [XmlExp] -> XmlExp
xml tag xes = XElem tag [] xes
-}
-- All this is defined in a library XML:
import XML
import Control.Search.SetFunctions

-- This is in package `xml`: to add it, try: > cypm add xml

-- XML documents from the `contacts` example:
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 "Smith"],
     xml "first"    [xtxt "William"],
     xml "nickname" [xtxt "Bill"],
     XElem "phone" [("place","office")] [xtxt "1-987-742-9388"]
    ]

-- with changed phone number order
entry4 :: XmlExp
entry4 =
  xml "entry"
    [xml "phone"    [xtxt "1-987-742-9388"],
     xml "name"     [xtxt "Smith"],
     xml "first"    [xtxt "William"],
     xml "nickname" [xtxt "Bill"]
    ]

contacts :: XmlExp
contacts = xml "contacts" [entry1, entry2]

getNamePhone1 :: XmlExp -> String
getNamePhone1
 (xml "entry"
      [xml "name" [xtxt n], _, xml "phone" [xtxt p], _, _]) = n ++ ": " ++ p

getNamePhone2 :: XmlExp -> String
getNamePhone2
 (xml "entry"
      [xml "name" [xtxt n], _, _, xml "phone" [xtxt p]]) = n ++ ": " ++ p


-- Partial XML patterns:
getNamePhone :: XmlExp -> String
getNamePhone
 (xml "entry"
      (with [xml "name" [xtxt n], xml "phone" [xtxt p]])) = n ++ ": " ++ p

with :: Data a => [a] -> [a]
with []     = _
with (x:xs) = _ ++ x : with xs

xmlP :: String -> [XmlExp] -> XmlExp
xmlP tag xes = XElem tag _ xes

-- Get name and phone but allow XML attributes:
getNamePhoneP :: XmlExp -> String
getNamePhoneP
 (xmlP "entry"
      (with [xmlP "name" [xtxt n], xmlP "phone" [xtxt p]])) = n ++ ": " ++ p

-- with unordered patterns:

-- Get name and phone but allow XML attributes:
getAnyNamePhone :: XmlExp -> String
getAnyNamePhone
 (xml "entry"
      (with (anyorder [xmlP "name" [xtxt n], xmlP "phone" [xtxt p]])))
  = n ++ ": " ++ p

anyorder :: [a] -> [a]
anyorder [] = []
anyorder (x:xs) = insert (anyorder xs)
 where insert []     = [x]
       insert (y:ys) = x:y:ys ? y : insert ys

-- Deep XML pattern matching:
getDeepNamePhone :: XmlExp -> String
getDeepNamePhone
  (deepXml "entry"
     (with [xml "name" [xtxt n], xml "phone" [xtxt p]])) = n ++ ": " ++ p

deepXml :: String -> [XmlExp] -> XmlExp
deepXml tag elems = xmlP tag elems
deepXml tag elems = xmlP _ (_ ++ [deepXml tag elems] ++ _)

-- Get all email addresses in an XML document (with tag `email`):
getEmail :: XmlExp -> String
getEmail (deepXml "email" [xtxt email]) = email

-- Get all email addresses in an XML document as a list (with tag `email`):
allEmails :: XmlExp -> [String]
allEmails xe = sortValues ((set1 getEmail) xe)


-----------------------------------------------------------------------
-- Consider negative information, i.e, absence of XML structures

-- Name and phone number of entries without an email address:
getNamePhoneWithoutEmail :: XmlExp -> String
getNamePhoneWithoutEmail
  (deepXml "entry"
     (withOthers [xml "name" [xtxt n], xml "phone" [xtxt p]] others))
     -- others are the remaining components without these in the first list
  | -- there is no email in this entry:
    "email" `noTagOf` others
  = n ++ ": " ++ p

noTagOf :: String -> [XmlExp] -> Bool
--noTagOf tag xes = all (\xe -> tagOf xe /= tag) xes 
noTagOf tag = all ((/= tag) . tagOf)


-- Returns some list containing the elements of both argument lists
-- by merging these lists.
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


-----------------------------------------------------------------------

-- Example: transform entries into phone number + full name
transPhone :: XmlExp -> XmlExp
transPhone
  (deepXml "entry"
     (with [xml "name"  [xtxt n],
            xml "first" [xtxt f],
            xml "phone" phone])) =
  xml "phonename" [xml "phone" phone, xml "fullname" [xtxt (f ++ ' ' : n)]]

phoneTable :: XmlExp -> XmlExp
phoneTable xe = xml "table" (sortValues ((set1 transPhone) xe))

-- Get a list of all persons together with the number of their email addresses:
getEmails :: XmlExp -> (String, Int)
getEmails
  (deepXml "entry"
     (withOthers [xml "name"  [xtxt n]] others)) =
  (n, length (sortValues ((set1 emailOf) others)))
 where
  emailOf (with [xml "email" email]) = email

getEmailNumbers :: XmlExp -> [(String,Int)]
getEmailNumbers xe = sortValues ((set1 getEmails) xe)