diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/BlockTable.hs | 180 | ||||
| -rw-r--r-- | src/HaddockHtml.hs | 234 | ||||
| -rw-r--r-- | src/Html.hs | 1011 |
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 >,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 ++ "\"" + |