[haddock @ 2002-04-08 16:41:37 by simonmar]

- Add our own versions of Html & BlockTable for the time being.
- Add support for generating an index to the HTML backend

3 files changed, 1335 insertions, 90 deletions

diff --git a/src/BlockTable.hs b/src/BlockTable.hs
new file mode 100644
index 00000000..af540f4a
--- /dev/null
+++ b/src/BlockTable.hs
@@ -0,0 +1,180 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Text.Html.BlockTable
+-- Copyright   :  (c) Andy Gill, and the Oregon Graduate Institute of 
+--		  Science and Technology, 1999-2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  Andy Gill <andy@galconn.com>
+-- Stability   :  experimental
+-- Portability :  portable
+--
+-- $Id: BlockTable.hs,v 1.1 2002/04/08 16:41:37 simonmar Exp $
+--
+-- An Html combinator library
+--
+-----------------------------------------------------------------------------
+
+module BlockTable (
+
+-- Datatypes:
+
+      BlockTable,             -- abstract
+
+-- Contruction Functions: 
+
+      single,
+      empty,
+      above,
+      beside,
+
+-- Investigation Functions: 
+
+      getMatrix,
+      showsTable,
+      showTable,
+
+      ) where
+
+import Prelude
+
+infixr 4 `beside`
+infixr 3 `above`
+
+-- These combinators can be used to build formated 2D tables.
+-- The specific target useage is for HTML table generation.
+
+{-
+   Examples of use:
+
+  	> table1 :: BlockTable String
+  	> table1 = single "Hello"	+-----+
+					|Hello|
+	  This is a 1x1 cell		+-----+
+	  Note: single has type
+	 
+		single :: a -> BlockTable a
+	
+	  So the cells can contain anything.
+	
+	> table2 :: BlockTable String
+	> table2 = single "World"	+-----+
+					|World|
+					+-----+
+
+
+	> table3 :: BlockTable String
+	> table3 = table1 %-% table2	+-----%-----+
+					|Hello%World|
+	 % is used to indicate		+-----%-----+
+	 the join edge between
+	 the two Tables.  
+
+	> table4 :: BlockTable String
+	> table4 = table3 %/% table2	+-----+-----+
+					|Hello|World|
+	  Notice the padding on the	%%%%%%%%%%%%%
+	  smaller (bottom) cell to	|World      |
+	  force the table to be a	+-----------+
+	  rectangle.
+
+	> table5 :: BlockTable String
+	> table5 = table1 %-% table4	+-----%-----+-----+
+					|Hello%Hello|World|
+	  Notice the padding on the	|     %-----+-----+
+	  leftmost cell, again to	|     %World      |
+	  force the table to be a	+-----%-----------+
+	  rectangle.
+ 
+   Now the table can be rendered with processTable, for example:
+	Main> processTable table5
+	[[("Hello",(1,2)),
+	  ("Hello",(1,1)),
+	  ("World",(1,1))],
+	 [("World",(2,1))]] :: [[([Char],(Int,Int))]]
+	Main> 
+-}
+
+-- ---------------------------------------------------------------------------
+-- Contruction Functions
+
+-- Perhaps one day I'll write the Show instance
+-- to show boxes aka the above ascii renditions.
+
+instance (Show a) => Show (BlockTable a) where
+      showsPrec p = showsTable
+
+type TableI a = [[(a,(Int,Int))]] -> [[(a,(Int,Int))]]
+
+data BlockTable a = Table (Int -> Int -> TableI a) Int Int
+
+
+-- You can create a (1x1) table entry
+
+single :: a -> BlockTable a
+single a = Table (\ x y r -> [(a,(x+1,y+1))] : r) 1 1
+
+empty :: BlockTable a
+empty = Table (\ x y r -> r) 0 0
+
+
+-- You can compose tables, horizonally and vertically
+
+above  :: BlockTable a -> BlockTable a -> BlockTable a
+beside :: BlockTable a -> BlockTable a -> BlockTable a
+
+t1 `above` t2 = trans (combine (trans t1) (trans t2) (.))
+
+t1 `beside` t2 = combine t1 t2 (\ lst1 lst2 r ->
+    let
+      -- Note this depends on the fact that
+      -- that the result has the same number
+      -- of lines as the y dimention; one list
+      -- per line. This is not true in general
+      -- but is always true for these combinators.
+      -- I should assert this!
+      -- I should even prove this.
+      beside (x:xs) (y:ys) = (x ++ y) : beside xs ys
+      beside (x:xs) []     = x        : xs ++ r
+      beside []     (y:ys) = y        : ys ++ r
+      beside []     []     =                  r
+    in
+      beside (lst1 []) (lst2 []))
+
+-- trans flips (transposes) over the x and y axis of
+-- the table. It is only used internally, and typically
+-- in pairs, ie. (flip ... munge ... (un)flip).
+
+trans :: BlockTable a -> BlockTable a
+trans (Table f1 x1 y1) = Table (flip f1) y1 x1
+
+combine :: BlockTable a 
+      -> BlockTable b 
+      -> (TableI a -> TableI b -> TableI c) 
+      -> BlockTable c
+combine (Table f1 x1 y1) (Table f2 x2 y2) comb = Table new_fn (x1+x2) max_y
+    where
+      max_y = max y1 y2
+      new_fn x y =
+         case compare y1 y2 of
+          EQ -> comb (f1 0 y)             (f2 x y)
+          GT -> comb (f1 0 y)             (f2 x (y + y1 - y2))
+          LT -> comb (f1 0 (y + y2 - y1)) (f2 x y)
+
+-- ---------------------------------------------------------------------------
+-- Investigation Functions
+
+-- This is the other thing you can do with a Table;
+-- turn it into a 2D list, tagged with the (x,y)
+-- sizes of each cell in the table.
+
+getMatrix :: BlockTable a -> [[(a,(Int,Int))]]
+getMatrix (Table r _ _) = r 0 0 []
+
+-- You can also look at a table
+
+showsTable :: (Show a) => BlockTable a -> ShowS
+showsTable table = shows (getMatrix table)
+
+showTable :: (Show a) => BlockTable a -> String
+showTable table = showsTable table ""
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 21b69499..461b698a 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -13,11 +13,11 @@ import HsSyn
 
 import Maybe	( fromJust, isJust )
 import FiniteMap
