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