diff options
Diffstat (limited to 'src/Haddock/Utils')
| -rw-r--r-- | src/Haddock/Utils/BlockTable.hs | 180 | ||||
| -rw-r--r-- | src/Haddock/Utils/FastMutInt2.hs | 63 | ||||
| -rw-r--r-- | src/Haddock/Utils/GHC.hs | 26 | ||||
| -rw-r--r-- | src/Haddock/Utils/Html.hs | 1037 |
4 files changed, 1306 insertions, 0 deletions
diff --git a/src/Haddock/Utils/BlockTable.hs b/src/Haddock/Utils/BlockTable.hs new file mode 100644 index 00000000..ed51654e --- /dev/null +++ b/src/Haddock/Utils/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.2 2002/07/24 09:42:18 simonmar Exp $ +-- +-- An Html combinator library +-- +----------------------------------------------------------------------------- + +module Haddock.Utils.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 _ = 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 (\ _ _ 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/Haddock/Utils/FastMutInt2.hs b/src/Haddock/Utils/FastMutInt2.hs new file mode 100644 index 00000000..c47b514b --- /dev/null +++ b/src/Haddock/Utils/FastMutInt2.hs @@ -0,0 +1,63 @@ +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +-- +-- (c) The University of Glasgow 2002 +-- +-- Unboxed mutable Ints + +module Haddock.Utils.FastMutInt2( + FastMutInt, newFastMutInt, + readFastMutInt, writeFastMutInt, + incFastMutInt, incFastMutIntBy + ) where + +#include "MachDeps.h" + +#ifndef SIZEOF_HSINT +#define SIZEOF_HSINT INT_SIZE_IN_BYTES +#endif + + +#if __GLASGOW_HASKELL__ < 503 +import GlaExts +import PrelIOBase +#else +import GHC.Base +import GHC.IOBase +#endif + +#if __GLASGOW_HASKELL__ < 411 +newByteArray# = newCharArray# +#endif + +#ifdef __GLASGOW_HASKELL__ +data FastMutInt = FastMutInt (MutableByteArray# RealWorld) + +newFastMutInt :: IO FastMutInt +newFastMutInt = IO $ \s0 -> + case newByteArray# size s0 of { (# s, arr #) -> + (# s, FastMutInt arr #) } + where I# size = SIZEOF_HSINT + +readFastMutInt :: FastMutInt -> IO Int +readFastMutInt (FastMutInt arr) = IO $ \s0 -> + case readIntArray# arr 0# s0 of { (# s, i #) -> + (# s, I# i #) } + +writeFastMutInt :: FastMutInt -> Int -> IO () +writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s0 -> + case writeIntArray# arr 0# i s0 of { s -> + (# s, () #) } + +incFastMutInt :: FastMutInt -> IO Int -- Returns original value +incFastMutInt (FastMutInt arr) = IO $ \s0 -> + case readIntArray# arr 0# s0 of { (# s1, i #) -> + case writeIntArray# arr 0# (i +# 1#) s1 of { s -> + (# s, I# i #) } } + +incFastMutIntBy :: FastMutInt -> Int -> IO Int -- Returns original value +incFastMutIntBy (FastMutInt arr) (I# n) = IO $ \s0 -> + case readIntArray# arr 0# s0 of { (# s1, i #) -> + case writeIntArray# arr 0# (i +# n) s1 of { s -> + (# s, I# i #) } } +#endif + diff --git a/src/Haddock/Utils/GHC.hs b/src/Haddock/Utils/GHC.hs new file mode 100644 index 00000000..b6fb54d4 --- /dev/null +++ b/src/Haddock/Utils/GHC.hs @@ -0,0 +1,26 @@ +module Haddock.Utils.GHC where + +import Debug.Trace + +import GHC +import HsSyn +import SrcLoc +import HscTypes +import Outputable + +getMainDeclBinder :: HsDecl name -> Maybe name +getMainDeclBinder (TyClD d) = Just (tcdName d) +getMainDeclBinder (ValD d) + = case collectAcc d [] of + [] -> Nothing + (name:_) -> Just (unLoc name) +getMainDeclBinder (SigD d) = sigNameNoLoc d +getMainDeclBinder (ForD (ForeignImport name _ _)) = Just (unLoc name) +getMainDeclBinder (ForD (ForeignExport name _ _)) = Nothing +getMainDeclBinder _ = Nothing + +-- To keep if if minf_iface is re-introduced +--modInfoName = moduleName . mi_module . minf_iface +--modInfoMod = mi_module . minf_iface + +trace_ppr x y = trace (showSDoc (ppr x)) y diff --git a/src/Haddock/Utils/Html.hs b/src/Haddock/Utils/Html.hs new file mode 100644 index 00000000..dbef2112 --- /dev/null +++ b/src/Haddock/Utils/Html.hs @@ -0,0 +1,1037 @@ +----------------------------------------------------------------------------- +-- +-- 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 +-- +-- An Html combinator library +-- +----------------------------------------------------------------------------- + +module Haddock.Utils.Html ( + module Haddock.Utils.Html, + ) where + +import qualified Haddock.Utils.BlockTable as BT + +import Data.Char (isAscii, ord) +import Numeric (showHex) + +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 = + case html of + HtmlTag { markupAttrs = markupAttrs0 + , markupTag = markupTag0 + , markupContent = markupContent0 } -> + HtmlTag { markupAttrs = markupAttrs0 ++ attr + , markupTag = markupTag0 + , markupContent = markupContent0 } + _ -> 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 -> Bool +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 + | isAscii c = [c] + | otherwise = "&#x" ++ showHex (ord 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 +button :: Html -> 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 +script :: 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" +button = tag "BUTTON" +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" +script = tag "SCRIPT" +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 +onclick :: String -> 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 "HTTP-EQUIV" +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" +onclick = strAttr "ONCLICK" +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", + "HTTP-EQUIV", + "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 :: Html -> HtmlTable +cell h = let + cellFn x y = h ! (add x colspan $ add y rowspan $ []) + add 1 _ 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, beside :: HtmlTable -> HtmlTable -> HtmlTable +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 +(</>), (<->) :: HtmlTable -> HtmlTable -> HtmlTable +(</>) = above +(<->) = beside + +emptyTable :: HtmlTable +emptyTable = HtmlTable BT.empty + +aboves, besides :: [HtmlTable] -> HtmlTable +aboves = foldr above emptyTable +besides = foldr beside emptyTable + +mkHtmlTable :: BT.BlockTable (Int -> Int -> Html) -> HtmlTable +mkHtmlTable r = HtmlTable r + +combine :: (BT.BlockTable (Int -> Int -> Html) + -> BT.BlockTable (Int -> Int -> Html) + -> BT.BlockTable (Int -> Int -> Html)) + -> HtmlTable -> HtmlTable -> HtmlTable +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 :: HTML a => [HtmlAttr] -> [HtmlAttr] -> [[a]] -> Html +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' (_:_) (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 :: [String] +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 = markupTag0, + markupContent = markupContent0, + markupAttrs = markupAttrs0 + }) = + case markupContent0 of + Html [] -> HtmlNode hd [] noHtml + Html xs -> HtmlNode hd (map debug xs) tl + where + args = if null markupAttrs0 + then "" + else " " ++ unwords (map show markupAttrs0) + hd = font ! [size "1"] << ("<" ++ markupTag0 ++ args ++ ">") + tl = font ! [size "1"] << ("</" ++ markupTag0 ++ ">") + +-- --------------------------------------------------------------------------- +-- 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 markupAttrs0 = input ! ([thetype w,name n] ++ markupAttrs0) + +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 unprettyHtml + (getHtmlElements (tag "HTML" << theHtml))) "\n" + +renderMessage :: String +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" + +unprettyHtml :: HtmlElement -> ShowS +unprettyHtml (HtmlString str) = (++) str +unprettyHtml (HtmlTag + { markupTag = name0, + markupContent = html, + markupAttrs = markupAttrs0 }) + = if isNoHtml html && elem name0 validHtmlITags + then renderTag True name0 markupAttrs0 0 + else (renderTag True name0 markupAttrs0 0 + . foldr (.) id (map unprettyHtml (getHtmlElements html)) + . renderTag False name0 [] 0) + +-- Local Utilities +prettyHtml :: (HTML html) => html -> String +prettyHtml theHtml = + unlines + $ concat + $ map prettyHtml' + $ getHtmlElements + $ toHtml theHtml + +prettyHtml' :: HtmlElement -> [String] +prettyHtml' (HtmlString str) = [str] +prettyHtml' (HtmlTag + { markupTag = name0, + markupContent = html, + markupAttrs = markupAttrs0 }) + = if isNoHtml html && elem name0 validHtmlITags + then + [rmNL (renderTag True name0 markupAttrs0 0 "")] + else + [rmNL (renderTag True name0 markupAttrs0 0 "")] ++ + shift (concat (map prettyHtml' (getHtmlElements html))) ++ + [rmNL (renderTag False name0 [] 0 "")] + where + shift = map (\x -> " " ++ x) + +rmNL :: [Char] -> [Char] +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 name0 markupAttrs0 n r + = open ++ name0 ++ rest markupAttrs0 ++ ">" ++ 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 tag0 val) + = tag0 ++ "=\"" ++ val ++ "\"" + |