From e4627dc83e619f89a99e662733e47f78efa60622 Mon Sep 17 00:00:00 2001
From: simonmar <unknown>
Date: Mon, 8 Apr 2002 16:41:38 +0000
Subject: [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
---
src/BlockTable.hs | 180 ++++++++++
src/HaddockHtml.hs | 234 +++++++-----
src/Html.hs | 1011 ++++++++++++++++++++++++++++++++++++++++++++++++++++
3 files changed, 1335 insertions(+), 90 deletions(-)
create mode 100644 src/BlockTable.hs
create mode 100644 src/Html.hs
(limited to 'src')
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 []) =
@@ -162,6 +172,97 @@ splitModule (Module mod) = split mod
(s1, '.':s2) -> s1 : split s2
(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
@@ -169,7 +270,7 @@ 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 >,etc.
+
+data HtmlElement
+{-
+ - ..just..plain..normal..text... but using © 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 '<' = "<"
+ fixChar '>' = ">"
+ fixChar '&' = "&"
+ fixChar '"' = """
+ 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 ' ' = " "
+ 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 ++ "\""
+
--
cgit v1.2.3