+import List 	( sortBy )
+import Char	( toUpper, toLower )
+import Monad	( when )
 
-import Html	hiding (text, above, beside, aboves, 
-			besides, (</>), (<->), td, 
-			renderHtml, renderMessage, renderHtml')
-import qualified HtmlBlockTable as BT
+import Html
 import qualified Html
 
 -- -----------------------------------------------------------------------------
@@ -25,14 +25,17 @@ import qualified Html
 
 ppHtml :: String -> Maybe String -> [(Module, Interface)] -> IO ()
 ppHtml title source_url ifaces =  do
-  ppHtmlIndex title source_url (map fst ifaces)
+  ppHtmlContents title source_url (map fst ifaces)
+  ppHtmlIndex title ifaces
   mapM_ (ppHtmlModule title source_url) ifaces
 
 moduleHtmlFile :: String -> FilePath
 moduleHtmlFile mod = mod ++ ".html" -- ToDo: Z-encode filename?
 
-indexHtmlFile = "index.html"
-styleSheetFile = "haddock.css"
+contentsHtmlFile = "index.html"
+indexHtmlFile    = "doc-index.html"
+styleSheetFile   = "haddock.css"
+subIndexHtmlFile k a = "doc-index-" ++ k:a:".html"
 
 footer = 
   tda [theclass "botbar"] << 
@@ -42,35 +45,39 @@ footer =
 	)
    
 
-simpleHeader title = 
-  (tda [theclass "topbar"] << 
-     vanillaTable << (
-       (td << 
-  	image ! [src "haskell_icon.gif", width "16", height 16, alt " " ]
-       ) <->
-       (tda [theclass "title"] << toHtml title)
-   ))
-
-buttons1 source_url mod file
+src_button source_url mod file
   | Just u <- source_url = 
 	let src_url = if (last u == '/') then u ++ file else u ++ '/':file
 	in
 	(tda [theclass "topbut", nowrap] <<
-  	   anchor ! [href src_url] << toHtml "Source code") <-> buttons2 mod
+  	   anchor ! [href src_url] << toHtml "Source code")
   | otherwise =
