{-# OPTIONS_GHC -fglasgow-exts #-}

module XML where --(XML, Att, intersperse, txt, elm, with, around, comment, (-->), showXML, showXMLs)  where

import List ( intersperse )
import Data.Generics
import PPrint

import HTMLEnt ( htmlEntityEncode )

-- ADT for XML

data XML = Elm String [Att] [XML]
         | Text String
         | Comm String [String] String
         | Hole String -- where this string is the name of the variable to interpolate
  deriving (Eq, Show, Data, Typeable)
data Att = Att String String
  deriving (Eq, Show, Data, Typeable)

type XMLs = [XML]

-- constructors and helper functions

infixr 0 `with`
infix  6 -->

hole = Hole
txt = Text
elm = Elm
n `with` attrs = elm n attrs []
n `around` contents = elm n [] contents
x --> y | x == "value" = Att x y -- yet another hack... so that "  Search  "
                                 -- stays the same, instead of "& Search &ampamp;"
        | otherwise = Att x (htmlEntityEncode y)
comment ss = Comm "<!--" ss "-->"

{-

=== Example usage:

< xbutton = "input" `with` ["name"-->"btnG", "id"-->"image",
<                           "type"-->"image", "src"-->"search.png", "maxlength"-->"256"]
< xinput = "input" `with` ["size"-->"60", "id"-->"field",
<                          "name"-->"q", "type"-->"text"]

which gives

" <input name="btnG" id="image" type="image" src="search.png" alt="Search" />

and

" <input size="60" id="field" name="q" type="text" value="" maxlength="256" />

when used with ""showXML xbutton"" and ""showXML xinput""

-}

-- insert a full blank line
x <$$$> y = x <$> empty <$> y

glue xs      = foldr (<>) empty xs
glueHard xs  = foldr (<$$>) empty (map (hang 2) xs)

wrap (Elm n ats _) guts = ((text"<"<>text n<> attrs2doc ats<> text">") <> -- <>linebreak<>
                             guts <>
                          (text"</"<>text n<>text">"))
wrap _             _    = error "only use wrap for tags with contents"

sep `myjoin` ss = concat $ intersperse sep ss
nlJoin = myjoin "\n"

xmls2doc :: [XML] -> Doc
xmls2doc xs = glueHard $ map xml2doc xs

xml2doc :: XML -> Doc
xml2doc (Comm l ss r) = text l <> align (vsep ((map text ss) ++ [text r]))
--text l <$> text (nlJoin ss) <$> text r

xml2doc (Text " ") = softline
xml2doc (Text "\n") = softline
xml2doc (Text t) = text t
xml2doc (Elm n ats []) = text"<"<>text n<> attrs2doc ats<> text" />" <> softbreak

xml2doc e@(Elm _ _ cs) = wrap e guts
    where guts = (glue $ map xml2doc cs) -- <> linebreak


{--((text"<"<>text n<> attrs2doc ats<> text">") <> -- <>linebreak<>
                             guts <>
                           (text"</"<>text n<>text">")) -- <> softbreak   -}


attrs2doc []  = empty
attrs2doc ats = space <> hcat (intersperse space (map attr2doc ats))
attr2doc (Att k v) = text k <>equals<> quote v
    where quote s = dquotes $ text s

--showXML  w d = displayS (renderPretty 1.0 w (xml2doc d)) ""
--showXMLs w d = displayS (renderPretty 1.0 w (xmls2doc d)) ""