+++ /dev/null
-{-# OPTIONS_GHC -fno-bang-patterns #-}
-
------------------------------------------------------------------------------
--- |
--- Module : Text.Html
--- Copyright : (c) Andy Gill and OGI, 1999-2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : Andy Gill <andy@galconn.com>
--- Stability : experimental
--- Portability : portable
---
--- An Html combinator library
---
------------------------------------------------------------------------------
-
-module Text.Html (
- module Text.Html,
- ) where
-
-import Prelude
-
-import qualified Text.Html.BlockTable as BT
-
-infixr 3 </> -- combining table cells
-infixr 4 <-> -- combining table cells
-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
-td :: Html -> Html
-textarea :: Html -> Html
-th :: Html -> Html
-thebase :: Html
-thecode :: Html -> Html
-thediv :: Html -> Html
-thehtml :: Html -> Html
-thelink :: Html -> 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"
-td = tag "TD"
-textarea = tag "TEXTAREA"
-th = tag "TH"
-thebase = itag "BASE"
-thecode = tag "CODE"
-thediv = tag "DIV"
-thehtml = tag "HTML"
-thelink = tag "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 "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"
-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",
- "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
-
-class HTMLTABLE ht where
- cell :: ht -> HtmlTable
-
-instance HTMLTABLE HtmlTable where
- cell = id
-
-instance HTMLTABLE Html where
- 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))
-
-
-(</>),above,(<->),beside :: (HTMLTABLE ht1,HTMLTABLE ht2)
- => ht1 -> ht2 -> HtmlTable
-aboves,besides :: (HTMLTABLE ht) => [ht] -> HtmlTable
-simpleTable :: [HtmlAttr] -> [HtmlAttr] -> [[Html]] -> Html
-
-
-mkHtmlTable :: BT.BlockTable (Int -> Int -> Html) -> HtmlTable
-mkHtmlTable r = HtmlTable r
-
--- We give both infix and nonfix, take your pick.
--- Notice that there is no concept of a row/column
--- of zero items.
-
-above a b = combine BT.above (cell a) (cell b)
-(</>) = above
-beside a b = combine BT.beside (cell a) (cell b)
-(<->) = beside
-
-
-combine fn (HtmlTable a) (HtmlTable b) = mkHtmlTable (a `fn` b)
-
--- Both aboves and besides presume a non-empty list.
--- here is no concept of a empty row or column in these
--- table combinators.
-
-aboves [] = error "aboves []"
-aboves xs = foldr1 (</>) (map cell xs)
-besides [] = error "besides []"
-besides xs = foldr1 (<->) (map cell xs)
-
--- 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 ((td ! 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
- (td ! [width "100%"]
- << bold
- << leaf)
- treeHtml' (c:cs@(c2:_)) (HtmlNode hopen ts hclose) =
- if null ts && isNoHtml hclose
- then
- cell hd
- else if null ts
- then
- hd </> bar `beside` (td ! [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 = td ! [bgcolor c,width "10"] << spaceHtml
- hd = td ! [bgcolor c] << hopen
- tl = td ! [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] <<
- ( 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 3.2 FINAL//EN\">\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 ++ "\""
-
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Text.Html.BlockTable
--- Copyright : (c) Andy Gill and OGI, 1999-2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : Andy Gill <andy@galconn.com>
--- Stability : experimental
--- Portability : portable
---
--- An Html combinator library
---
------------------------------------------------------------------------------
-
-module Text.Html.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 ""
projects / ghc-base.git / commitdiff