Name
Html
Version
0.1
Description
Main import module for the Html combinators
License
The Haskell Html Library is Copyright © Andy Gill, and the Oregon Graduate Institute of Science and Technology, 1999, All rights reserved, and is distributed as free software under the license in the file "License", which is included in the distribution.
Author
Andy Gill
Restrictions
This works with all Haskell 98 compilers.
Tested
Hugs98, GHC 4.03

module Html (
      module Html,
      ) where

import qualified HtmlBlockTable as BT

infixr 3 </>  -- combining table cells 
infixr 4 <->  -- combining table cells
infixr 2 +++  -- combining Html
infixr 7 <<   -- nesting Html
infixl 8 !    -- adding optional arguments

A important property of Html is that all strings inside the structure are already in Html friendly format. For example, use of >,etc.
data Html
{-
 -    ..just..plain..normal..text... but using &copy; and &amb;, etc.
 -}
      = HtmlString String
{-
 -    <thetag {..attrs..}> ..inside.. </thetag>
 -}
      | HtmlTag {                     -- tag with an internal html
              thetag      :: String,
              attrs       :: [HtmlAttr],
              innerHtml :: [Html]
              }

{- These are the index-value pairs.
 - The empty string is a synonym for tags with no arguments.
 - (not strictly HTML, but anyway).
 -}

data HtmlAttr = HtmlAttr String String

Read MARKUP as the class of things that can be validly rendered inside MARKUP tag brackets. So this can be one or more Html's, or a String, for example.
class MARKUP a where
      markup     :: a -> [Html]
      markupList :: [a] -> [Html]

      markup _      = []
      markupList xs = concat (map markup xs)

instance MARKUP Html where
      markup a    = [a]

instance MARKUP Char where
      markup       a = markup [a]
      markupList []  = []
      markupList str = [HtmlString (stringToHtmlString str)]

instance (MARKUP a) => MARKUP [a] where
      markup xs = markupList xs

class ADDATTRS a where
      (!) :: a -> [HtmlAttr] -> a

instance (ADDATTRS b) => ADDATTRS (a -> b) where
      fn ! attr = \ arg -> fn arg ! attr

instance ADDATTRS Html where
      html@(HtmlTag {}) ! newAttrs 
               = html { attrs = attrs html ++ newAttrs }
      html ! _ = html

(<<)            :: (MARKUP a) => ([Html] -> b) -> a        -> b
fn << arg = fn (markup arg)

a +++ b       = concat [markup a,markup b]

noHtmls :: [Html]
noHtmls = [] 

tag  :: String -> [Html] -> Html
tag str       htmls =
      HtmlTag {
              thetag = str,
              attrs = [],
              innerHtml = htmls }

itag :: String -> Html
itag str = tag str []

emptyAttr :: String -> HtmlAttr
emptyAttr s = HtmlAttr s ""

intAttr :: String -> Int -> HtmlAttr
intAttr s i = HtmlAttr s (show i)

strAttr :: String -> String -> HtmlAttr
strAttr s t = HtmlAttr s t

foldHtml :: (String -> [HtmlAttr] -> [a] -> a) 
      -> (String -> a)
      -> Html
      -> a
foldHtml f g (HtmlTag str attr fmls) 
      = f str attr (map (foldHtml f g) fmls) 
foldHtml f g (HtmlString  str)           
      = g str

-- Processing Strings into Html friendly things.
-- This converts a String to a Html String.
stringToHtmlString :: String -> String
stringToHtmlString = concatMap fixChar
    where
      fixChar '<' = "&lt;"
      fixChar '>' = "&gt;"
      fixChar '&' = "&amp;"
      fixChar '"' = "&quot;"
      fixChar c   = [c]               

Classes

instance Show Html where
      showsPrec _ html = showString (prettyHtml html)
      showList htmls   = showString (concat (map show htmls))

instance Show HtmlAttr where
      showsPrec _ (HtmlAttr str val) = 
              showString str .
              showString "=" .
              shows val

Data types

type URL = String

Basic primitives

This is not processed for special chars. use stringToHtml or lineToHtml instead, for user strings, because they understand special chars, like '<'.
primHtml      :: String                                -> Html
primHtml      = HtmlString

Basic Combinators

