bump version to 2.0
[ghc.git] / libraries / base / Text / Html.hs
1 {-# OPTIONS_GHC -fno-bang-patterns #-}
2
3 -----------------------------------------------------------------------------
4 -- |
5 -- Module : Text.Html
6 -- Copyright : (c) Andy Gill and OGI, 1999-2001
7 -- License : BSD-style (see the file libraries/base/LICENSE)
8 --
9 -- Maintainer : Andy Gill <andy@galconn.com>
10 -- Stability : experimental
11 -- Portability : portable
12 --
13 -- An Html combinator library
14 --
15 -----------------------------------------------------------------------------
16
17 module Text.Html (
18 module Text.Html,
19 ) where
20
21 import Prelude
22
23 import qualified Text.Html.BlockTable as BT
24
25 infixr 3 </> -- combining table cells
26 infixr 4 <-> -- combining table cells
27 infixr 2 +++ -- combining Html
28 infixr 7 << -- nesting Html
29 infixl 8 ! -- adding optional arguments
30
31
32 -- A important property of Html is that all strings inside the
33 -- structure are already in Html friendly format.
34 -- For example, use of &gt;,etc.
35
36 data HtmlElement
37 {-
38 - ..just..plain..normal..text... but using &copy; and &amb;, etc.
39 -}
40 = HtmlString String
41 {-
42 - <thetag {..attrs..}> ..content.. </thetag>
43 -}
44 | HtmlTag { -- tag with internal markup
45 markupTag :: String,
46 markupAttrs :: [HtmlAttr],
47 markupContent :: Html
48 }
49
50 {- These are the index-value pairs.
51 - The empty string is a synonym for tags with no arguments.
52 - (not strictly HTML, but anyway).
53 -}
54
55
56 data HtmlAttr = HtmlAttr String String
57
58
59 newtype Html = Html { getHtmlElements :: [HtmlElement] }
60
61 -- Read MARKUP as the class of things that can be validly rendered
62 -- inside MARKUP tag brackets. So this can be one or more Html's,
63 -- or a String, for example.
64
65 class HTML a where
66 toHtml :: a -> Html
67 toHtmlFromList :: [a] -> Html
68
69 toHtmlFromList xs = Html (concat [ x | (Html x) <- map toHtml xs])
70
71 instance HTML Html where
72 toHtml a = a
73
74 instance HTML Char where
75 toHtml a = toHtml [a]
76 toHtmlFromList [] = Html []
77 toHtmlFromList str = Html [HtmlString (stringToHtmlString str)]
78
79 instance (HTML a) => HTML [a] where
80 toHtml xs = toHtmlFromList xs
81
82 class ADDATTRS a where
83 (!) :: a -> [HtmlAttr] -> a
84
85 instance (ADDATTRS b) => ADDATTRS (a -> b) where
86 fn ! attr = \ arg -> fn arg ! attr
87
88 instance ADDATTRS Html where
89 (Html htmls) ! attr = Html (map addAttrs htmls)
90 where
91 addAttrs (html@(HtmlTag { markupAttrs = markupAttrs }) )
92 = html { markupAttrs = markupAttrs ++ attr }
93 addAttrs html = html
94
95
96 (<<) :: (HTML a) => (Html -> b) -> a -> b
97 fn << arg = fn (toHtml arg)
98
99
100 concatHtml :: (HTML a) => [a] -> Html
101 concatHtml as = Html (concat (map (getHtmlElements.toHtml) as))
102
103 (+++) :: (HTML a,HTML b) => a -> b -> Html
104 a +++ b = Html (getHtmlElements (toHtml a) ++ getHtmlElements (toHtml b))
105
106 noHtml :: Html
107 noHtml = Html []
108
109
110 isNoHtml (Html xs) = null xs
111
112
113 tag :: String -> Html -> Html
114 tag str htmls = Html [
115 HtmlTag {
116 markupTag = str,
117 markupAttrs = [],
118 markupContent = htmls }]
119
120 itag :: String -> Html
121 itag str = tag str noHtml
122
123 emptyAttr :: String -> HtmlAttr
124 emptyAttr s = HtmlAttr s ""
125
126 intAttr :: String -> Int -> HtmlAttr
127 intAttr s i = HtmlAttr s (show i)
128
129 strAttr :: String -> String -> HtmlAttr
130 strAttr s t = HtmlAttr s t
131
132
133 {-
134 foldHtml :: (String -> [HtmlAttr] -> [a] -> a)
135 -> (String -> a)
136 -> Html
137 -> a
138 foldHtml f g (HtmlTag str attr fmls)
139 = f str attr (map (foldHtml f g) fmls)
140 foldHtml f g (HtmlString str)
141 = g str
142
143 -}
144 -- Processing Strings into Html friendly things.
145 -- This converts a String to a Html String.
146 stringToHtmlString :: String -> String
147 stringToHtmlString = concatMap fixChar
148 where
149 fixChar '<' = "&lt;"
150 fixChar '>' = "&gt;"
151 fixChar '&' = "&amp;"
152 fixChar '"' = "&quot;"
153 fixChar c = [c]
154
155 -- ---------------------------------------------------------------------------
156 -- Classes
157
158 instance Show Html where
159 showsPrec _ html = showString (prettyHtml html)
160 showList htmls = showString (concat (map show htmls))
161
162 instance Show HtmlAttr where
163 showsPrec _ (HtmlAttr str val) =
164 showString str .
165 showString "=" .
166 shows val
167
168
169 -- ---------------------------------------------------------------------------
170 -- Data types
171
172 type URL = String
173
174 -- ---------------------------------------------------------------------------
175 -- Basic primitives
176
177 -- This is not processed for special chars.
178 -- use stringToHtml or lineToHtml instead, for user strings,
179 -- because they understand special chars, like '<'.
180
181 primHtml :: String -> Html
182 primHtml x = Html [HtmlString x]
183
184 -- ---------------------------------------------------------------------------
185 -- Basic Combinators
186
187 stringToHtml :: String -> Html
188 stringToHtml = primHtml . stringToHtmlString
189
190 -- This converts a string, but keeps spaces as non-line-breakable
191
192 lineToHtml :: String -> Html
193 lineToHtml = primHtml . concatMap htmlizeChar2 . stringToHtmlString
194 where
195 htmlizeChar2 ' ' = "&nbsp;"
196 htmlizeChar2 c = [c]
197
198 -- ---------------------------------------------------------------------------
199 -- Html Constructors
200
201 -- (automatically generated)
202
203 address :: Html -> Html
204 anchor :: Html -> Html
205 applet :: Html -> Html
206 area :: Html
207 basefont :: Html
208 big :: Html -> Html
209 blockquote :: Html -> Html
210 body :: Html -> Html
211 bold :: Html -> Html
212 br :: Html
213 caption :: Html -> Html
214 center :: Html -> Html
215 cite :: Html -> Html
216 ddef :: Html -> Html
217 define :: Html -> Html
218 dlist :: Html -> Html
219 dterm :: Html -> Html
220 emphasize :: Html -> Html
221 fieldset :: Html -> Html
222 font :: Html -> Html
223 form :: Html -> Html
224 frame :: Html -> Html
225 frameset :: Html -> Html
226 h1 :: Html -> Html
227 h2 :: Html -> Html
228 h3 :: Html -> Html
229 h4 :: Html -> Html
230 h5 :: Html -> Html
231 h6 :: Html -> Html
232 header :: Html -> Html
233 hr :: Html
234 image :: Html
235 input :: Html
236 italics :: Html -> Html
237 keyboard :: Html -> Html
238 legend :: Html -> Html
239 li :: Html -> Html
240 meta :: Html
241 noframes :: Html -> Html
242 olist :: Html -> Html
243 option :: Html -> Html
244 paragraph :: Html -> Html
245 param :: Html
246 pre :: Html -> Html
247 sample :: Html -> Html
248 select :: Html -> Html
249 small :: Html -> Html
250 strong :: Html -> Html
251 style :: Html -> Html
252 sub :: Html -> Html
253 sup :: Html -> Html
254 table :: Html -> Html
255 td :: Html -> Html
256 textarea :: Html -> Html
257 th :: Html -> Html
258 thebase :: Html
259 thecode :: Html -> Html
260 thediv :: Html -> Html
261 thehtml :: Html -> Html
262 thelink :: Html -> Html
263 themap :: Html -> Html
264 thespan :: Html -> Html
265 thetitle :: Html -> Html
266 tr :: Html -> Html
267 tt :: Html -> Html
268 ulist :: Html -> Html
269 underline :: Html -> Html
270 variable :: Html -> Html
271
272 address = tag "ADDRESS"
273 anchor = tag "A"
274 applet = tag "APPLET"
275 area = itag "AREA"
276 basefont = itag "BASEFONT"
277 big = tag "BIG"
278 blockquote = tag "BLOCKQUOTE"
279 body = tag "BODY"
280 bold = tag "B"
281 br = itag "BR"
282 caption = tag "CAPTION"
283 center = tag "CENTER"
284 cite = tag "CITE"
285 ddef = tag "DD"
286 define = tag "DFN"
287 dlist = tag "DL"
288 dterm = tag "DT"
289 emphasize = tag "EM"
290 fieldset = tag "FIELDSET"
291 font = tag "FONT"
292 form = tag "FORM"
293 frame = tag "FRAME"
294 frameset = tag "FRAMESET"
295 h1 = tag "H1"
296 h2 = tag "H2"
297 h3 = tag "H3"
298 h4 = tag "H4"
299 h5 = tag "H5"
300 h6 = tag "H6"
301 header = tag "HEAD"
302 hr = itag "HR"
303 image = itag "IMG"
304 input = itag "INPUT"
305 italics = tag "I"
306 keyboard = tag "KBD"
307 legend = tag "LEGEND"
308 li = tag "LI"
309 meta = itag "META"
310 noframes = tag "NOFRAMES"
311 olist = tag "OL"
312 option = tag "OPTION"
313 paragraph = tag "P"
314 param = itag "PARAM"
315 pre = tag "PRE"
316 sample = tag "SAMP"
317 select = tag "SELECT"
318 small = tag "SMALL"
319 strong = tag "STRONG"
320 style = tag "STYLE"
321 sub = tag "SUB"
322 sup = tag "SUP"
323 table = tag "TABLE"
324 td = tag "TD"
325 textarea = tag "TEXTAREA"
326 th = tag "TH"
327 thebase = itag "BASE"
328 thecode = tag "CODE"
329 thediv = tag "DIV"
330 thehtml = tag "HTML"
331 thelink = tag "LINK"
332 themap = tag "MAP"
333 thespan = tag "SPAN"
334 thetitle = tag "TITLE"
335 tr = tag "TR"
336 tt = tag "TT"
337 ulist = tag "UL"
338 underline = tag "U"
339 variable = tag "VAR"
340
341 -- ---------------------------------------------------------------------------
342 -- Html Attributes
343
344 -- (automatically generated)
345
346 action :: String -> HtmlAttr
347 align :: String -> HtmlAttr
348 alink :: String -> HtmlAttr
349 alt :: String -> HtmlAttr
350 altcode :: String -> HtmlAttr
351 archive :: String -> HtmlAttr
352 background :: String -> HtmlAttr
353 base :: String -> HtmlAttr
354 bgcolor :: String -> HtmlAttr
355 border :: Int -> HtmlAttr
356 bordercolor :: String -> HtmlAttr
357 cellpadding :: Int -> HtmlAttr
358 cellspacing :: Int -> HtmlAttr
359 checked :: HtmlAttr
360 clear :: String -> HtmlAttr
361 code :: String -> HtmlAttr
362 codebase :: String -> HtmlAttr
363 color :: String -> HtmlAttr
364 cols :: String -> HtmlAttr
365 colspan :: Int -> HtmlAttr
366 compact :: HtmlAttr
367 content :: String -> HtmlAttr
368 coords :: String -> HtmlAttr
369 enctype :: String -> HtmlAttr
370 face :: String -> HtmlAttr
371 frameborder :: Int -> HtmlAttr
372 height :: Int -> HtmlAttr
373 href :: String -> HtmlAttr
374 hspace :: Int -> HtmlAttr
375 httpequiv :: String -> HtmlAttr
376 identifier :: String -> HtmlAttr
377 ismap :: HtmlAttr
378 lang :: String -> HtmlAttr
379 link :: String -> HtmlAttr
380 marginheight :: Int -> HtmlAttr
381 marginwidth :: Int -> HtmlAttr
382 maxlength :: Int -> HtmlAttr
383 method :: String -> HtmlAttr
384 multiple :: HtmlAttr
385 name :: String -> HtmlAttr
386 nohref :: HtmlAttr
387 noresize :: HtmlAttr
388 noshade :: HtmlAttr
389 nowrap :: HtmlAttr
390 rel :: String -> HtmlAttr
391 rev :: String -> HtmlAttr
392 rows :: String -> HtmlAttr
393 rowspan :: Int -> HtmlAttr
394 rules :: String -> HtmlAttr
395 scrolling :: String -> HtmlAttr
396 selected :: HtmlAttr
397 shape :: String -> HtmlAttr
398 size :: String -> HtmlAttr
399 src :: String -> HtmlAttr
400 start :: Int -> HtmlAttr
401 target :: String -> HtmlAttr
402 text :: String -> HtmlAttr
403 theclass :: String -> HtmlAttr
404 thestyle :: String -> HtmlAttr
405 thetype :: String -> HtmlAttr
406 title :: String -> HtmlAttr
407 usemap :: String -> HtmlAttr
408 valign :: String -> HtmlAttr
409 value :: String -> HtmlAttr
410 version :: String -> HtmlAttr
411 vlink :: String -> HtmlAttr
412 vspace :: Int -> HtmlAttr
413 width :: String -> HtmlAttr
414
415 action = strAttr "ACTION"
416 align = strAttr "ALIGN"
417 alink = strAttr "ALINK"
418 alt = strAttr "ALT"
419 altcode = strAttr "ALTCODE"
420 archive = strAttr "ARCHIVE"
421 background = strAttr "BACKGROUND"
422 base = strAttr "BASE"
423 bgcolor = strAttr "BGCOLOR"
424 border = intAttr "BORDER"
425 bordercolor = strAttr "BORDERCOLOR"
426 cellpadding = intAttr "CELLPADDING"
427 cellspacing = intAttr "CELLSPACING"
428 checked = emptyAttr "CHECKED"
429 clear = strAttr "CLEAR"
430 code = strAttr "CODE"
431 codebase = strAttr "CODEBASE"
432 color = strAttr "COLOR"
433 cols = strAttr "COLS"
434 colspan = intAttr "COLSPAN"
435 compact = emptyAttr "COMPACT"
436 content = strAttr "CONTENT"
437 coords = strAttr "COORDS"
438 enctype = strAttr "ENCTYPE"
439 face = strAttr "FACE"
440 frameborder = intAttr "FRAMEBORDER"
441 height = intAttr "HEIGHT"
442 href = strAttr "HREF"
443 hspace = intAttr "HSPACE"
444 httpequiv = strAttr "HTTP-EQUIV"
445 identifier = strAttr "ID"
446 ismap = emptyAttr "ISMAP"
447 lang = strAttr "LANG"
448 link = strAttr "LINK"
449 marginheight = intAttr "MARGINHEIGHT"
450 marginwidth = intAttr "MARGINWIDTH"
451 maxlength = intAttr "MAXLENGTH"
452 method = strAttr "METHOD"
453 multiple = emptyAttr "MULTIPLE"
454 name = strAttr "NAME"
455 nohref = emptyAttr "NOHREF"
456 noresize = emptyAttr "NORESIZE"
457 noshade = emptyAttr "NOSHADE"
458 nowrap = emptyAttr "NOWRAP"
459 rel = strAttr "REL"
460 rev = strAttr "REV"
461 rows = strAttr "ROWS"
462 rowspan = intAttr "ROWSPAN"
463 rules = strAttr "RULES"
464 scrolling = strAttr "SCROLLING"
465 selected = emptyAttr "SELECTED"
466 shape = strAttr "SHAPE"
467 size = strAttr "SIZE"
468 src = strAttr "SRC"
469 start = intAttr "START"
470 target = strAttr "TARGET"
471 text = strAttr "TEXT"
472 theclass = strAttr "CLASS"
473 thestyle = strAttr "STYLE"
474 thetype = strAttr "TYPE"
475 title = strAttr "TITLE"
476 usemap = strAttr "USEMAP"
477 valign = strAttr "VALIGN"
478 value = strAttr "VALUE"
479 version = strAttr "VERSION"
480 vlink = strAttr "VLINK"
481 vspace = intAttr "VSPACE"
482 width = strAttr "WIDTH"
483
484 -- ---------------------------------------------------------------------------
485 -- Html Constructors
486
487 -- (automatically generated)
488
489 validHtmlTags :: [String]
490 validHtmlTags = [
491 "ADDRESS",
492 "A",
493 "APPLET",
494 "BIG",
495 "BLOCKQUOTE",
496 "BODY",
497 "B",
498 "CAPTION",
499 "CENTER",
500 "CITE",
501 "DD",
502 "DFN",
503 "DL",
504 "DT",
505 "EM",
506 "FIELDSET",
507 "FONT",
508 "FORM",
509 "FRAME",
510 "FRAMESET",
511 "H1",
512 "H2",
513 "H3",
514 "H4",
515 "H5",
516 "H6",
517 "HEAD",
518 "I",
519 "KBD",
520 "LEGEND",
521 "LI",
522 "NOFRAMES",
523 "OL",
524 "OPTION",
525 "P",
526 "PRE",
527 "SAMP",
528 "SELECT",
529 "SMALL",
530 "STRONG",
531 "STYLE",
532 "SUB",
533 "SUP",
534 "TABLE",
535 "TD",
536 "TEXTAREA",
537 "TH",
538 "CODE",
539 "DIV",
540 "HTML",
541 "LINK",
542 "MAP",
543 "TITLE",
544 "TR",
545 "TT",
546 "UL",
547 "U",
548 "VAR"]
549
550 validHtmlITags :: [String]
551 validHtmlITags = [
552 "AREA",
553 "BASEFONT",
554 "BR",
555 "HR",
556 "IMG",
557 "INPUT",
558 "META",
559 "PARAM",
560 "BASE"]
561
562 validHtmlAttrs :: [String]
563 validHtmlAttrs = [
564 "ACTION",
565 "ALIGN",
566 "ALINK",
567 "ALT",
568 "ALTCODE",
569 "ARCHIVE",
570 "BACKGROUND",
571 "BASE",
572 "BGCOLOR",
573 "BORDER",
574 "BORDERCOLOR",
575 "CELLPADDING",
576 "CELLSPACING",
577 "CHECKED",
578 "CLEAR",
579 "CODE",
580 "CODEBASE",
581 "COLOR",
582 "COLS",
583 "COLSPAN",
584 "COMPACT",
585 "CONTENT",
586 "COORDS",
587 "ENCTYPE",
588 "FACE",
589 "FRAMEBORDER",
590 "HEIGHT",
591 "HREF",
592 "HSPACE",
593 "HTTP-EQUIV",
594 "ID",
595 "ISMAP",
596 "LANG",
597 "LINK",
598 "MARGINHEIGHT",
599 "MARGINWIDTH",
600 "MAXLENGTH",
601 "METHOD",
602 "MULTIPLE",
603 "NAME",
604 "NOHREF",
605 "NORESIZE",
606 "NOSHADE",
607 "NOWRAP",
608 "REL",
609 "REV",
610 "ROWS",
611 "ROWSPAN",
612 "RULES",
613 "SCROLLING",
614 "SELECTED",
615 "SHAPE",
616 "SIZE",
617 "SRC",
618 "START",
619 "TARGET",
620 "TEXT",
621 "CLASS",
622 "STYLE",
623 "TYPE",
624 "TITLE",
625 "USEMAP",
626 "VALIGN",
627 "VALUE",
628 "VERSION",
629 "VLINK",
630 "VSPACE",
631 "WIDTH"]
632
633 -- ---------------------------------------------------------------------------
634 -- Html colors
635
636 aqua :: String
637 black :: String
638 blue :: String
639 fuchsia :: String
640 gray :: String
641 green :: String
642 lime :: String
643 maroon :: String
644 navy :: String
645 olive :: String
646 purple :: String
647 red :: String
648 silver :: String
649 teal :: String
650 yellow :: String
651 white :: String
652
653 aqua = "aqua"
654 black = "black"
655 blue = "blue"
656 fuchsia = "fuchsia"
657 gray = "gray"
658 green = "green"
659 lime = "lime"
660 maroon = "maroon"
661 navy = "navy"
662 olive = "olive"
663 purple = "purple"
664 red = "red"
665 silver = "silver"
666 teal = "teal"
667 yellow = "yellow"
668 white = "white"
669
670 -- ---------------------------------------------------------------------------
671 -- Basic Combinators
672
673 linesToHtml :: [String] -> Html
674
675 linesToHtml [] = noHtml
676 linesToHtml (x:[]) = lineToHtml x
677 linesToHtml (x:xs) = lineToHtml x +++ br +++ linesToHtml xs
678
679
680 -- ---------------------------------------------------------------------------
681 -- Html abbriviations
682
683 primHtmlChar :: String -> Html
684 copyright :: Html
685 spaceHtml :: Html
686 bullet :: Html
687 p :: Html -> Html
688
689 primHtmlChar = \ x -> primHtml ("&" ++ x ++ ";")
690 copyright = primHtmlChar "copy"
691 spaceHtml = primHtmlChar "nbsp"
692 bullet = primHtmlChar "#149"
693
694 p = paragraph
695
696 -- ---------------------------------------------------------------------------
697 -- Html tables
698
699 class HTMLTABLE ht where
700 cell :: ht -> HtmlTable
701
702 instance HTMLTABLE HtmlTable where
703 cell = id
704
705 instance HTMLTABLE Html where
706 cell h =
707 let
708 cellFn x y = h ! (add x colspan $ add y rowspan $ [])
709 add 1 fn rest = rest
710 add n fn rest = fn n : rest
711 r = BT.single cellFn
712 in
713 mkHtmlTable r
714
715 -- We internally represent the Cell inside a Table with an
716 -- object of the type
717 -- \pre{
718 -- Int -> Int -> Html
719 -- }
720 -- When we render it later, we find out how many columns
721 -- or rows this cell will span over, and can
722 -- include the correct colspan/rowspan command.
723
724 newtype HtmlTable
725 = HtmlTable (BT.BlockTable (Int -> Int -> Html))
726
727
728 (</>),above,(<->),beside :: (HTMLTABLE ht1,HTMLTABLE ht2)
729 => ht1 -> ht2 -> HtmlTable
730 aboves,besides :: (HTMLTABLE ht) => [ht] -> HtmlTable
731 simpleTable :: [HtmlAttr] -> [HtmlAttr] -> [[Html]] -> Html
732
733
734 mkHtmlTable :: BT.BlockTable (Int -> Int -> Html) -> HtmlTable
735 mkHtmlTable r = HtmlTable r
736
737 -- We give both infix and nonfix, take your pick.
738 -- Notice that there is no concept of a row/column
739 -- of zero items.
740
741 above a b = combine BT.above (cell a) (cell b)
742 (</>) = above
743 beside a b = combine BT.beside (cell a) (cell b)
744 (<->) = beside
745
746
747 combine fn (HtmlTable a) (HtmlTable b) = mkHtmlTable (a `fn` b)
748
749 -- Both aboves and besides presume a non-empty list.
750 -- here is no concept of a empty row or column in these
751 -- table combinators.
752
753 aboves [] = error "aboves []"
754 aboves xs = foldr1 (</>) (map cell xs)
755 besides [] = error "besides []"
756 besides xs = foldr1 (<->) (map cell xs)
757
758 -- renderTable takes the HtmlTable, and renders it back into
759 -- and Html object.
760
761 renderTable :: BT.BlockTable (Int -> Int -> Html) -> Html
762 renderTable theTable
763 = concatHtml
764 [tr << [theCell x y | (theCell,(x,y)) <- theRow ]
765 | theRow <- BT.getMatrix theTable]
766
767 instance HTML HtmlTable where
768 toHtml (HtmlTable tab) = renderTable tab
769
770 instance Show HtmlTable where
771 showsPrec _ (HtmlTable tab) = shows (renderTable tab)
772
773
774 -- If you can't be bothered with the above, then you
775 -- can build simple tables with simpleTable.
776 -- Just provide the attributes for the whole table,
777 -- attributes for the cells (same for every cell),
778 -- and a list of lists of cell contents,
779 -- and this function will build the table for you.
780 -- It does presume that all the lists are non-empty,
781 -- and there is at least one list.
782 --
783 -- Different length lists means that the last cell
784 -- gets padded. If you want more power, then
785 -- use the system above, or build tables explicitly.
786
787 simpleTable attr cellAttr lst
788 = table ! attr
789 << (aboves
790 . map (besides . map ((td ! cellAttr) . toHtml))
791 ) lst
792
793
794 -- ---------------------------------------------------------------------------
795 -- Tree Displaying Combinators
796
797 -- The basic idea is you render your structure in the form
798 -- of this tree, and then use treeHtml to turn it into a Html
799 -- object with the structure explicit.
800
801 data HtmlTree
802 = HtmlLeaf Html
803 | HtmlNode Html [HtmlTree] Html
804
805 treeHtml :: [String] -> HtmlTree -> Html
806 treeHtml colors h = table ! [
807 border 0,
808 cellpadding 0,
809 cellspacing 2] << treeHtml' colors h
810 where
811 manycolors = scanr (:) []
812
813 treeHtmls :: [[String]] -> [HtmlTree] -> HtmlTable
814 treeHtmls c ts = aboves (zipWith treeHtml' c ts)
815
816 treeHtml' :: [String] -> HtmlTree -> HtmlTable
817 treeHtml' (c:_) (HtmlLeaf leaf) = cell
818 (td ! [width "100%"]
819 << bold
820 << leaf)
821 treeHtml' (c:cs@(c2:_)) (HtmlNode hopen ts hclose) =
822 if null ts && isNoHtml hclose
823 then
824 cell hd
825 else if null ts
826 then
827 hd </> bar `beside` (td ! [bgcolor c2] << spaceHtml)
828 </> tl
829 else
830 hd </> (bar `beside` treeHtmls morecolors ts)
831 </> tl
832 where
833 -- This stops a column of colors being the same
834 -- color as the immeduately outside nesting bar.
835 morecolors = filter ((/= c).head) (manycolors cs)
836 bar = td ! [bgcolor c,width "10"] << spaceHtml
837 hd = td ! [bgcolor c] << hopen
838 tl = td ! [bgcolor c] << hclose
839 treeHtml' _ _ = error "The imposible happens"
840
841 instance HTML HtmlTree where
842 toHtml x = treeHtml treeColors x
843
844 -- type "length treeColors" to see how many colors are here.
845 treeColors = ["#88ccff","#ffffaa","#ffaaff","#ccffff"] ++ treeColors
846
847
848 -- ---------------------------------------------------------------------------
849 -- Html Debugging Combinators
850
851 -- This uses the above tree rendering function, and displays the
852 -- Html as a tree structure, allowing debugging of what is
853 -- actually getting produced.
854
855 debugHtml :: (HTML a) => a -> Html
856 debugHtml obj = table ! [border 0] <<
857 ( th ! [bgcolor "#008888"]
858 << underline
859 << "Debugging Output"
860 </> td << (toHtml (debug' (toHtml obj)))
861 )
862 where
863
864 debug' :: Html -> [HtmlTree]
865 debug' (Html markups) = map debug markups
866
867 debug :: HtmlElement -> HtmlTree
868 debug (HtmlString str) = HtmlLeaf (spaceHtml +++
869 linesToHtml (lines str))
870 debug (HtmlTag {
871 markupTag = markupTag,
872 markupContent = markupContent,
873 markupAttrs = markupAttrs
874 }) =
875 case markupContent of
876 Html [] -> HtmlNode hd [] noHtml
877 Html xs -> HtmlNode hd (map debug xs) tl
878 where
879 args = if null markupAttrs
880 then ""
881 else " " ++ unwords (map show markupAttrs)
882 hd = font ! [size "1"] << ("<" ++ markupTag ++ args ++ ">")
883 tl = font ! [size "1"] << ("</" ++ markupTag ++ ">")
884
885 -- ---------------------------------------------------------------------------
886 -- Hotlink datatype
887
888 data HotLink = HotLink {
889 hotLinkURL :: URL,
890 hotLinkContents :: [Html],
891 hotLinkAttributes :: [HtmlAttr]
892 } deriving Show
893
894 instance HTML HotLink where
895 toHtml hl = anchor ! (href (hotLinkURL hl) : hotLinkAttributes hl)
896 << hotLinkContents hl
897
898 hotlink :: URL -> [Html] -> HotLink
899 hotlink url h = HotLink {
900 hotLinkURL = url,
901 hotLinkContents = h,
902 hotLinkAttributes = [] }
903
904
905 -- ---------------------------------------------------------------------------
906 -- More Combinators
907
908 -- (Abridged from Erik Meijer's Original Html library)
909
910 ordList :: (HTML a) => [a] -> Html
911 ordList items = olist << map (li <<) items
912
913 unordList :: (HTML a) => [a] -> Html
914 unordList items = ulist << map (li <<) items
915
916 defList :: (HTML a,HTML b) => [(a,b)] -> Html
917 defList items
918 = dlist << [ [ dterm << bold << dt, ddef << dd ] | (dt,dd) <- items ]
919
920
921 widget :: String -> String -> [HtmlAttr] -> Html
922 widget w n markupAttrs = input ! ([thetype w,name n] ++ markupAttrs)
923
924 checkbox :: String -> String -> Html
925 hidden :: String -> String -> Html
926 radio :: String -> String -> Html
927 reset :: String -> String -> Html
928 submit :: String -> String -> Html
929 password :: String -> Html
930 textfield :: String -> Html
931 afile :: String -> Html
932 clickmap :: String -> Html
933
934 checkbox n v = widget "CHECKBOX" n [value v]
935 hidden n v = widget "HIDDEN" n [value v]
936 radio n v = widget "RADIO" n [value v]
937 reset n v = widget "RESET" n [value v]
938 submit n v = widget "SUBMIT" n [value v]
939 password n = widget "PASSWORD" n []
940 textfield n = widget "TEXT" n []
941 afile n = widget "FILE" n []
942 clickmap n = widget "IMAGE" n []
943
944 menu :: String -> [Html] -> Html
945 menu n choices
946 = select ! [name n] << [ option << p << choice | choice <- choices ]
947
948 gui :: String -> Html -> Html
949 gui act = form ! [action act,method "POST"]
950
951 -- ---------------------------------------------------------------------------
952 -- Html Rendering
953
954 -- Uses the append trick to optimize appending.
955 -- The output is quite messy, because space matters in
956 -- HTML, so we must not generate needless spaces.
957
958 renderHtml :: (HTML html) => html -> String
959 renderHtml theHtml =
960 renderMessage ++
961 foldr (.) id (map (renderHtml' 0)
962 (getHtmlElements (tag "HTML" << theHtml))) "\n"
963
964 renderMessage =
965 "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 FINAL//EN\">\n" ++
966 "<!--Rendered using the Haskell Html Library v0.2-->\n"
967
968 -- Warning: spaces matters in HTML. You are better using renderHtml.
969 -- This is intentually very inefficent to "encorage" this,
970 -- but the neater version in easier when debugging.
971
972 -- Local Utilities
973 prettyHtml :: (HTML html) => html -> String
974 prettyHtml theHtml =
975 unlines
976 $ concat
977 $ map prettyHtml'
978 $ getHtmlElements
979 $ toHtml theHtml
980
981 renderHtml' :: Int -> HtmlElement -> ShowS
982 renderHtml' _ (HtmlString str) = (++) str
983 renderHtml' n (HtmlTag
984 { markupTag = name,
985 markupContent = html,
986 markupAttrs = markupAttrs })
987 = if isNoHtml html && elem name validHtmlITags
988 then renderTag True name markupAttrs n
989 else (renderTag True name markupAttrs n
990 . foldr (.) id (map (renderHtml' (n+2)) (getHtmlElements html))
991 . renderTag False name [] n)
992
993 prettyHtml' :: HtmlElement -> [String]
994 prettyHtml' (HtmlString str) = [str]
995 prettyHtml' (HtmlTag
996 { markupTag = name,
997 markupContent = html,
998 markupAttrs = markupAttrs })
999 = if isNoHtml html && elem name validHtmlITags
1000 then
1001 [rmNL (renderTag True name markupAttrs 0 "")]
1002 else
1003 [rmNL (renderTag True name markupAttrs 0 "")] ++
1004 shift (concat (map prettyHtml' (getHtmlElements html))) ++
1005 [rmNL (renderTag False name [] 0 "")]
1006 where
1007 shift = map (\x -> " " ++ x)
1008 rmNL = filter (/= '\n')
1009
1010 -- This prints the Tags The lack of spaces in intentunal, because Html is
1011 -- actually space dependant.
1012
1013 renderTag :: Bool -> String -> [HtmlAttr] -> Int -> ShowS
1014 renderTag x name markupAttrs n r
1015 = open ++ name ++ rest markupAttrs ++ ">" ++ r
1016 where
1017 open = if x then "<" else "</"
1018
1019 nl = "\n" ++ replicate (n `div` 8) '\t'
1020 ++ replicate (n `mod` 8) ' '
1021
1022 rest [] = nl
1023 rest attr = " " ++ unwords (map showPair attr) ++ nl
1024
1025 showPair :: HtmlAttr -> String
1026 showPair (HtmlAttr tag val)
1027 = tag ++ " = \"" ++ val ++ "\""
1028