1 -------------------------------------------------------------------------------
2 -- $Id: DataHtml.hs,v 1.2 2000/07/10 16:15:34 rrt Exp $
4 -- Copyright (c) 1999 Andy Gill
5 -------------------------------------------------------------------------------
8 Html, HtmlName, HtmlAttr, HtmlTable,
9 (+++), verbatim, {- tag, atag, -} noHtml, primHtml,
10 concatHtml, htmlStr, htmlLine,
12 font, bold, anchor, header, body, theTitle, paragraph, italics,
15 {- tr, int, percent -}
16 color, bgcolor, href, name, title, height, width, align, valign,
17 border, size, cellpadding, cellspacing,
18 p, hr, copyright, spaceHtml,
20 cellHtml, (+/+), above, (+-+), beside, aboves, besides,
21 renderTable, simpleTable,
24 import qualified OptTable as OT
26 infixr 5 +++ -- appending Html
27 infixr 3 +/+ -- combining HtmlTable
28 infixr 4 +-+ -- combining HtmlTable
31 = HtmlAppend Html Html -- Some Html, followed by more text
32 | HtmlVerbatim Html -- Turn on or off smart formating
33 | HtmlEmpty -- Nothing!
34 | HtmlNestingTag HtmlName [HtmlAttr] Html
35 | HtmlSimpleTag HtmlName [HtmlAttr]
40 - A important property of Html is all strings inside the
41 - structure are already in Html friendly format.
42 - For example, use of >,etc.
45 type HtmlName = String
46 type HtmlAttr = (HtmlName,Either Int String)
47 type HtmlTable = OT.OptTable (Int -> Int -> Html)
49 ------------------------------------------------------------------------------
51 ------------------------------------------------------------------------------
53 -- primitive combinators
54 (+++) :: Html -> Html -> Html
55 verbatim :: Html -> Html
56 tag :: String -> [HtmlAttr] -> Html -> Html
57 atag :: String -> [HtmlAttr] -> Html
59 primHtml :: String -> Html
62 concatHtml :: [Html] -> Html
63 htmlStr, htmlLine :: String -> Html
66 h1,h2,h3,h4,h5,h6 :: [HtmlAttr] -> Html -> Html
70 italics, ul, tt :: [HtmlAttr] -> Html -> Html
71 bar, meta, li :: [HtmlAttr] -> Html
74 str :: String -> String -> HtmlAttr
75 int :: String -> Int -> HtmlAttr
76 percent :: String -> Int -> HtmlAttr
80 width, align, valign :: String -> HtmlAttr
84 cellspacing :: Int -> HtmlAttr
94 renderHtml :: Html -> String
97 cellHtml :: [HtmlAttr] -> Html -> HtmlTable
99 (+-+),beside :: HtmlTable -> HtmlTable -> HtmlTable
100 aboves, besides :: [HtmlTable] -> HtmlTable
101 renderTable :: [HtmlAttr] -> HtmlTable -> Html
102 simpleTable :: [HtmlAttr] -> [HtmlAttr] -> [[Html]]
105 ------------------------------------------------------------------------------
106 -- Basic, primitive combinators
108 -- This is intentionally lazy in the second argument.
109 (HtmlAppend x y) +++ z = x +++ (y +++ z)
110 (HtmlEmpty) +++ z = z
111 x +++ z = HtmlAppend x z
113 verbatim = HtmlVerbatim
118 -- This is not processed for special chars.
119 -- It is used to output them, though!
120 primHtml = HtmlString
122 ------------------------------------------------------------------------------
123 -- Useful Combinators
125 concatHtml = foldr (+++) noHtml
126 -- Processing Strings into Html friendly things.
127 -- This converts a string to an Html.
128 htmlStr = primHtml . htmlizeStr
130 -- This converts a string, but keeps spaces as non-line-breakable
131 htmlLine = primHtml . concat . map htmlizeChar2
133 htmlizeChar2 ' ' = " "
134 htmlizeChar2 c = htmlizeChar c
137 htmlizeStr :: String -> String
138 htmlizeStr = concat . map htmlizeChar
140 htmlizeChar :: Char -> String
141 htmlizeChar '<' = ">"
142 htmlizeChar '>' = "<"
143 htmlizeChar '&' = "&amb;"
144 htmlizeChar '"' = """
147 ------------------------------------------------------------------------------
149 h n = tag ("h" ++ show n)
151 -- Isn't Haskell great!
152 [h1,h2,h3,h4,h5,h6] = map h [1..6]
158 header = tag "header"
160 theTitle = tag "title"
170 ------------------------------------------------------------------------------
173 -- note: the string is presumed to be formated for output
174 --str :: String -> String -> HtmlAttr
175 str n s = (n,Right s)
177 --int :: String -> Int -> HtmlAttr
180 --percent :: String -> Int -> HtmlAttr
181 percent n v = str n (show v ++ "%")
185 bgcolor = str "bgcolor"
189 height = str "height"
192 valign = str "valign"
194 border = int "border"
196 cellpadding = int "cellpadding"
197 cellspacing = int "cellspacing"
199 ------------------------------------------------------------------------------
203 copyright = primHtml "©"
204 spaceHtml = primHtml " "
206 ------------------------------------------------------------------------------
209 renderHtml html = renderHtml' html (Just 0) ++ footerMessage
212 = "\n<!-- Generated using the Haskell HTML generator package HaskHTML -->\n"
214 renderHtml' (HtmlAppend html1 html2) d
215 = renderHtml' html1 d ++ renderHtml' html2 d
216 renderHtml' (HtmlVerbatim html1) d
217 = renderHtml' html1 Nothing
218 renderHtml' (HtmlEmpty) d = ""
219 renderHtml' (HtmlSimpleTag name attr) d
220 = renderTag True name attr d
221 renderHtml' (HtmlNestingTag name attr html) d
222 = renderTag True name attr d ++ renderHtml' html (incDepth d) ++
223 renderTag False name [] d
224 renderHtml' (HtmlString str) _ = str
226 incDepth :: Maybe Int -> Maybe Int
229 -- This prints the tags in
230 renderTag :: Bool -> HtmlName -> [HtmlAttr] -> Maybe Int -> String
231 renderTag x name attrs n = start ++ base_spaces ++ open ++ name ++ rest attrs ++ ">"
233 open = if x then "<" else "</"
234 (start,base_spaces,sep) = case n of
235 Nothing -> ("",""," ")
236 Just n -> ("\n",replicate n ' ',"\n")
239 rest [(tag,val)] = " " ++ tag ++ "=" ++ myShow val
240 rest (hd:tl) = " " ++ showPair hd ++ sep ++
241 foldr1 (\ x y -> x ++ sep ++ y)
242 [ base_spaces ++ replicate (1 + length name + 1) ' '
243 ++ showPair p | p <- tl ]
245 showPair :: HtmlAttr -> String
246 showPair (tag,val) = tag ++ replicate (tagsz - length tag) ' ' ++
248 myShow (Left n) = show n
249 myShow (Right s) = "\"" ++ s ++ "\""
251 tagsz = maximum (map (length.fst) attrs)
253 ------------------------------------------------------------------------------
254 -- Html table related things
256 cellHtml attr html = OT.single cellFn
258 cellFn x y = tag "td" (addX x (addY y attr)) html
260 addX n rest = int "colspan" n : rest
262 addY n rest = int "rowspan" n : rest
270 - Note: Both aboves and besides presume a non-empty list.
273 aboves = foldl1 (+/+)
274 besides = foldl1 (+-+)
276 -- renderTable takes the HtmlTable, and renders it back into
277 -- and Html object. The attributes are added to the outside
280 renderTable attr theTable
281 = table [row [theCell x y | (theCell,(x,y)) <- theRow ]
282 | theRow <- OT.getMatrix theTable]
284 row :: [Html] -> Html
285 row = tag "tr" [] . concatHtml
287 table :: [Html] -> Html
288 table = tag "table" attr . concatHtml
290 -- If you cant be bothered with the above, then you
291 -- can build simple tables with this.
292 -- Just provide the attributes for the whole table,
293 -- attributes for the cells (same for every cell),
294 -- and a list of list of cell contents,
295 -- and this function will build the table for you.
296 -- It does presume that all the lists are non-empty,
297 -- and there is at least one list.
299 -- Different length lists means that the last cell
300 -- gets padded. If you want more power, then
301 -- use the system above.
303 simpleTable attr cellAttr
306 . map (besides . map (cellHtml cellAttr))
309 ------------------------------------------------------------------------------