stringToHtml          :: String                       -> Html
stringToHtml = primHtml . stringToHtmlString 

This converts a string, but keeps spaces as non-line-breakable
lineToHtml            :: String                       -> Html
lineToHtml = primHtml . concatMap htmlizeChar2 . stringToHtmlString 
   where 
      htmlizeChar2 ' ' = "&nbsp;"
      htmlizeChar2 c   = [c]

Html Constructors

-- (automatically generated)

address             :: [Html] -> Html
anchor              :: [Html] -> Html
applet              :: [Html] -> Html
area                ::           Html
basefont            ::           Html
big                 :: [Html] -> Html
blockquote          :: [Html] -> Html
body                :: [Html] -> Html
bold                :: [Html] -> Html
br                  ::           Html
caption             :: [Html] -> Html
center              :: [Html] -> Html
cite                :: [Html] -> Html
ddef                :: [Html] -> Html
define              :: [Html] -> Html
dlist               :: [Html] -> Html
dterm               :: [Html] -> Html
emphasize           :: [Html] -> Html
fieldset            :: [Html] -> Html
font                :: [Html] -> Html
form                :: [Html] -> Html
frame               :: [Html] -> Html
frameset            :: [Html] -> Html
h1                  :: [Html] -> Html
h2                  :: [Html] -> Html
h3                  :: [Html] -> Html
h4                  :: [Html] -> Html
h5                  :: [Html] -> Html
h6                  :: [Html] -> Html
header              :: [Html] -> Html
hr                  ::           Html
image               ::           Html
input               ::           Html
italics             :: [Html] -> Html
keyboard            :: [Html] -> Html
legend              :: [Html] -> Html
li                  :: [Html] -> Html
meta                ::           Html
noframes            :: [Html] -> Html
olist               :: [Html] -> Html
option              :: [Html] -> Html
paragraph           :: [Html] -> Html
param               ::           Html
pre                 :: [Html] -> Html
sample              :: [Html] -> Html
select              :: [Html] -> Html
small               :: [Html] -> Html
strong              :: [Html] -> Html
style               :: [Html] -> Html
sub                 :: [Html] -> Html
sup                 :: [Html] -> Html
table               :: [Html] -> Html
td                  :: [Html] -> Html
textarea            :: [Html] -> Html
th                  :: [Html] -> Html
thebase             ::           Html
thecode             :: [Html] -> Html
thediv              :: [Html] -> Html
thehtml             :: [Html] -> Html
thelink             :: [Html] -> Html
themap              :: [Html] -> Html
thetitle            :: [Html] -> Html
tr                  :: [Html] -> Html
tt                  :: [Html] -> Html
ulist               :: [Html] -> Html
underline           :: [Html] -> Html
variable            :: [Html] -> Html

address             =  tag "ADDRESS"
anchor              =  tag "A"
applet              =  tag "APPLET"
area                = itag "AREA"
basefont            = itag "BASEFONT"
big                 =  tag "BIG"
blockquote          =  tag "BLOCKQUOTE"
body                =  tag "BODY"
bold                =  tag "B"
br                  = itag "BR"
caption             =  tag "CAPTION"
center              =  tag "CENTER"
cite                =  tag "CITE"
ddef                =  tag "DD"
define              =  tag "DFN"
dlist               =  tag "DL"
dterm               =  tag "DT"
emphasize           =  tag "EM"
fieldset            =  tag "FIELDSET"
font                =  tag "FONT"
form                =  tag "FORM"
frame               =  tag "FRAME"
frameset            =  tag "FRAMESET"
h1                  =  tag "H1"
h2                  =  tag "H2"
h3                  =  tag "H3"
h4                  =  tag "H4"
h5                  =  tag "H5"
h6                  =  tag "H6"
header              =  tag "HEAD"
hr                  = itag "HR"
image               = itag "IMG"
input               = itag "INPUT"
italics             =  tag "I"
keyboard            =  tag "KBD"
legend              =  tag "LEGEND"
li                  =  tag "LI"
meta                = itag "META"
noframes            =  tag "NOFRAMES"
olist               =  tag "OL"
option              =  tag "OPTION"
paragraph           =  tag "P"
param               = itag "PARAM"
pre                 =  tag "PRE"
sample              =  tag "SAMP"
select              =  tag "SELECT"
small               =  tag "SMALL"
strong              =  tag "STRONG"
style               =  tag "STYLE"
sub                 =  tag "SUB"
sup                 =  tag "SUP"
table               =  tag "TABLE"
td                  =  tag "TD"
textarea            =  tag "TEXTAREA"
th                  =  tag "TH"
thebase             = itag "BASE"
thecode             =  tag "CODE"
thediv              =  tag "DIV"
thehtml             =  tag "HTML"
thelink             =  tag "LINK"
themap              =  tag "MAP"
thetitle            =  tag "TITLE"
tr                  =  tag "TR"
tt                  =  tag "TT"
ulist               =  tag "UL"
underline           =  tag "U"
variable            =  tag "VAR"

