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