-- This module contains utilities f or building and pretty printing
-- an XML tree. Attributes are not used but can easily be added to
-- the data statement as follows: ATag ATag  and
-- type ATag = (AtTag, XMLTree, XMLTree)
-- type AtTag = (String,[(String, String)] whereby the
-- attributes are represented by two strings: name and value. 
-- Author: G.Naudts. Mail: naudts_vannoten@yahoo.com.

module XML where
import "Utils"

-- an XML tree is empty or contains a tag composed of a name, the
-- children of the tree and a content string
data XMLTree = Empty|
               Tag (Name, Children, Content) 

type Name = String
type Children = [XMLTree]
type Content = String

-- declaration of equality of trees. 
instance Eq XMLTree where
   Empty == Empty = True
   Tag (name1, children1, content1) == Tag (name2, children2, content2) =
        name1 == name2 && children1 == children2 && content1 == content2
   t1 == t2  = False

-- add a tree to a tree; the tree is added to the list of children after
-- the existing children.
addTree :: XMLTree -> XMLTree -> XMLTree
addTree Empty Empty = Empty
addTree t Empty = t
addTree Empty t = t
addTree (Tag tag@(name, children, content)) t
                        = Tag (name, children ++ [t], content)

-- ad a list of trees to the children of a tree.
addTreeList :: XMLTree -> [XMLTree] -> XMLTree
addTreeList Empty _ = Empty
addTreeList t [] = t
addTreeList (Tag tag@(name, children, content)) treeList
                        = Tag (name, children ++ treeList, content)

-- set the content of a tag (delete by setting to "").
addContent :: XMLTree -> String -> XMLTree
addContent Empty s = Empty
addContent (Tag (name, children, content)) s 
            =  Tag (name, children, s)

-- search if there is direct content that contains a certain string
searchContent :: [XMLTree] -> String -> Bool
searchContent [] s = False
searchContent ((Tag (name, children, content)):xs) s
   | containsString s content = True
   | otherwise = searchContent xs s
searchContent (x:xs) s = searchContent xs s

-- get all children of a tag. 
getChildren :: XMLTree -> [XMLTree]
getChildren Empty = []
getChildren (Tag (name, children, content)) = children

-- clears the tree
clearTree :: XMLTree -> XMLTree
clearTree (Tag (name, children, content)) =
        Tag (name, [], "")
clearTree Empty = Empty

-- get a list of all tags in a tree.
getAllTags :: XMLTree -> [XMLTree]
getAllTags Empty = []
getAllTags (Tag tag@(name, [], content)) = [Tag tag]
getAllTags (Tag tag@(name, children, content)) =
         [Tag tag] ++ getAllTagsFromTree(children)

-- get alltags from a list of trees
getAllTagsFromTree :: [XMLTree] -> [XMLTree]
getAllTagsFromTree [] = []
getAllTagsFromTree (x:xs) = getAllTags x ++ getAllTagsFromTree(xs)

-- get all tags with a given name
getChildrenByName :: XMLTree -> String -> [XMLTree]
getChildrenByName t s = selectFromTree t f 
           where f Empty = []
                 f (Tag (name, children, content))
                    |name == s = [Tag(name, children, content)]
                    |otherwise = []

-- get the first child with a specific name
getChildByName :: XMLTree -> String -> XMLTree
getChildByName Empty s = Empty
getChildByName (Tag (name, [], content)) s = Empty
getChildByName (Tag (name,(x:xs),content)) s
        |x == Empty = getChildByName (Tag(name, xs, content)) s        
        |name1 == s = x
        |otherwise = getChildByName (Tag(name, xs, content)) s
        where Tag(name1, _, _) = x

-- deletes the first child with a name.
deleteChildByName :: XMLTree -> String -> XMLTree
deleteChildByName Empty s = Empty
deleteChildByName (Tag(name, children, content)) s 
           = Tag (name, deleteChildByNameFromTree children s, content)
           where deleteChildByNameFromTree [] s = []
                 deleteChildByNameFromTree (x:xs) s
                    |name1 == s = xs
                    |otherwise = x:deleteChildByNameFromTree xs s
                    where Tag(name1, _, _) = x

-- delete allchildren with a specific name
deleteAllChildren :: XMLTree -> String -> XMLTree
deleteAllChildren Empty s = Empty
deleteAllChildren (Tag (name, children, content)) s
        = Tag (name, deleteAllChildrenFromTree children s, content)
        where deleteAllChildrenFromTree [] s = []
              deleteAllChildrenFromTree (x:xs) s
                 |name1 == s = deleteAllChildrenFromTree xs s
                 |otherwise = x:deleteAllChildrenFromTree xs s
                 where Tag(name1, _, _) = x

-- get all tags with a given name that directly descend from the given tag
getDirectChildrenByName :: XMLTree -> String -> [XMLTree]
-- tree possibilities for Tag
getDirectChildrenByName Empty s = []
getDirectChildrenByName (Tag tag@(name, children, content)) s =
   getDirectChildrenByNameFromList children 
   where getDirectChildrenByNameFromList :: [XMLTree] -> [XMLTree]
         getDirectChildrenByNameFromList [] = []
         getDirectChildrenByNameFromList (Tag t@(name1, _, _):ts) 
             | name1 == s = (Tag t):getDirectChildrenByNameFromList ts
             | otherwise = getDirectChildrenByNameFromList ts


-- replace the first child with given name by the given tree.
replaceChild :: XMLTree -> XMLTree -> String -> XMLTree
replaceChild Empty _ s = Empty
replaceChild tree Empty s = tree
replaceChild (Tag tag@(name, children, content)) t1 s1
   = Tag (name, (replaceChildInTree children t1 s1), content)
   where replaceChildInTree (x:xs) t1 s1
                 |name1 == s1 = t1:xs
                 |otherwise = x:replaceChildInTree xs t1 s1
                 where Tag(name1, _, _) = x

-- walk a tree. The first input is the tree to walk.
-- The second input is a function that takes as input an XML tree
-- and as output an XML Tree. This function is applied to every
-- Tag of the input tree and must return resp. a Tag or an Empty tree.
-- The output tree is the modified input tree.
walkATree :: XMLTree -> (XMLTree -> XMLTree) -> XMLTree
walkATree Empty f = Empty
walkATree (Tag tag@(name, children, content)) f =
        (Tag (s, (walkATreeList t f), c))
   where Tag (s, t, c) = f (Tag tag)
         walkATreeList [] f = []
         walkATreeList (x:xs) f = (walkATree x f): (walkATreeList xs f)

-- select from a tree. The first input is the tree to select from.
-- The second input is a function that takes as input an XML tree
-- and as output a list of trees. This function is applied to every
-- Tag of the input tree and must return resp. Tag or an Empty tree.
-- The output tree is the concatenation of
-- the output from this function.
selectFromTree :: XMLTree -> (XMLTree -> [XMLTree]) -> [XMLTree]
selectFromTree Empty f = f Empty
selectFromTree (Tag tag@(name, children, content)) f  
         = (f (Tag tag)) ++ selectFromTreeList children f
         where
         selectFromTreeList [] f = []
         selectFromTreeList (x:xs) f = (selectFromTree x f) ++
                                        (selectFromTreeList xs f)

-- eliminate all empty trees
eliminateEmpties :: [XMLTree] -> [XMLTree]
eliminateEmpties [] = []
eliminateEmpties (t:ts)
   | t == Empty = eliminateEmpties ts
   | otherwise = t:eliminateEmpties ts

-- print an empty tree
printEmpty :: XMLTree -> String
printEmpty Empty = "Empty"
printEmpty t = ""

-- print the contents of this xml tree on screen
printXml :: XMLTree -> String -> String
printXml Empty sep = ""
printXml (Tag(name, [], "")) sep =
             sep ++ "<" ++ name ++ ">\n" ++
             sep ++ "</" ++ name ++ ">\n"
printXml (Tag(name, [], content)) sep =
             sep ++ "<" ++ name ++ ">\n" ++
             ind ++ sep ++ content ++ "\n" ++
             sep ++ "</" ++ name ++ ">\n"
printXml (Tag(name, children, "")) sep =
             sep ++ "<" ++ name ++ ">\n" ++
             printTreeList children (sep ++ ind) ++ 
             sep ++ "</" ++ name ++ ">\n"
printXml (Tag(name, children, content)) sep =
             sep ++ "<" ++ name ++ ">\n" ++
             ind ++ sep ++ content ++ "\n" ++
             printTreeList children (sep ++ ind) ++ 
             sep ++ "</" ++ name ++ ">\n"

-- print a list of trees
printTreeList :: [XMLTree] -> String -> String
printTreeList [] sep = ""
printTreeList (x:xs) sep =
      printXml x sep ++ printTreeList xs sep

-- test if a XMLTree is a Tag
testTag :: XMLTree -> Bool
testTag (Tag t) = True
testTag c = False

-- test if a XMLTree is empty
testEmpty :: XMLTree -> Bool
testEmpty Empty = True
testEmpty t = False

-- indent constant
ind = "  "

testWalkATree = putStr(printXml (walkATree tree4 f) "")
                where f (Tag (s, t, p)) = Tag ("Ha!", t, p)
                      f t = t

-- testdata

xml = Empty
tree11 = addTree xml (Tag("test", [], "tree11"))
tree1 = (addTree (addTree xml (Tag("test", [], "")))
                              (Tag ("test1", [], "test")))
tree2 = (addTree tree1 (Tag("test2", [], "")))
showTree2 = putStr( printXml ( tree2) "")
tree3 = (addTree tree2 (Tag("test", [],"")))
tree4 = (addTree (addTree (addTree xml (Tag("test", [], "")))
         (Tag("test1", [], ""))) (Tag ("Test content",[], "")))

test = putStr (printXml tree1 "")
test1 = putStr (printXml (getChildByName tree1 "test1") "")
test13 = putStr (printXml tree11 "")
test2 = putStr (printTreeList (getChildren tree3) "")
test3 = putStr (printXml tree3 "")
test4 = putStr (printXml tree3 "")
test5 = putStr (printXml (getChildByName tree1 "test1") "")
test52 = putStr (printXml tree1 "")
test6 = putStr (printTreeList (getChildrenByName tree3 "test") "")
test7 = putStr (printTreeList (getAllTags tree3) "")
test10 = putStr (printXml tree4 "")
test11 = putStr (printXml tree4 "")
test14 = putStr (printXml(addTree tree1 tree2) "")
test16 = putStr (printXml(addTree tree11 (Tag ("ttt", [], "")))"")