Html Attributes

-- (automatically generated)

action              :: String -> HtmlAttr
align               :: String -> HtmlAttr
alink               :: String -> HtmlAttr
alt                 :: String -> HtmlAttr
altcode             :: String -> HtmlAttr
archive             :: String -> HtmlAttr
background          :: String -> HtmlAttr
base                :: String -> HtmlAttr
bgcolor             :: String -> HtmlAttr
border              :: Int    -> HtmlAttr
bordercolor         :: String -> HtmlAttr
cellpadding         :: Int    -> HtmlAttr
cellspacing         :: Int    -> HtmlAttr
checked             ::           HtmlAttr
clear               :: String -> HtmlAttr
code                :: String -> HtmlAttr
codebase            :: String -> HtmlAttr
color               :: String -> HtmlAttr
cols                :: String -> HtmlAttr
colspan             :: Int    -> HtmlAttr
compact             ::           HtmlAttr
content             :: String -> HtmlAttr
coords              :: String -> HtmlAttr
enctype             :: String -> HtmlAttr
face                :: String -> HtmlAttr
frameborder         :: Int    -> HtmlAttr
height              :: Int    -> HtmlAttr
href                :: String -> HtmlAttr
hspace              :: Int    -> HtmlAttr
httpequiv           :: String -> HtmlAttr
identity            :: String -> HtmlAttr
ismap               ::           HtmlAttr
lang                :: String -> HtmlAttr
link                :: String -> HtmlAttr
marginheight        :: Int    -> HtmlAttr
marginwidth         :: Int    -> HtmlAttr
maxlength           :: Int    -> HtmlAttr
method              :: String -> HtmlAttr
multiple            ::           HtmlAttr
name                :: String -> HtmlAttr
nohref              ::           HtmlAttr
noresize            ::           HtmlAttr
noshade             ::           HtmlAttr
nowrap              ::           HtmlAttr
rel                 :: String -> HtmlAttr
rev                 :: String -> HtmlAttr
rows                :: String -> HtmlAttr
rowspan             :: Int    -> HtmlAttr
rules               :: String -> HtmlAttr
scrolling           :: String -> HtmlAttr
selected            ::           HtmlAttr
shape               :: String -> HtmlAttr
size                :: String -> HtmlAttr
src                 :: String -> HtmlAttr
start               :: Int    -> HtmlAttr
target              :: String -> HtmlAttr
text                :: String -> HtmlAttr
theclass            :: String -> HtmlAttr
thestyle            :: String -> HtmlAttr
thetype             :: String -> HtmlAttr
title               :: String -> HtmlAttr
usemap              :: String -> HtmlAttr
valign              :: String -> HtmlAttr
value               :: String -> HtmlAttr
version             :: String -> HtmlAttr
vlink               :: String -> HtmlAttr
vspace              :: Int    -> HtmlAttr
width               :: String -> HtmlAttr

