-- This module contains utilities for 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

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

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


-- 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 (Tag tag@(ftag, tree1, parent)) (Tag (tag2, tree2, _))
                        = Tag (ftag, addSerial tree1 ftag2, parent)
   where ftag2 = (tag2, tree2, Tag tag)
addTree (Tag tag) (Tree (x:xs)) = addTree (addTree (Tag tag) x) (Tree xs)
addTree (Tree t) _ = Empty
addTree (Tag tag@(ftag, tree1, parent)) (Content s) =
                         Tag (ftag, addContent tree1 s, parent)

-- add a tree after another tree. Use only when all tags of
-- the parent have a different name or when insertion after a
-- tag with the same name is OK !!!
addTreeAfter :: XMLTree -> XMLTree -> XMLTree
addTreeAfter Empty Empty = Empty
addTreeAfter t Empty = t
addTreeAfter (Tag t) t1 = insertAfterTag t t1 -- attention - returns the parent !!!
addTreeAfter (Tree t) t = Tree t ++ [t]

-- insert a tag. Attention: returns the parent!
-- the first tree is the parent
insertAfterTag :: XMLTree -> XMLTree -> XMLTree -> XMLTree
insertAfterTag t t1 t2
   | tag2 == tag3 = Tag (tag4, (x:t1:xs), parent2)
   | otherwise = insertAfterTag 
   where (tag1, _, parent1) = t1
         (Tag t2@(tag2, _, _) = x
         (Tag t3@(tag3, _, _) = t2
         (Tag t4@(tag4, (x:xs), parent2) = t

-- add a tree before another tree
addTreeBefore :: XMLTree -> XMLTree -> XMLTree
addTreeBefore Empty Empty = Empty
addTreeBefore t Empty = t
addTreeBefore (Tag tag@(ftag, tree1, parent)) t
                        = parent1  -- returns parent
   where (tag2, tree2, parent1) = parent
         parent1 = (tag2, t:tree2, parent1)
addTree (Tag tag) (Tree (x:xs)) = addTree (addTree (Tag tag) x) (Tree xs)
addTree (Tree t) _ = Empty
addTree (Tag tag@(ftag, tree1, parent)) (Content s) =
                         Tag (ftag, addContent tree1 s, parent)

-- 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
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])

-- add content to the end of the tree
addContent :: XMLTree -> String -> XMLTree
addContent Empty c = Content c  -- does this make sense?
addContent (Tag tag) c
                   = Tree [Tag tag, Content c]
addContent (Tree xs) c = Tree (xs ++ [(Content c)])

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

-- get achild 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

-- get all tags with a given name
getChildrenByName :: XMLTree -> String -> [XMLTree]
getChildrenByName Empty s = [Empty]
getChildrenByName (Tree []) s = [Empty]
getChildrenByName (Tree (x:xs)) s =
   (getChildrenByName x s) ++ (getChildrenByName (Tree xs) s)
getChildrenByName (Tag ftag@(stag, Empty, _)) s   -- tree possibilities for Tag
   | stag == s = [(Tag ftag)]
   | otherwise = []
getChildrenByName (Tag ftag@(stag, Tag ftag1, _)) s
   | stag == s = (Tag ftag):getChildrenByName (Tag ftag1) s
   | otherwise = getChildrenByName (Tag ftag1) s
getChildrenByName (Tag ftag@(stag, tree, _)) s
   | stag == s = (Tag ftag):getChildrenByName tree s
   | otherwise = getChildrenByName tree s
   
   
-- get a list of all tags
getAllTags :: XMLTree -> [XMLTree]
getAllTags Empty = []
getAllTags (Tree []) = []
getAllTags (Tree (x:xs)) = x:getAllTags (Tree xs)
getAllTags (Tag ftag@(stag, Empty, _)) = [(Tag ftag)]
getAllTags (Tag ftag@(stag, tree, _)) = (Tag ftag):getAllTags tree

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

-- 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 s) sep = sep ++ s

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

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

-- 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 s) = "Error content: " ++ s

-- 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 (Content s) sep = sep ++ s ++ "\n"
toXML (Tag ftag) sep = toXMLTag ftag sep

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

-- 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))
tree3 = (addChild tree2 ("test", Empty, Empty))
tree4 = (addTree (addChild (addChild xml ("test", Empty, Empty))
         ("test1", Empty, Empty)) (Content "Test content"))

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 "")