-- 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. 

module XML where
import "Utils"

-- an XML tree is empty, contains a single tag or a series of tags or
-- a content string
data XMLTree = Empty|
               Tag FTag|
               Tree [XMLTree]|
               Content Content

-- declaration of equality.
-- attention!!! the parents do not have to be equal!!
instance Eq XMLTree where
   Empty == Empty = True
   Tag (s, t, p) == Tag (s1, t1, p1) = (s == s1) && (t == t1)
   Tree [] == Tree [] = True
   Tree (x:xs) == Tree (y:ys) = (x == y) && (Tree xs == Tree ys)
   Content (s, p) == Content (s1, p1) = (s == s1) 
   t1 == t2  = False


-- the  string is the name of the tag (without attributes)
type STag = String  -- single tag (no attributes!!)
-- the first tree are the children; the second is the parent
type FTag = (STag, XMLTree, XMLTree) -- full tag
-- the XMLTree is the parent
type Content = (String, XMLTree)

-- add a tree to a tree; if the first tree is a tag a child is added;
-- if it is a tree Empty is returned. To add a tree after a tree,
-- use addTreeAfter
addTree :: XMLTree -> XMLTree -> XMLTree
addTree Empty Empty = Empty
addTree t Empty = t
addTree Empty t = t
addTree (Tag tag@(ftag, tree1, parent)) (Tag (tag2, tree2, _))
                        = Tag (ftag, addSerial tree1 ftag2, parent)
   where ftag2 = (tag2, tree2, Tag tag)
addTree (Tag tag) (Tree []) = (Tag tag)
addTree (Tag tag) (Tree (x:xs)) = addTree (addTree (Tag tag) x) (Tree xs)
addTree (Tree t) _ = Empty
addTree (Tag tag) (Content s) =
                         addContent (Tag tag) (Content s)
addTree c _ = Empty  -- cannot add to content

-- add a child to a tag; if a list or content then return Empty
addChild :: XMLTree -> FTag -> XMLTree
addChild Empty (tag, tree1, parent) = Tag (tag, tree1, parent)
addChild (Tag tag@(ftag, tree1, parent)) (tag2, tree2, _)
                        = Tag (ftag, addSerial tree1 ftag2, parent)
   where ftag2 = (tag2, tree2, Tag tag)
addChild (Tree xs) ftag = Empty
addChild (Content s) (tag, _, _) = Empty -- not permitted !!!

-- add a tag to the end of the tree. Attention! parent can change!!
addSerial :: XMLTree -> FTag -> XMLTree
addSerial Empty (tag, tree1, parent) = Tag (tag, tree1, parent)
addSerial (Tag tag@(tag1, _, parent1)) (tag2, tree, parent2)
                   = Tree [Tag tag, Tag ftag1]   -- merge two tags in a list
   where ftag1 = (tag2, tree, parent1)
addSerial (Tree xs) ftag = Tree (xs ++ [Tag ftag])
addSerial c _ = Empty -- cannot add to content

-- add content to the end of the tree
-- content may only be added after a tag
addContent :: XMLTree -> XMLTree -> XMLTree
addContent Empty c = Empty
addContent (Tag tag@(tag1, Empty, parent)) (Content (s, _))
                   = Tag (tag1, Tree [Content (s, Tag tag)], parent)
addContent (Tag tag@(tag1, Tag tag2, parent)) (Content (s, _))
                   = Tag (tag1, Tree [Tag tag2, Content (s, Tag tag)], parent)
addContent (Tag tag@(tag1, Tree tree, parent)) (Content (s, _))
                   = Tag (tag1, Tree (tree ++ [Content (s, Tag tag)]), parent)
addContent (Tag tag@(tag1, Content c, parent)) (Content (s, _))
                   = Tag (tag1, Tree (Content c:[Content (s, Tag tag)]), parent)
addContent (Tree xs) c = Empty

-- get the parent tag
getParent :: XMLTree -> XMLTree
getParent Empty = Empty
getParent (Tag ftag@(_, _, t)) = t
getParent (Tree []) = Empty
getParent (Tree (x:xs)) = getParent x
getParent (Content (s, t)) = t

-- add a tree after a tree. Returns the merged tree.
-- In the case the first tree is a Tree the parent is taken from
-- the first element of this tree and propagated throughout the second tree.
addTreeAfter :: XMLTree -> XMLTree -> XMLTree
addTreeAfter Empty tree = tree
addTreeAfter tree Empty = tree
addTreeAfter (Tag tag) t = addTreeAfter (Tree [Tag tag]) t
addTreeAfter (Tree t) (Tag (tag, tree, parent)) = Tree (t ++
                             [Tag (tag, tree, getParent (Tree t))])