action              =   strAttr "ACTION"
align               =   strAttr "ALIGN"
alink               =   strAttr "ALINK"
alt                 =   strAttr "ALT"
altcode             =   strAttr "ALTCODE"
archive             =   strAttr "ARCHIVE"
background          =   strAttr "BACKGROUND"
base                =   strAttr "BASE"
bgcolor             =   strAttr "BGCOLOR"
border              =   intAttr "BORDER"
bordercolor         =   strAttr "BORDERCOLOR"
cellpadding         =   intAttr "CELLPADDING"
cellspacing         =   intAttr "CELLSPACING"
checked             = emptyAttr "CHECKED"
clear               =   strAttr "CLEAR"
code                =   strAttr "CODE"
codebase            =   strAttr "CODEBASE"
color               =   strAttr "COLOR"
cols                =   strAttr "COLS"
colspan             =   intAttr "COLSPAN"
compact             = emptyAttr "COMPACT"
content             =   strAttr "CONTENT"
coords              =   strAttr "COORDS"
enctype             =   strAttr "ENCTYPE"
face                =   strAttr "FACE"
frameborder         =   intAttr "FRAMEBORDER"
height              =   intAttr "HEIGHT"
href                =   strAttr "HREF"
hspace              =   intAttr "HSPACE"
httpequiv           =   strAttr "HTTPEQUIV"
identity            =   strAttr "ID"
ismap               = emptyAttr "ISMAP"
lang                =   strAttr "LANG"
link                =   strAttr "LINK"
marginheight        =   intAttr "MARGINHEIGHT"
marginwidth         =   intAttr "MARGINWIDTH"
maxlength           =   intAttr "MAXLENGTH"
method              =   strAttr "METHOD"
multiple            = emptyAttr "MULTIPLE"
name                =   strAttr "NAME"
nohref              = emptyAttr "NOHREF"
noresize            = emptyAttr "NORESIZE"
noshade             = emptyAttr "NOSHADE"
nowrap              = emptyAttr "NOWRAP"
rel                 =   strAttr "REL"
rev                 =   strAttr "REV"
rows                =   strAttr "ROWS"
rowspan             =   intAttr "ROWSPAN"
rules               =   strAttr "RULES"
scrolling           =   strAttr "SCROLLING"
selected            = emptyAttr "SELECTED"
shape               =   strAttr "SHAPE"
size                =   strAttr "SIZE"
src                 =   strAttr "SRC"
start               =   intAttr "START"
target              =   strAttr "TARGET"
text                =   strAttr "TEXT"
theclass            =   strAttr "CLASS"
thestyle            =   strAttr "STYLE"
thetype             =   strAttr "TYPE"
title               =   strAttr "TITLE"
usemap              =   strAttr "USEMAP"
valign              =   strAttr "VALIGN"
value               =   strAttr "VALUE"
version             =   strAttr "VERSION"
vlink               =   strAttr "VLINK"
vspace              =   intAttr "VSPACE"
width               =   strAttr "WIDTH"

-- (automatically generated)

validHtmlTags :: [String]
validHtmlTags = [
      "ADDRESS",
      "A",
      "APPLET",
      "BIG",
      "BLOCKQUOTE",
      "BODY",
      "B",
      "CAPTION",
      "CENTER",
      "CITE",
      "DD",
      "DFN",
      "DL",
      "DT",
      "EM",
      "FIELDSET",
      "FONT",
      "FORM",
      "FRAME",
      "FRAMESET",
      "H1",
      "H2",
      "H3",
      "H4",
      "H5",
      "H6",
      "HEAD",
      "I",
      "KBD",
      "LEGEND",
      "LI",
      "NOFRAMES",
      "OL",
      "OPTION",
      "P",
      "PRE",
      "SAMP",
      "SELECT",
      "SMALL",
      "STRONG",
      "STYLE",
      "SUB",
      "SUP",
      "TABLE",
      "TD",
      "TEXTAREA",
      "TH",
      "CODE",
      "DIV",
      "HTML",
      "LINK",
      "MAP",
      "TITLE",
      "TR",
      "TT",
      "UL",
      "U",
      "VAR"]

validHtmlITags :: [String]
validHtmlITags = [
      "AREA",
      "BASEFONT",
      "BR",
      "HR",
      "IMG",
      "INPUT",
      "META",
      "PARAM",
      "BASE"]

