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 </>  -- combining table cells 
infixr <->  -- combining table cells
infixr +++  -- combining Html
infixr <<   -- 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 &copyand &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 HTMLbut 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     :: -> [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 [awhere
      markup xs markupList xs

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

instance (ADDATTRS b) => ADDATTRS (-> bwhere
      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)

+++ 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 gfmls
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  -> primHtml ("&" ++ ++ ";")
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 (add x colspan add y rowspan [])
              add 1 fn rest rest
              add n fn rest fn n rest
              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 cellAttrmarkup))
              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) => -> Html
debugHtml obj table [border 0<< 
                  th [bgcolor "#008888"
                     << underline
                       << "Debugging Output"
               </>  td << (map (markup debughobj)
              )
  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 hlhotLinkAttributes 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 << dtddef << 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" [value v]
hidden   n v widget "HIDDEN"   [value v]
radio    n v widget "RADIO"    [value v]
reset    n v widget "RESET"    [value v]
submit   n v widget "SUBMIT"   [value v]
password n   widget "PASSWORD" []
textfield n  widget "TEXT"     []
afile    n   widget "FILE"     []
clickmap n   widget "IMAGE"    []

menu :: String -> [Html] -> Html
menu n choices
   select [name n<< option << << 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 [] "")]


shift map (\-> "   " ++ 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 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