module Html where

-- the data type for representing HTML expressions:
data HtmlExp =
   HtmlText String                               -- text string
 | HtmlStruct String [(String,String)] [HtmlExp] -- (type attrs contents)
 | HtmlElem   String [(String,String)]           -- single element like HR, BR



------------------------------------------------------------------------------
-- some useful abbreviations:

-- basic text (maybe containing special HTML chars):
htxt  :: String -> HtmlExp
htxt s = HtmlText s


-- empty expression:
hempty :: HtmlExp
hempty = HtmlText ""


-- html document
html      :: [HtmlExp] -> HtmlExp
html hexps = HtmlStruct "HTML" [] hexps

-- head
header      :: [HtmlExp] -> HtmlExp
header hexps = HtmlStruct "HEAD" [] hexps

-- title
title      :: [HtmlExp] -> HtmlExp
title hexps = HtmlStruct "TITLE" [] hexps

-- body

body      :: [HtmlExp] -> HtmlExp
body hexps = HtmlStruct "BODY" [] hexps

-- header 1:
h1      :: [HtmlExp] -> HtmlExp
h1 hexps = HtmlStruct "H1" [] hexps

-- header 2:
h2      :: [HtmlExp] -> HtmlExp
h2 hexps = HtmlStruct "H2" [] hexps

-- header 3:
h3      :: [HtmlExp] -> HtmlExp
h3 hexps = HtmlStruct "H3" [] hexps

-- header 4:
h4      :: [HtmlExp] -> HtmlExp
h4 hexps = HtmlStruct "H4" [] hexps

-- header 5:
h5      :: [HtmlExp] -> HtmlExp
h5 hexps = HtmlStruct "H5" [] hexps

-- center
center      :: [HtmlExp] -> HtmlExp
center hexps = HtmlStruct "center" [] hexps

-- paragraph:
par      :: [HtmlExp] -> HtmlExp
par hexps = HtmlStruct "P" [] hexps

-- emphasize:
emphasize      :: [HtmlExp] -> HtmlExp
emphasize hexps = HtmlStruct "EM" [] hexps

-- boldface:
bold      :: [HtmlExp] -> HtmlExp
bold hexps = HtmlStruct "B" [] hexps

-- italic:
italic      :: [HtmlExp] -> HtmlExp
italic hexps = HtmlStruct "I" [] hexps

-- underline:
underline      :: [HtmlExp] -> HtmlExp
underline hexps = HtmlStruct "U" [] hexps

-- blinking text:
blink      :: [HtmlExp] -> HtmlExp
blink hexps = HtmlStruct "BLINK" [] hexps

-- teletype font:
teletype      :: [HtmlExp] -> HtmlExp
teletype hexps = HtmlStruct "TT" [] hexps

-- unformattted, keep spaces and line breaks, don't quote special characters:
pre      :: [HtmlExp] -> HtmlExp
pre hexps = HtmlStruct "PRE" [] hexps

-- verbatim (unformatted), special characters (<,>,&,") are quoted:
verbatim  :: String -> HtmlExp
verbatim s = HtmlStruct "PRE" [] [HtmlText (htmlQuote s)]

-- address:
address      :: [HtmlExp] -> HtmlExp
address hexps = HtmlStruct "ADDRESS" [] hexps

-- hypertext reference:
href          :: String -> [HtmlExp] -> HtmlExp
href ref hexps = HtmlStruct "A" [("HREF",ref)] hexps

-- unordered list: the arguments are the list items
ulist       :: [[HtmlExp]] -> HtmlExp
ulist items = HtmlStruct "UL" [] (map litem items)

-- ordered list: the arguments are the list items
olist :: [[HtmlExp]] -> HtmlExp
olist items = HtmlStruct "OL" [] (map litem items)

-- list item:
litem hexps = HtmlStruct "LI" [] hexps

-- horizontal rule:
hrule :: HtmlExp
hrule = HtmlElem "HR" []

-- break a line:
breakline :: HtmlExp
breakline = HtmlElem "BR" []

-- image (URL, alternative text):
image :: String -> String -> HtmlExp
image src alt = HtmlElem "IMG" [("SRC",src),("ALT",alt)]

------------------------------------------------------------------------------
-- add an attribute (name/value pair) to an HTML element:

addAttr :: HtmlExp -> (String,String) -> HtmlExp
addAttr (HtmlText s) _ = HtmlText s  -- strings have no attributes
addAttr (HtmlStruct tag attrs hexps) attr =
    HtmlStruct tag (attrs++[attr]) hexps
addAttr (HtmlElem tag attrs) attr =
    HtmlElem tag (attrs++[attr])



------------------------------------------------------------------------------
-- quote special characters (<,>,&,") in a string as HTML special characters:

htmlQuote :: String -> String
htmlQuote [] = []
htmlQuote (c:cs) | c=='<' = "&lt;"   ++ htmlQuote cs
                 | c=='>' = "&gt;"   ++ htmlQuote cs
                 | c=='&' = "&amp;"  ++ htmlQuote cs
                 | c=='"' = "&quot;" ++ htmlQuote cs
                 | otherwise = c : htmlQuote cs