validHtmlAttrs :: [String]
validHtmlAttrs = [
      "ACTION",
      "ALIGN",
      "ALINK",
      "ALT",
      "ALTCODE",
      "ARCHIVE",
      "BACKGROUND",
      "BASE",
      "BGCOLOR",
      "BORDER",
      "BORDERCOLOR",
      "CELLPADDING",
      "CELLSPACING",
      "CHECKED",
      "CLEAR",
      "CODE",
      "CODEBASE",
      "COLOR",
      "COLS",
      "COLSPAN",
      "COMPACT",
      "CONTENT",
      "COORDS",
      "ENCTYPE",
      "FACE",
      "FRAMEBORDER",
      "HEIGHT",
      "HREF",
      "HSPACE",
      "HTTPEQUIV",
      "ID",
      "ISMAP",
      "LANG",
      "LINK",
      "MARGINHEIGHT",
      "MARGINWIDTH",
      "MAXLENGTH",
      "METHOD",
      "MULTIPLE",
      "NAME",
      "NOHREF",
      "NORESIZE",
      "NOSHADE",
      "NOWRAP",
      "REL",
      "REV",
      "ROWS",
      "ROWSPAN",
      "RULES",
      "SCROLLING",
      "SELECTED",
      "SHAPE",
      "SIZE",
      "SRC",
      "START",
      "TARGET",
      "TEXT",
      "CLASS",
      "STYLE",
      "TYPE",
      "TITLE",
      "USEMAP",
      "VALIGN",
      "VALUE",
      "VERSION",
      "VLINK",
      "VSPACE",
      "WIDTH"]

Html colors

aqua          :: String
black         :: String
blue          :: String
fuchsia       :: String
gray          :: String
green         :: String
lime          :: String
maroon        :: String
navy          :: String
olive         :: String
purple        :: String
red           :: String
silver        :: String
teal          :: String
yellow        :: String
white         :: String

aqua          = "aqua"
black         = "black"
blue          = "blue"
fuchsia       = "fuchsia"
gray          = "gray"
green         = "green"
lime          = "lime"
maroon        = "maroon"
navy          = "navy"
olive         = "olive"
purple        = "purple"
red           = "red"
silver        = "silver"
teal          = "teal"
yellow        = "yellow"
white         = "white"

Basic Combinators

linesToHtml :: [String]       -> [Html]

linesToHtml []     = []
linesToHtml (x:[]) = [lineToHtml x]
linesToHtml (x:xs) = lineToHtml x +++ br +++ linesToHtml xs

Html abbriviations

primHtmlChar  :: String -> Html
copyright     :: Html
spaceHtml     :: Html
bullet        :: Html
p             :: [Html] -> Html

primHtmlChar  = \ x -> primHtml ("&" ++ x ++ ";")
copyright     = primHtmlChar "copy"
spaceHtml     = primHtmlChar "nbsp"
bullet        = primHtmlChar "#149"

p             = paragraph

Html tables

class HTMLTABLE ht where
      cell :: ht -> HtmlTable

instance HTMLTABLE HtmlTable where
      cell = id

instance HTMLTABLE Html where
      cell h = 
         let
              cellFn x y = h ! (add x colspan $ add y rowspan $ [])
              add 1 fn rest = rest
              add n fn rest = fn n : rest
              r = BT.single cellFn
         in 
              mkHtmlTable r

We internally represent the Cell inside a Table with an object of the type 
 	Int -> Int -> Html
When we render it later, we find out how many columns or rows this cell will span over, and can include the correct colspan/rowspan command.
newtype HtmlTable 
      = HtmlTable (BT.BlockTable (Int -> Int -> Html))


(</>),above,(<->),beside :: (HTMLTABLE ht1,HTMLTABLE ht2)
                       => ht1 -> ht2 -> HtmlTable
aboves,besides                 :: (HTMLTABLE ht) => [ht] -> HtmlTable
simpleTable            :: [HtmlAttr] -> [HtmlAttr] -> [[Html]] -> Html


mkHtmlTable :: BT.BlockTable (Int -> Int -> Html) -> HtmlTable
mkHtmlTable r = HtmlTable r

We give both infix and nonfix, take your pick. Notice that there is no concept of a row/column of zero items.
above   a b = combine BT.above (cell a) (cell b)
(</>)         = above
beside  a b = combine BT.beside (cell a) (cell b)
(<->) = beside

combine fn (HtmlTable a) (HtmlTable b) = mkHtmlTable (a `fn` b)

Both aboves and besides presume a non-empty list. here is no concept of a empty row or column in these table combinators.
aboves []  = error "aboves []"
aboves xs  = foldr1 (</>) (map cell xs)
besides [] = error "besides []"
besides xs = foldr1 (<->) (map cell xs)

