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