addTreeAfter (Tree t) t1 = Tree (t ++ t2)
   where Tree t2 = (changeParent t1 (getParent (Tree t)))

-- change the parent in a tree
changeParent :: XMLTree -> XMLTree -> XMLTree
changeParent (Tree []) p = Tree []
changeParent (Tree (x:xs)) p = merge (Tree [t]) (changeParent (Tree xs) p)
   where Tag (tag, tree, p1) = x
         t = Tag (tag, tree, p)

-- merge two lists of trees together into one list of trees
merge :: XMLTree -> XMLTree -> XMLTree
merge (Tree t1) (Tree t2) = Tree (t1 ++ t2)

-- merge a list of trees to a Tree that is a list.
mergeTreeList :: [XMLTree] -> XMLTree
mergeTreeList [] = Empty
mergeTreeList (t:ts) =  addTreeAfter t (mergeTreeList ts)

-- get a child or the first child
getChild :: XMLTree -> XMLTree
getChild Empty = Empty
getChild (Tree []) = Empty
getChild (Tree (x:xs)) = Empty
getChild (Tag ftag@(stag, Empty, _)) = Empty
getChild (Tag ftag@(stag, Tag t, _)) = Tag t
getChild (Tag ftag@(stag, Tree (x:xs), _)) = x  -- get first child
getChild (Tag ftag@(stag, Content c, _)) = Content c
getChild t = Empty  -- everything else is certainly bad

-- get a the first or main tag/tree/content
getMain :: XMLTree -> XMLTree
getMain Empty = Empty
getMain (Tree []) = Empty
getMain (Tree (x:xs)) = x
getMain (Tag ftag@(s,_,p)) = Tag (s, Empty, p)
getMain (Content c) = Content c

-- gets the content of a tag
getContentFromTag :: XMLTree -> XMLTree
getContentFromTag  (Tag tag@(s, t, p)) = getContentFromList t1
   where Tree t1 = t
getContentFromTag t = Empty

-- gets the content of a tag (the string contained in the content)
getTagContent :: XMLTree -> String
getTagContent (Tag (_, c, _)) = s
   where Content (s, _) = c
getTagContent tag = ""

-- gets the content from a List
getContentFromList [] = Empty
getContentFromList (Content c : ts) = Content c
getContentFromList (t:ts) = getContentFromList ts

-- replace a child tag
replaceChild :: XMLTree -> XMLTree -> String -> XMLTree
replaceChild (Tag tag@(s, t, p)) t1 s1
   = Tag (s, (replaceChild t t1 s1), p)
replaceChild (Tree []) t1 s = t1
replaceChild (Tree ((Tag tag):xs)) t1 s
   | s == s1 = Tree (t1:xs)
   | otherwise = merge (Tree [Tag tag]) (replaceChild (Tree xs) t1 s)
   where Tag (s1, _, _) = Tag tag
replaceChild (Tree ((Tree t):xs)) t1 s
   = merge (Tree t) (replaceChild (Tree xs) t1 s)
replaceChild t t1 s = t1

-- get the first child with a specific name
getChildByName :: XMLTree -> String -> XMLTree
getChildByName Empty s = Empty
getChildByName (Tree []) s = Empty
getChildByName (Tree (x:xs)) s
   | bv1 && s == s1 = x
   | otherwise = getChildByName (Tree xs) s
   where bv1 = testTag x
         Tag (s1, t, p) = x
getChildByName (Tag ftag@(stag, Empty, _)) s   -- tree possibilities for Tag
   = Empty
getChildByName (Tag ftag@(stag, Tag ftag1, _)) s
   | s1 == s = (Tag ftag1)
   | otherwise = getChildByName t s
   where Tag (s1, t, p) = Tag ftag1
getChildByName (Tag ftag@(stag, tree, _)) s
   = getChildByName tree s
getChildByName t s = Empty

-- get all tags with a given name
getChildrenByName :: XMLTree -> String -> [XMLTree]
getChildrenByName Empty s = []
getChildrenByName (Tree []) s = []
getChildrenByName (Tree (x:xs)) s
   | bv1 && s == s1 = x:getChildrenByName (Tree xs) s
   | otherwise = (getChildrenByName x s) ++ (getChildrenByName (Tree xs) s)
   where bv1 = testTag x
         Tag (s1, t, p) = x