renderTable takes the HtmlTable, and renders it back into and Html object.
renderTable :: BT.BlockTable (Int -> Int -> Html) -> [Html]
renderTable theTable
      = [tr [theCell x y | (theCell,(x,y)) <- theRow ]
                      | theRow <- BT.getMatrix theTable]

instance MARKUP HtmlTable where
      markup (HtmlTable tab) = renderTable tab

instance Show HtmlTable where
      showsPrec _ (HtmlTable tab) = shows (renderTable tab)

If you can't be bothered with the above, then you can build simple tables with simpleTable. Just provide the attributes for the whole table, attributes for the cells (same for every cell), and a list of lists of cell contents, and this function will build the table for you. It does presume that all the lists are non-empty, and there is at least one list. Different length lists means that the last cell gets padded. If you want more power, then use the system above, or build tables explicitly.
simpleTable attr cellAttr lst
      = table ! attr 
          <<  (aboves 
              . map (besides . map ((td ! cellAttr) . markup))
              ) lst

Tree Displaying Combinators

The basic idea is you render your structure in the form of this tree, and then use treeHtml to turn it into a Html object with the structure explicit.
data HtmlTree
      = HtmlLeaf [Html]
      | HtmlNode [Html] [HtmlTree] [Html]

treeHtml :: [String] -> HtmlTree -> Html
treeHtml colors h = table ! [
                    border 0,
                    cellpadding 0,
                    cellspacing 2] << treeHtml' colors h
     where
      manycolors = scanr (:) []

      treeHtmls :: [[String]] -> [HtmlTree] -> HtmlTable
      treeHtmls c ts = aboves (zipWith treeHtml' c ts)

      treeHtml' :: [String] -> HtmlTree -> HtmlTable
      treeHtml' (c:_) (HtmlLeaf leaf) = cell
                                         (td ! [width "100%"] 
                                            << bold  
                                               << leaf)
      treeHtml' (c:cs@(c2:_)) (HtmlNode hopen ts hclose) =
          if null ts && null hclose
          then
              cell hd 
          else if null ts
          then
              hd </> bar `beside` (td ! [bgcolor c2] << spaceHtml)
                 </> tl
          else
              hd </> (bar `beside` treeHtmls morecolors ts)
                 </> tl
        where
              -- This stops a column of colors being the same
              -- color as the immeduately outside nesting bar.
              morecolors = filter ((/= c).head) (manycolors cs)
              bar = td ! [bgcolor c,width "10"] << spaceHtml
              hd = td ! [bgcolor c] << hopen
              tl = td ! [bgcolor c] << hclose
      treeHtml' _ _ = error "The imposible happens"

instance MARKUP HtmlTree where
      markup x = [treeHtml treeColors x]

-- type "length treeColors" to see how many colors are here.
treeColors = ["#88ccff","#ffffaa","#ffaaff","#ccffff"] ++ treeColors

Html Debugging Combinators

This uses the above tree rendering function, and displays the Html as a tree structure, allowing debugging of what is actually getting produced.
debugHtml :: (MARKUP a) => a -> Html
debugHtml obj = table ! [border 0] << 
                  ( th ! [bgcolor "#008888"] 
                     << underline
                       << "Debugging Output"
               </>  td << (map (markup . debug) hobj)
              )
  where
      hobj = markup obj

      debug :: Html -> HtmlTree
      debug (HtmlString str) = HtmlLeaf (spaceHtml : markup str)
      debug (HtmlTag {
              thetag = thetag,
              innerHtml = innerHtml,
              attrs  = attrs
              }) = 
              case innerHtml of
                [] -> HtmlNode [hd] [] []
                xs -> HtmlNode [hd] (map debug xs) [tl]
        where
              args = unwords (map show attrs)
              hd = font ! [size "1"] << ("<" ++ thetag ++ " " ++ args ++ ">")
              tl = font ! [size "1"] << ("</" ++ thetag ++ ">")

Hotlink datatype

data HotLink = HotLink {
      hotLinkURL        :: URL,
      hotLinkContents   :: [Html],
      hotLinkAttributes :: [HtmlAttr]
      } deriving Show

instance MARKUP HotLink where
      markup hl = [anchor ! (href (hotLinkURL hl) : hotLinkAttributes hl)
                      << hotLinkContents hl]

hotlink :: URL -> [Html] -> HotLink
hotlink url h = HotLink {
      hotLinkURL = url,
      hotLinkContents = h,
      hotLinkAttributes = [] }

More Combinators

-- (Abridged from Erik Meijer's Original Html library)

ordList   :: (MARKUP a) => [a] -> Html
ordList items = olist << map (li <<) items

unordList :: (MARKUP a) => [a] -> Html
unordList items = ulist << map (li <<) items

defList   :: (MARKUP a,MARKUP b) => [(a,b)] -> Html
defList items
 = dlist << [ [ dterm << bold << dt, ddef << dd ] | (dt,dd) <- items ]


widget :: String -> String -> [HtmlAttr] -> Html
widget w n attrs = input ! ([thetype w,name n] ++ attrs)

checkbox :: String -> String -> Html
hidden   :: String -> String -> Html
radio    :: String -> String -> Html
reset    :: String -> String -> Html
submit   :: String -> String -> Html
password :: String           -> Html
textfield :: String          -> Html
afile    :: String           -> Html
clickmap :: String           -> Html

checkbox n v = widget "CHECKBOX" n [value v]
hidden   n v = widget "HIDDEN"   n [value v]
radio    n v = widget "RADIO"    n [value v]
reset    n v = widget "RESET"    n [value v]
submit   n v = widget "SUBMIT"   n [value v]
password n   = widget "PASSWORD" n []
textfield n  = widget "TEXT"     n []
afile    n   = widget "FILE"     n []
clickmap n   = widget "IMAGE"    n []

menu :: String -> [Html] -> Html
menu n choices
   = select ! [name n] << [ option << p << choice | choice <- choices ]

gui :: String -> [Html] -> Html
gui act = form ! [action act,method "POST"]

Html Rendering

Uses the append trick to optimize appending. The output is quite messy, because space matters in HTML, so we must not generate needless spaces.
renderHtml :: (MARKUP html) => html -> String
renderHtml theHtml =
      renderMessage ++ renderHtml' 0 (tag "HTML" << theHtml) "\n"

renderMessage =
      "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 FINAL//EN\">\n" ++
      "<!--Rendered using the Haskell Html Library v0.1-->\n"

Warning: spaces matters in HTML. You are better using renderHtml. This is intentually very inefficent to "encorage" this, but the neater version in easier when debugging.
-- Local Utilities
prettyHtml :: (MARKUP html) => html -> String
prettyHtml theHtml = unlines $ concat $ map prettyHtml' $ markup theHtml

renderHtml' :: Int -> Html -> ShowS
renderHtml' _ (HtmlString str) = (++) str
renderHtml' n (HtmlTag
              { thetag = name,
                innerHtml = html,
                attrs = attrs })
      = if null html && elem name validHtmlITags
        then renderTag True name attrs n
        else (renderTag True name attrs n
             . foldr (.) id (map (renderHtml' (n+2)) html)
             . renderTag False name [] n)

prettyHtml' :: Html -> [String]
prettyHtml' (HtmlString str) = [str]
prettyHtml' (HtmlTag
              { thetag = name,
                innerHtml = html,
                attrs = attrs })
      = if null html && elem name validHtmlITags
        then 
         [rmNL (renderTag True name attrs 0 "")]
        else
         [rmNL (renderTag True name attrs 0 "")] ++ 
          shift (concat (map prettyHtml' html)) ++
         [rmNL (renderTag False name [] 0 "")]


shift = map (\x -> "   " ++ x)
rmNL = filter (/= '\n')

This prints the Tags The lack of spaces in intentunal, because Html is actually space dependant.
renderTag :: Bool -> String -> [HtmlAttr] -> Int -> ShowS
renderTag x name attrs n r
      = open ++ name ++ rest attrs ++ ">" ++ r
  where
      open = if x then "<" else "</"
      
      nl = "\n" ++ replicate (n `div` 8) '\t' 
                ++ replicate (n `mod` 8) ' '

      rest []   = nl
      rest attr = " " ++ unwords (map showPair attr) ++ nl

      showPair :: HtmlAttr -> String
      showPair (HtmlAttr tag val)
              = tag ++ " = \"" ++ val  ++ "\""

-- End of Local Utilities