-	buttons2 mod
+	Html.emptyTable
   
 
-buttons2 mod = 
+parent_button mod = 
   case span (/= '.') (reverse mod) of
    (m, '.':rest) -> 
        (tda [theclass "topbut", nowrap] <<
-  	 anchor ! [href (moduleHtmlFile (reverse rest))] << toHtml "Parent") <->
-	contentsButton
-   _ -> cell contentsButton
+  	 anchor ! [href (moduleHtmlFile (reverse rest))] << toHtml "Parent")
+   _ -> 
+	Html.emptyTable
+
+contentsButton = tda [theclass "topbut", nowrap] <<
+  	 	    anchor ! [href contentsHtmlFile] << toHtml "Contents"
+
+indexButton = tda [theclass "topbut", nowrap] <<
+  	 	    anchor ! [href indexHtmlFile] << toHtml "Index"
 
-contentsButton = (tda [theclass "topbut", nowrap] <<
-  	 	    anchor ! [href indexHtmlFile] << toHtml "Contents")
+simpleHeader title = 
+  (tda [theclass "topbar"] << 
+     vanillaTable << (
+       (td << 
+  	image ! [src "haskell_icon.gif", width "16", height 16, alt " " ]
+       ) <->
+       (tda [theclass "title"] << toHtml title) <->
+	contentsButton <-> indexButton
+   ))
 
 pageHeader mod iface title source_url =
   (tda [theclass "topbar"] << 
@@ -79,7 +86,10 @@ pageHeader mod iface title source_url =
   	image ! [src "haskell_icon.gif", width "16", height 16, alt " "]
        ) <->
        (tda [theclass "title"] << toHtml title) <->
-	buttons1 source_url mod (iface_filename iface)
+	src_button source_url mod (iface_filename iface) <->
+	parent_button mod <->
+	contentsButton <->
+	indexButton
     )
    ) </>
    tda [theclass "modulebar"] <<
@@ -104,27 +114,27 @@ pageHeader mod iface title source_url =
     )
 
 -- ---------------------------------------------------------------------------
--- Generate the module index
+-- Generate the module contents
 
