diff options
Diffstat (limited to 'src/Html.hs')
| -rw-r--r-- | src/Html.hs | 1037 |
1 files changed, 0 insertions, 1037 deletions
diff --git a/src/Html.hs b/src/Html.hs deleted file mode 100644 index 530df829..00000000 --- a/src/Html.hs +++ /dev/null @@ -1,1037 +0,0 @@ ------------------------------------------------------------------------------ --- --- 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 Html ( - module Html, - ) where - -import qualified 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 ++ "\"" - |