-----------------------------------------------------------------------------
-- |
-- 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 : provisional
-- Portability : portable
--
-- An Html combinator library
--
-----------------------------------------------------------------------------
module Text.Html (
module Text.Html,
) where
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 ++ "\""
|