getChildrenByName (Tag ftag@(stag, Empty, _)) s   -- tree possibilities for Tag
   = []
getChildrenByName (Tag ftag@(stag, Tag ftag1, _)) s
   | s1 == s = (Tag ftag1):getChildrenByName t s
   | otherwise = getChildrenByName t s
   where Tag (s1, t, p) = Tag ftag1
getChildrenByName (Tag ftag@(stag, tree, _)) s
   = getChildrenByName tree s
getChildrenByName t s = []

-- get all tags with a given name that directly descend from the given tag
getDirectChildrenByName :: XMLTree -> String -> [XMLTree]
-- tree possibilities for Tag
getDirectChildrenByName (Tag ftag@(stag, Tag ftag1@(s1, _, _), _)) s
   | s1 == s = [Tag ftag1]
   | otherwise = []
getDirectChildrenByName (Tag ftag@(stag, Tree tree, _)) s =
   getDirectChildrenByNameFromList tree
   where getDirectChildrenByNameFromList :: [XMLTree] -> [XMLTree]
         getDirectChildrenByNameFromList [] = []
         getDirectChildrenByNameFromList ((Tag t@(s1, _, _)):ts) 
             | s1 == s = (Tag t):getDirectChildrenByNameFromList ts
             | otherwise = getDirectChildrenByNameFromList ts
         getDirectChildrenByNameFromList (t:ts) =
            getDirectChildrenByNameFromList ts
getDirectChildrenByName t s = []
   
-- get a list of all tags in a tree
getAllTags :: XMLTree -> [XMLTree]
getAllTags Empty = []
getAllTags (Tree []) = []
getAllTags (Tree (x:xs)) = getAllTags x ++ getAllTags (Tree xs)
getAllTags (Tag ftag@(stag, Empty, _)) = [(Tag ftag)]
getAllTags (Tag ftag@(stag, tree, _)) = (Tag ftag):getAllTags tree
getAllTags (Content c) = [(Content c)]

-- modify the name of a tag
modifyTagName :: XMLTree -> String -> XMLTree
modifyTagName (Tag (tag, tree, parent)) newName
                     = Tag (newName, tree, parent)
modifyTagName t newName = t   -- no tag; do nothing

-- get all children of a tag; if a tree return empty 
getChildren :: XMLTree -> XMLTree
getChildren Empty = Empty
getChildren (Tree t) = Empty
getChildren (Tag ftag@(stag, tree, _)) = tree 
getChildren t = Empty

-- 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 or Content of the input tree and must return resp. Tag and Content.
-- The output tree is the modified input tree.
walkATree :: XMLTree -> (XMLTree -> XMLTree) -> XMLTree
walkATree (Tag tag) f = (Tag (s, (walkATree t f), p))
   where Tag (s, t, p) = f (Tag tag)
walkATree (Tree t@(x:xs)) f
   = merge (Tree [walkATree x f])  (walkATree (Tree xs) f)
walkATree c f = f c  -- Content, Empty, Tree[]

-- 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 an XML Tree. This function is applied to every
-- Tag or Content of the input tree and must return resp. Tag and Content.
-- 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@(s, t, p)) f  
   = (f (Tag tag)) ++ selectFromTree t f
selectFromTree (Tree t@(x:xs)) f
   = selectFromTree x f ++  (selectFromTree (Tree xs) f)
selectFromTree c f = f c  -- content

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

-- show a tree including the name of the parent
showXML :: XMLTree -> String -> String
showXML Empty sep = ""
showXML (Tree []) sep = ""
showXML (Tree ((Tag tag):xs)) sep =
   (showTag tag sep) ++
   "\n" ++ (showXML (Tree xs) sep)
showXML (Tree ((Content c):xs)) sep =
   (showXML (Content c) sep) ++
   "\n" ++ (showXML (Tree xs) sep)
showXML (Tag ftag) sep = (showTag ftag sep) 
showXML (Content c@(s, p)) sep = sep ++ s ++ "\n" ++ sep ++ "Parent: "
                                 ++ (getName p) ++ "\n"

-- show a list of trees
showXMLlist :: [XMLTree] -> String
showXMLlist [] = ""
showXMLlist (x:xs) = showXML x "" ++ "\n\n" ++ showXMLlist xs