-ppHtmlIndex :: String -> Maybe String -> [Module] -> IO ()
-ppHtmlIndex title source_url mods = do
+ppHtmlContents :: String -> Maybe String -> [Module] -> IO ()
+ppHtmlContents title source_url mods = do
   let tree = mkModuleTree mods  
       html = 
 	header (thetitle (toHtml title) +++
-		mylink ! [href styleSheetFile, 
+		thelink ! [href styleSheetFile, 
 		  rel "stylesheet", thetype "text/css"]) +++
         body <<  
 	  table ! [width "100%", cellpadding 0, cellspacing 1] << (
    	    simpleHeader title </>
-	    td << (ppModuleTree title tree) </>
+	    ppModuleTree title tree </>
 	    footer
 	  )
-  writeFile indexHtmlFile (renderHtml html)
+  writeFile contentsHtmlFile (renderHtml html)
 
-ppModuleTree :: String -> [ModuleTree] -> Html
+ppModuleTree :: String -> [ModuleTree] -> HtmlTable
 ppModuleTree title ts = 
-  h1 << toHtml "Modules" +++
-  table ! [cellpadding 0, cellspacing 2] << aboves (map (mkNode []) ts)
+  tda [theclass "section1"] << toHtml "Modules" </>
+  td <<  table ! [cellpadding 0, cellspacing 2] << aboves (map (mkNode []) ts)
 
 mkNode :: [String] -> ModuleTree -> HtmlTable
 mkNode ss (Node s leaf []) =
@@ -163,13 +173,104 @@ splitModule (Module mod) = split mod
      			(s1, _) -> [s1]
 
 -- ---------------------------------------------------------------------------
+-- Generate the index
+
+ppHtmlIndex :: String -> [(Module,Interface)] -> IO ()
+ppHtmlIndex title ifaces = do
+  let html = 
+	header (thetitle (toHtml (title ++ " (Index)")) +++
+		thelink ! [href styleSheetFile, 
+		  rel "stylesheet", thetype "text/css"]) +++
+        body <<  
+	  table ! [width "100%", cellpadding 0, cellspacing 1] << (
+	    simpleHeader title </>
+	    tda [theclass "section1"] << toHtml "Type/Class Index" </>
+	    index_html tycls_index 't' </>
+	    tda [theclass "section1"] << toHtml "Function/Constructor Index" </>
+	    index_html var_index 'v'
+	   )
+
+  when split_indices
+    (do mapM_ (do_sub_index "Type/Class" tycls_index 't') ['A'..'Z'] 
+        mapM_ (do_sub_index "Function/Constructor" var_index 'v') ['A'..'Z'] 
+    )
+
+  writeFile indexHtmlFile (renderHtml html)
+
+ where
+  split_indices = length tycls_index > 50 || length var_index > 50
+
+  index_html this_ix kind
+    | split_indices = 
+	td << table ! [cellpadding 0, cellspacing 5] <<
+	    besides [ td << anchor ! [href (subIndexHtmlFile kind c)] <<
+			 toHtml [c]
+		    | c <- ['A'..'Z'] ]
+   | otherwise =
+	td << table ! [cellpadding 0, cellspacing 5] <<
+	  aboves (map indexElt this_ix) 
+ 	
+  do_sub_index descr this_ix kind c
+    = writeFile (subIndexHtmlFile kind c) (renderHtml html)
+    where 
+      html = header (thetitle (toHtml (title ++ " (" ++ descr ++ "Index)")) +++
+		thelink ! [href styleSheetFile, 
+		  rel "stylesheet", thetype "text/css"]) +++
+             body <<  
+	      table ! [width "100%", cellpadding 0, cellspacing 1] << (
+	        simpleHeader title </>
+	        tda [theclass "section1"] << 
+	      	toHtml (descr ++ " Index (" ++ c:")") </>
+	        td << table ! [cellpadding 0, cellspacing 5] <<
+	      	  aboves (map indexElt index_part) 
+	       )
+
+      index_part = [(n,stuff) | (n,stuff) <- this_ix, n `nameBeginsWith` c]
+
+  tycls_index = index isTyClsName
+  var_index   = index (not.isTyClsName)
+
+  isTyClsName (HsTyClsName _) = True
+  isTyClsName _ = False
+
+  index :: (HsName -> Bool) -> [(HsName, [(Module,Bool)])]
+  index f = sortBy cmp (fmToList (full_index f))
+    where cmp (n1,_) (n2,_) = n1 `compare` n2
+    
+  iface_indices f = map (getIfaceIndex f) ifaces
+  full_index f = foldr1 (plusFM_C (++)) (iface_indices f)
+
+  getIfaceIndex f (mod,iface) = listToFM
+    [ (name, [(mod, mod == mod')]) 
+    | (name, Qual mod' _) <- fmToList (iface_env iface),
+      f name ]
+
+  indexElt :: (HsName, [(Module,Bool)]) -> HtmlTable
+  indexElt (nm, entries) = 
+     td << ppHsName nm
+     <-> td << (hsep [ if defining then
+			 bold << anchor ! [href (linkId mod nm)] << toHtml mod
+		       else
+			 anchor ! [href (linkId mod nm)] << toHtml mod
+	             | (Module mod, defining) <- entries ])
+     where
+	defining_mods = [ m | (Module m, True) <- entries ]
+
+nameBeginsWith (HsTyClsName id) c = idBeginsWith id c
+nameBeginsWith (HsVarName   id) c = idBeginsWith id c
+
+idBeginsWith (HsIdent   s) c = head s `elem` [toLower c, toUpper c]
+idBeginsWith (HsSymbol  s) c = head s `elem` [toLower c, toUpper c]
+idBeginsWith (HsSpecial s) c = head s `elem` [toLower c, toUpper c]
+
+-- ---------------------------------------------------------------------------
 -- Generate the HTML page for a module
 
 ppHtmlModule :: String -> Maybe String -> (Module,Interface) -> IO ()
 ppHtmlModule title source_url (Module mod,iface) = do
   let html = 
 	header (thetitle (toHtml mod) +++
-		mylink ! [href styleSheetFile, 
+		thelink ! [href styleSheetFile, 
 		  rel "stylesheet", thetype "text/css"]) +++
         body <<  
 	  table ! [width "100%", cellpadding 0, cellspacing 1] << (
@@ -181,19 +282,19 @@ ppHtmlModule title source_url (Module mod,iface) = do
 
 ifaceToHtml :: String -> Interface -> HtmlTable
 ifaceToHtml mod iface
-  | null exports = td << noHtml
+  | null exports = Html.emptyTable
   | otherwise =
-    td << table ! [width "100%", cellpadding 0, cellspacing 15] << body1
+    td << table ! [width "100%", cellpadding 0, cellspacing 15] << 
+	(body1 </> body2)
  where exports = iface_exports iface
        doc_map = iface_name_docs iface
 
        body1
          | Just doc <- iface_doc iface
          = (tda [theclass "section1"] << toHtml "Description") </>
-	   docBox (markup htmlMarkup doc) </>
-	   body2
+	   docBox (markup htmlMarkup doc)
 	 | otherwise
-	 = body2
+	 = Html.emptyTable
 
        body2 =
          (tda [theclass "section1"] << toHtml "Synopsis") </>
@@ -205,7 +306,7 @@ ifaceToHtml mod iface
 
 processExport :: FiniteMap HsName Doc -> Bool -> ExportItem -> HtmlTable
 processExport doc_map summary (ExportGroup lev doc)
-  | summary   = td << noHtml
+  | summary   = Html.emptyTable
   | otherwise = ppDocGroup lev (markup htmlMarkup doc)
 processExport doc_map summary (ExportDecl decl)
   = doDecl doc_map summary decl
@@ -260,7 +361,7 @@ doDecl doc_map summary decl = do_decl decl
 	= ppHsClassDecl doc_map summary decl
 
      do_decl (HsDocGroup lev str) 
-	= if summary then td << noHtml else ppDocGroup lev str
+	= if summary then Html.emptyTable else ppDocGroup lev str
 
      do_decl _ = error (show decl)
 
@@ -556,8 +657,6 @@ ubxParenList = ubxparens . hsep . punctuate comma
 ubxparens p = toHtml "(#" +++ p +++ toHtml "#)"
 
 text   = strAttr "TEXT"
-div    = tag "DIV"
-mylink = itag "LINK"
 
 declBox :: Html -> HtmlTable
 declBox html = tda [theclass "decl"] << html
@@ -566,48 +665,3 @@ docBox :: Html -> HtmlTable
 docBox html = tda [theclass "doc"] << html
 
 vanillaTable = table ! [width "100%", cellpadding 0, cellspacing 0, border 0]
-
-renderHtml :: (HTML html) => html -> String
-renderHtml theHtml =
-      renderMessage ++ 
-         foldr (.) id (map (renderHtml' 0)
-                           (getHtmlElements (tag "HTML" << theHtml))) "\n"
-
-renderMessage =
-      "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">\n" ++
-      "<!--Rendered using the Haskell Html Library v0.2-->\n"
-
-renderHtml' :: Int -> HtmlElement -> ShowS
-renderHtml' _ (HtmlString str) = (++) str
-renderHtml' n (HtmlTag
-              { markupTag = name,
-                markupContent = html,
-                markupAttrs = markupAttrs })
-      = if isNoHtml html && elem name myValidHtmlITags
-        then renderTag True name markupAttrs n
-        else (renderTag True name markupAttrs n
-             . foldr (.) id (map (renderHtml' (n+2)) (getHtmlElements html))
-             . renderTag False name [] n)
-
-myValidHtmlITags = "LINK" : validHtmlITags
-
--- -----------------------------------------------------------------------------
--- a "better" implementation of the table combinators (less confusing, anyhow)
-
-td :: Html -> HtmlTable
-td = cell . Html.td
-
-tda :: [HtmlAttr] -> Html -> HtmlTable
-tda as = cell . (Html.td ! as)
-
-above  a b = combine BT.above a b
-beside a b = combine BT.beside a b
-
-infixr 3 </>  -- combining table cells 
-infixr 4 <->  -- combining table cells
-(</>) = above
-(<->) = beside
-
-aboves  = foldr1 above
-besides = foldr1 beside
-
diff --git a/src/Html.hs b/src/Html.hs
new file mode 100644
index 00000000..9f2f7439
--- /dev/null
+++ b/src/Html.hs
@@ -0,0 +1,1011 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Text.Html
+-- Copyright   :  (c) Andy Gill, and the Oregon Graduate Institute of 
+--		  Science and Technology, 1999-2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  Andy Gill <andy@galconn.com>
+-- Stability   :  experimental
+-- Portability :  portable
+--
+-- $Id: Html.hs,v 1.1 2002/04/08 16:41:38 simonmar Exp $
+--
+-- An Html combinator library
+--
+-----------------------------------------------------------------------------
+
+module Html (
+      module Html,
+      ) where
+
+import qualified BlockTable as BT
+
+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 &gt;,etc.
+
+data HtmlElement
+{-
+ -    ..just..plain..normal..text... but using &copy; and &amb;, etc.
+ -}
+      = HtmlString String
+{-
+ -    <thetag {..attrs..}> ..content.. </thetag>
+ -}
+      | HtmlTag {                   -- tag with internal markup
+              markupTag      :: String,
+              markupAttrs    :: [HtmlAttr],
+              markupContent  :: 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
+
+
+newtype Html = Html { getHtmlElements :: [HtmlElement] }
+
+-- 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 HTML a where
+      toHtml     :: a -> Html
+      toHtmlFromList :: [a] -> Html
+
+      toHtmlFromList xs = Html (concat [ x | (Html x) <- map toHtml xs])
+
+instance HTML Html where
+      toHtml a    = a
+
+instance HTML Char where
+      toHtml       a = toHtml [a]
+      toHtmlFromList []  = Html []
+      toHtmlFromList str = Html [HtmlString (stringToHtmlString str)]
+
+instance (HTML a) => HTML [a] where
+      toHtml xs = toHtmlFromList 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 htmls) ! attr = Html (map addAttrs htmls)
+        where
+              addAttrs (html@(HtmlTag { markupAttrs = markupAttrs }) )
+                              = html { markupAttrs = markupAttrs ++ attr }
+              addAttrs html = html
+
+
+(<<)            :: (HTML a) => (Html -> b) -> a        -> b
+fn << arg = fn (toHtml arg)
+
+
+concatHtml :: (HTML a) => [a] -> Html
+concatHtml as = Html (concat (map (getHtmlElements.toHtml) as))
+
+(+++) :: (HTML a,HTML b) => a -> b -> Html
+a +++ b = Html (getHtmlElements (toHtml a) ++ getHtmlElements (toHtml b))
+
+noHtml :: Html
+noHtml = Html []
+
+
+isNoHtml (Html xs) = null xs
+
+
+tag  :: String -> Html -> Html
+tag str       htmls = Html [
+      HtmlTag {
+              markupTag = str,
+              markupAttrs = [],
+              markupContent = htmls }]
+
+itag :: String -> Html
+itag str = tag str noHtml
+
+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 x    = Html [HtmlString x]
+
+-- ---------------------------------------------------------------------------
+-- 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
+thetd               :: Html -> Html
+textarea            :: Html -> Html
+th                  :: Html -> Html
+thebase             ::         Html
+thecode             :: Html -> Html
+thediv              :: Html -> Html
+thehtml             :: Html -> Html
+thelink             ::         Html
+themap              :: Html -> Html
+thespan             :: 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"
+thetd               =  tag "TD"
+textarea            =  tag "TEXTAREA"
+th                  =  tag "TH"
+thebase             = itag "BASE"
+thecode             =  tag "CODE"
+thediv              =  tag "DIV"
+thehtml             =  tag "HTML"
+thelink             = itag "LINK"
+themap              =  tag "MAP"
+thespan             =  tag "SPAN"
+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
+identifier          :: 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"
+identifier          =   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"
+
+-- ---------------------------------------------------------------------------
+-- Html Constructors
+
+-- (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",
+      "LINK",
+      "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 []     = noHtml
+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
+
+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
+-- \pre{
+-- 	   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))
+
+td :: Html -> HtmlTable
+td = cell . thetd
+
+tda :: [HtmlAttr] -> Html -> HtmlTable
+tda as = cell . (thetd ! as)
+
+above  a b = combine BT.above a b
+beside a b = combine BT.beside a b
+
+infixr 3 </>  -- combining table cells 
+infixr 4 <->  -- combining table cells
+(</>) = above
+(<->) = beside
+
+emptyTable = HtmlTable BT.empty
+
+aboves  = foldr above  emptyTable
+besides = foldr beside emptyTable
+
+mkHtmlTable :: BT.BlockTable (Int -> Int -> Html) -> HtmlTable
+mkHtmlTable r = HtmlTable r
+
+combine fn (HtmlTable a) (HtmlTable b) = mkHtmlTable (a `fn` b)
+
+-- renderTable takes the HtmlTable, and renders it back into
+-- and Html object.
+
+renderTable :: BT.BlockTable (Int -> Int -> Html) -> Html
+renderTable theTable
+      = concatHtml
+          [tr << [theCell x y | (theCell,(x,y)) <- theRow ]
+                      | theRow <- BT.getMatrix theTable]
+
+instance HTML HtmlTable where
+      toHtml (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 (cell . (thetd ! cellAttr) . toHtml))
+              ) 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
+                                         (thetd ! [width "100%"] 
+                                            << bold  
+                                               << leaf)
+      treeHtml' (c:cs@(c2:_)) (HtmlNode hopen ts hclose) =
+          if null ts && isNoHtml hclose
+          then
+              hd 
+          else if null ts
+          then
+              hd </> bar `beside` (cell . (thetd ! [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 = cell (thetd ! [bgcolor c,width "10"] << spaceHtml)
+              hd = cell (thetd ! [bgcolor c] << hopen)
+              tl = cell (thetd ! [bgcolor c] << hclose)
+      treeHtml' _ _ = error "The imposible happens"
+
+instance HTML HtmlTree where
+      toHtml 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 :: (HTML a) => a -> Html
+debugHtml obj = table ! [border 0] << (
+                  cell (th ! [bgcolor "#008888"] 
+                     	<< underline
+                       	   << "Debugging Output")
+               </>  td << (toHtml (debug' (toHtml obj)))
+              )
+  where
+
+      debug' :: Html -> [HtmlTree]
+      debug' (Html markups) = map debug markups
+
+      debug :: HtmlElement -> HtmlTree
+      debug (HtmlString str) = HtmlLeaf (spaceHtml +++
+                                              linesToHtml (lines str))
+      debug (HtmlTag {
+              markupTag = markupTag,
+              markupContent = markupContent,
+              markupAttrs  = markupAttrs
+              }) =
+              case markupContent of
+                Html [] -> HtmlNode hd [] noHtml
+                Html xs -> HtmlNode hd (map debug xs) tl
+        where
+              args = if null markupAttrs
+                     then ""
+                     else "  " ++ unwords (map show markupAttrs) 
+              hd = font ! [size "1"] << ("<" ++ markupTag ++ args ++ ">")
+              tl = font ! [size "1"] << ("</" ++ markupTag ++ ">")
+
+-- ---------------------------------------------------------------------------
+-- Hotlink datatype
+
+data HotLink = HotLink {
+      hotLinkURL        :: URL,
+      hotLinkContents   :: [Html],
+      hotLinkAttributes :: [HtmlAttr]
+      } deriving Show
+
+instance HTML HotLink where
+      toHtml 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   :: (HTML a) => [a] -> Html
+ordList items = olist << map (li <<) items
+
+unordList :: (HTML a) => [a] -> Html
+unordList items = ulist << map (li <<) items
+
+defList   :: (HTML a,HTML b) => [(a,b)] -> Html
+defList items
+ = dlist << [ [ dterm << bold << dt, ddef << dd ] | (dt,dd) <- items ]
+
+
+widget :: String -> String -> [HtmlAttr] -> Html
+widget w n markupAttrs = input ! ([thetype w,name n] ++ markupAttrs)
+
+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 :: (HTML html) => html -> String
+renderHtml theHtml =
+      renderMessage ++ 
+         foldr (.) id (map (renderHtml' 0)
+                           (getHtmlElements (tag "HTML" << theHtml))) "\n"
+
+renderMessage =
+      "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">\n" ++
+      "<!--Rendered using the Haskell Html Library v0.2-->\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 :: (HTML html) => html -> String
+prettyHtml theHtml = 
+        unlines
+      $ concat
+      $ map prettyHtml'
+      $ getHtmlElements
+      $ toHtml theHtml
+
+renderHtml' :: Int -> HtmlElement -> ShowS
+renderHtml' _ (HtmlString str) = (++) str
+renderHtml' n (HtmlTag
+              { markupTag = name,
+                markupContent = html,
+                markupAttrs = markupAttrs })
+      = if isNoHtml html && elem name validHtmlITags
+        then renderTag True name markupAttrs n
+        else (renderTag True name markupAttrs n
+             . foldr (.) id (map (renderHtml' (n+2)) (getHtmlElements html))
+             . renderTag False name [] n)
+
+prettyHtml' :: HtmlElement -> [String]
+prettyHtml' (HtmlString str) = [str]
+prettyHtml' (HtmlTag
+              { markupTag = name,
+                markupContent = html,
+                markupAttrs = markupAttrs })
+      = if isNoHtml html && elem name validHtmlITags
+        then 
+         [rmNL (renderTag True name markupAttrs 0 "")]
+        else
+         [rmNL (renderTag True name markupAttrs 0 "")] ++ 
+          shift (concat (map prettyHtml' (getHtmlElements html))) ++
+         [rmNL (renderTag False name [] 0 "")]
+  where
+      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 markupAttrs n r
+      = open ++ name ++ rest markupAttrs ++ ">" ++ 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  ++ "\""
+