{-# LANGUAGE FlexibleInstances #-}
module XmlOut where

import Data.Char (ord, toLower, isAscii)
import Data.List (intersperse)
import Numeric (showHex)


type XML = [Element]
data Element = Etag Tag | Estr String | Eent String deriving (Show,Read)
data Tag = Tag String [Attribute] XML deriving (Show,Read)

data Attribute = String := String deriving (Show,Read)

xmlout :: XML -> String
xmlout = concatMap fe
    where
    fe (Etag t) = tagout t
    fe (Estr s) = xml_escape s
    fe (Eent s) = "&" ++ filter isAscii s ++ ";"

tagout :: Tag -> String
tagout (Tag name atts els) = case els of
    []   -> "<"++name++attstring++" />"
    els  -> "<"++name++attstring++">"++elstring++"</"++name++"\n>"
    where
    attstring = concatMap fa atts
    elstring  = xmlout els

    fa (n:=v) = " " ++ n ++ "=\"" ++ att_escape v ++ "\""

xml_escape, att_escape :: String -> String
xml_escape = xml_escape' "<>&"
att_escape = xml_escape' "<>&\""

xml_escape' escme = concatMap (\c -> if c `elem` escme || ord c > 127 then unirep c else [c])
    where
    unirep c = "&#" ++ show (ord c) ++ ";"

uri_escape :: String -> String
uri_escape = concatMap (\c -> if c `elem` safe then [c] else uni c)
  where
  safe   = alpha ++ digit ++ "$-_@.&!*\"'()+"
  alpha  = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
  digit  = "0123456789"
  uni c = "%" ++ showhex 2 (ord c)

showhex :: Int -> Int -> String
showhex len n = reverse $ take len $ reverse (showHex n "") ++ repeat '0'


addatt :: Tag -> Attribute -> Tag
addatt (Tag name atts els) att = Tag name (atts ++ [att]) els

addel :: Tag -> Element -> Tag
addel (Tag name atts els) el = Tag name atts (els ++ [el])

class TagApply t where
    tag' :: [Attribute] -> [Element] -> String -> t

instance TagApply Element where
    tag' atts els name = Etag (tag' atts els name)
instance TagApply Tag where
    tag' atts els name = Tag name (reverse atts) (reverse els)
instance (TagApply t) => TagApply (Attribute -> t) where
    tag' atts els name att = tag' (att:atts) els name
instance (TagApply t) => TagApply (Tag -> t) where
    tag' atts els name t = tag' atts (Etag t:els) name
instance (TagApply t) => TagApply (String -> t) where
    tag' atts els name s = tag' atts (Estr s:els) name
instance (TagApply t) => TagApply (XML -> t) where
    tag' atts els name x = tag' atts (reverse x ++ els) name

tag :: (TagApply t) => String -> t
tag = tag' [] []

cdata :: String -> Element
cdata = Estr

ent :: String -> Element
ent = Eent