-- show a list of trees in XML format
treeListToXML :: [XMLTree] -> String
treeListToXML [] = ""
treeListToXML (x:xs) = fileToXML x ++ "\n\n" ++ treeListToXML xs

-- show a tag
showTag :: FTag -> String -> String
showTag (s, tree, parent) sep = sep ++ "<" ++ s ++ ">" ++ "\n" ++
                 (showXML tree (sep ++ ind)) ++ sep ++ "Parent: "
                 ++ (getName parent) ++ "\n"

-- get the name of a parent
getName :: XMLTree -> String
getName Empty = "Empty"
getName (Tree []) = "Empty tree"
getName (Tree (x:xs)) = "Tree"
getName (Tag ftag@(stag, _, _)) = stag 
getName (Content c@(_, p)) = getName p

-- show a tree in XML format including the xml tag
fileToXML :: XMLTree -> String
fileToXML t =  "<?xml version=\"1.0\"?>\n"  ++ toXML t ""

-- show a tree in xml format
toXML :: XMLTree -> String -> String
toXML Empty sep = ""
toXML (Tree []) sep = ""
toXML (Tree ((Tag tag):xs)) sep =
   (toXMLTag tag sep) ++ toXML (Tree xs) sep 
toXML (Tree ((Content s):xs)) sep =
   toXML (Content s) sep ++ toXML (Tree xs) sep 
toXML (Tree [Empty]) sep = sep
toXML (Tree ((Tree t):xs)) sep = (toXML (Tree t) sep) ++ toXML (Tree xs) sep 
toXML (Tree (x:xs)) sep = (toXML x sep) ++ toXML (Tree xs) sep
toXML (Content (s, _)) sep = sep ++ s ++ "\n"
toXML (Tag ftag) sep = toXMLTag ftag sep
toXML t sep = ""

-- show a tag in xml format
toXMLTag :: FTag -> String -> String
toXMLTag (s, tree, _) sep = sep ++ "<" ++ s ++ ">\n" ++ (toXML tree (sep ++ ind))
                    ++ sep ++ "</" ++ s ++ ">\n"


-- search if there is content that contains a certain string
searchContent :: [XMLTree] -> String -> Bool
searchContent [] s = False
searchContent (Content c@(s1,_):xs) s
   | containsString s s1 = True
   | otherwise = searchContent xs s
searchContent (x:xs) s = searchContent xs s

-- get content that contains a certain string
getContent :: [XMLTree] -> String -> XMLTree
getContent [] s = Empty
getContent (Content c@(s1,_):xs) s
   | containsString s s1 = Content c
   | otherwise = getContent xs s
getContent (x:xs) s = getContent xs s

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

-- test if a XMLTree is Content
testContent :: XMLTree -> Bool
testContent (Content c) = True
testContent c = False

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

-- indent constant
ind = "  "

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

-- testdata

xml = Empty
tree11 = addChild xml ("test", Empty, Empty)
tree1 = (addChild (addChild xml ("test", Empty, Empty))
                               ("test1", Empty, Empty))
tree2 = (addChild tree1 ("test2", Empty, Empty))
showTree2 = putStr( fileToXML( tree2))
tree3 = (addChild tree2 ("test", Empty, Empty))
tree4 = (addTree (addChild (addChild xml ("test", Empty, Empty))
         ("test1", Empty, Empty)) (Content ("Test content",Empty)))

test = putStr (showXML tree1 "")
test1 = putStr (showXML (getChild tree1) "")
test12 = putStr (fileToXML (getParent tree11))
test13 = putStr (fileToXML tree11)
test2 = putStr (showXML (getChildren tree3) "")
test3 = putStr (fileToXML tree3)
test4 = putStr (showXML tree3 "")
test5 = putStr (fileToXML (getChild tree1))
test51 = putStr (fileToXML (getParent (getChild tree1)))
test52 = putStr (fileToXML tree1)
test6 = putStr (showXMLlist (getChildrenByName tree3 "test"))
test7 = putStr (showXMLlist (getAllTags tree3))
test8 = putStr (fileToXML (addSerial tree3 ("add",Empty, Empty)))
test9 = putStr (showXML (addSerial tree3 ("add",Empty, Empty)) "")
test10 = putStr (fileToXML tree4)
test11 = putStr (showXML tree4 "")
test14 = putStr (showXML(addTreeAfter tree1 tree2) "")
test15 = putStr (showXML(getParent (getChild tree1)) "")
test16 = putStr (showXML(addTree tree11 (Tag ("ttt", Empty, Empty)))"")