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