1 {-# OPTIONS_GHC -fno-bang-patterns #-}
3 -----------------------------------------------------------------------------
6 -- Copyright : (c) Andy Gill and OGI, 1999-2001
7 -- License : BSD-style (see the file libraries/base/LICENSE)
9 -- Maintainer : Andy Gill <andy@galconn.com>
10 -- Stability : experimental
11 -- Portability : portable
13 -- An Html combinator library
15 -----------------------------------------------------------------------------
23 import qualified Text.Html.BlockTable as BT
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
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 >,etc.
38 - ..just..plain..normal..text... but using © and &amb;, etc.
42 - <thetag {..attrs..}> ..content.. </thetag>
44 | HtmlTag { -- tag with internal markup
46 markupAttrs :: [HtmlAttr],
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).
56 data HtmlAttr = HtmlAttr String String
59 newtype Html = Html { getHtmlElements :: [HtmlElement] }
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.
67 toHtmlFromList :: [a] -> Html
69 toHtmlFromList xs = Html (concat [ x | (Html x) <- map toHtml xs])
71 instance HTML Html where
74 instance HTML Char where
76 toHtmlFromList [] = Html []
77 toHtmlFromList str = Html [HtmlString (stringToHtmlString str)]
79 instance (HTML a) => HTML [a] where
80 toHtml xs = toHtmlFromList xs
82 class ADDATTRS a where
83 (!) :: a -> [HtmlAttr] -> a
85 instance (ADDATTRS b) => ADDATTRS (a -> b) where
86 fn ! attr = \ arg -> fn arg ! attr
88 instance ADDATTRS Html where
89 (Html htmls) ! attr = Html (map addAttrs htmls)
91 addAttrs (html@(HtmlTag { markupAttrs = markupAttrs }) )
92 = html { markupAttrs = markupAttrs ++ attr }
96 (<<) :: (HTML a) => (Html -> b) -> a -> b
97 fn << arg = fn (toHtml arg)
100 concatHtml :: (HTML a) => [a] -> Html
101 concatHtml as = Html (concat (map (getHtmlElements.toHtml) as))
103 (+++) :: (HTML a,HTML b) => a -> b -> Html
104 a +++ b = Html (getHtmlElements (toHtml a) ++ getHtmlElements (toHtml b))
110 isNoHtml (Html xs) = null xs
113 tag :: String -> Html -> Html
114 tag str htmls = Html [
118 markupContent = htmls }]
120 itag :: String -> Html
121 itag str = tag str noHtml
123 emptyAttr :: String -> HtmlAttr
124 emptyAttr s = HtmlAttr s ""
126 intAttr :: String -> Int -> HtmlAttr
127 intAttr s i = HtmlAttr s (show i)
129 strAttr :: String -> String -> HtmlAttr
130 strAttr s t = HtmlAttr s t
134 foldHtml :: (String -> [HtmlAttr] -> [a] -> a)
138 foldHtml f g (HtmlTag str attr fmls)
139 = f str attr (map (foldHtml f g) fmls)
140 foldHtml f g (HtmlString str)
144 -- Processing Strings into Html friendly things.
145 -- This converts a String to a Html String.
146 stringToHtmlString :: String -> String
147 stringToHtmlString = concatMap fixChar
151 fixChar '&' = "&"
152 fixChar '"' = """
155 -- ---------------------------------------------------------------------------
158 instance Show Html where
159 showsPrec _ html = showString (prettyHtml html)
160 showList htmls = showString (concat (map show htmls))
162 instance Show HtmlAttr where
163 showsPrec _ (HtmlAttr str val) =
169 -- ---------------------------------------------------------------------------
174 -- ---------------------------------------------------------------------------
177 -- This is not processed for special chars.
178 -- use stringToHtml or lineToHtml instead, for user strings,
179 -- because they understand special chars, like '<'.
181 primHtml :: String -> Html
182 primHtml x = Html [HtmlString x]
184 -- ---------------------------------------------------------------------------
187 stringToHtml :: String -> Html
188 stringToHtml = primHtml . stringToHtmlString
190 -- This converts a string, but keeps spaces as non-line-breakable
192 lineToHtml :: String -> Html
193 lineToHtml = primHtml . concatMap htmlizeChar2 . stringToHtmlString
195 htmlizeChar2 ' ' = " "
198 -- ---------------------------------------------------------------------------
201 -- (automatically generated)
203 address :: Html -> Html
204 anchor :: Html -> Html
205 applet :: Html -> Html
209 blockquote :: Html -> Html
213 caption :: Html -> Html
214 center :: Html -> Html
217 define :: Html -> Html
218 dlist :: Html -> Html
219 dterm :: Html -> Html
220 emphasize :: Html -> Html
221 fieldset :: Html -> Html
224 frame :: Html -> Html
225 frameset :: Html -> Html
232 header :: Html -> Html
236 italics :: Html -> Html
237 keyboard :: Html -> Html
238 legend :: Html -> Html
241 noframes :: Html -> Html
242 olist :: Html -> Html
243 option :: Html -> Html
244 paragraph :: Html -> Html
247 sample :: Html -> Html
248 select :: Html -> Html
249 small :: Html -> Html
250 strong :: Html -> Html
251 style :: Html -> Html
254 table :: Html -> Html
256 textarea :: Html -> 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
268 ulist :: Html -> Html
269 underline :: Html -> Html
270 variable :: Html -> Html
272 address = tag "ADDRESS"
274 applet = tag "APPLET"
276 basefont = itag "BASEFONT"
278 blockquote = tag "BLOCKQUOTE"
282 caption = tag "CAPTION"
283 center = tag "CENTER"
290 fieldset = tag "FIELDSET"
294 frameset = tag "FRAMESET"
307 legend = tag "LEGEND"
310 noframes = tag "NOFRAMES"
312 option = tag "OPTION"
317 select = tag "SELECT"
319 strong = tag "STRONG"
325 textarea = tag "TEXTAREA"
327 thebase = itag "BASE"
334 thetitle = tag "TITLE"
341 -- ---------------------------------------------------------------------------
344 -- (automatically generated)
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
360 clear :: String -> HtmlAttr
361 code :: String -> HtmlAttr
362 codebase :: String -> HtmlAttr
363 color :: String -> HtmlAttr
364 cols :: String -> HtmlAttr
365 colspan :: Int -> 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
378 lang :: String -> HtmlAttr
379 link :: String -> HtmlAttr
380 marginheight :: Int -> HtmlAttr
381 marginwidth :: Int -> HtmlAttr
382 maxlength :: Int -> HtmlAttr
383 method :: String -> HtmlAttr
385 name :: String -> 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
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
415 action = strAttr "ACTION"
416 align = strAttr "ALIGN"
417 alink = strAttr "ALINK"
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"
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"
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"
484 -- ---------------------------------------------------------------------------
487 -- (automatically generated)
489 validHtmlTags :: [String]
550 validHtmlITags :: [String]
562 validHtmlAttrs :: [String]
633 -- ---------------------------------------------------------------------------
670 -- ---------------------------------------------------------------------------
673 linesToHtml :: [String] -> Html
675 linesToHtml [] = noHtml
676 linesToHtml (x:[]) = lineToHtml x
677 linesToHtml (x:xs) = lineToHtml x +++ br +++ linesToHtml xs
680 -- ---------------------------------------------------------------------------
681 -- Html abbriviations
683 primHtmlChar :: String -> Html
689 primHtmlChar = \ x -> primHtml ("&" ++ x ++ ";")
690 copyright = primHtmlChar "copy"
691 spaceHtml = primHtmlChar "nbsp"
692 bullet = primHtmlChar "#149"
696 -- ---------------------------------------------------------------------------
699 class HTMLTABLE ht where
700 cell :: ht -> HtmlTable
702 instance HTMLTABLE HtmlTable where
705 instance HTMLTABLE Html where
708 cellFn x y = h ! (add x colspan $ add y rowspan $ [])
710 add n fn rest = fn n : rest
715 -- We internally represent the Cell inside a Table with an
716 -- object of the type
718 -- Int -> Int -> Html
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.
725 = HtmlTable (BT.BlockTable (Int -> Int -> Html))
728 (</>),above,(<->),beside :: (HTMLTABLE ht1,HTMLTABLE ht2)
729 => ht1 -> ht2 -> HtmlTable
730 aboves,besides :: (HTMLTABLE ht) => [ht] -> HtmlTable
731 simpleTable :: [HtmlAttr] -> [HtmlAttr] -> [[Html]] -> Html
734 mkHtmlTable :: BT.BlockTable (Int -> Int -> Html) -> HtmlTable
735 mkHtmlTable r = HtmlTable r
737 -- We give both infix and nonfix, take your pick.
738 -- Notice that there is no concept of a row/column
741 above a b = combine BT.above (cell a) (cell b)
743 beside a b = combine BT.beside (cell a) (cell b)
747 combine fn (HtmlTable a) (HtmlTable b) = mkHtmlTable (a `fn` b)
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.
753 aboves [] = error "aboves []"
754 aboves xs = foldr1 (</>) (map cell xs)
755 besides [] = error "besides []"
756 besides xs = foldr1 (<->) (map cell xs)
758 -- renderTable takes the HtmlTable, and renders it back into
761 renderTable :: BT.BlockTable (Int -> Int -> Html) -> Html
764 [tr << [theCell x y | (theCell,(x,y)) <- theRow ]
765 | theRow <- BT.getMatrix theTable]
767 instance HTML HtmlTable where
768 toHtml (HtmlTable tab) = renderTable tab
770 instance Show HtmlTable where
771 showsPrec _ (HtmlTable tab) = shows (renderTable tab)
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.
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.
787 simpleTable attr cellAttr lst
790 . map (besides . map ((td ! cellAttr) . toHtml))
794 -- ---------------------------------------------------------------------------
795 -- Tree Displaying Combinators
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.
803 | HtmlNode Html [HtmlTree] Html
805 treeHtml :: [String] -> HtmlTree -> Html
806 treeHtml colors h = table ! [
809 cellspacing 2] << treeHtml' colors h
811 manycolors = scanr (:) []
813 treeHtmls :: [[String]] -> [HtmlTree] -> HtmlTable
814 treeHtmls c ts = aboves (zipWith treeHtml' c ts)
816 treeHtml' :: [String] -> HtmlTree -> HtmlTable
817 treeHtml' (c:_) (HtmlLeaf leaf) = cell
821 treeHtml' (c:cs@(c2:_)) (HtmlNode hopen ts hclose) =
822 if null ts && isNoHtml hclose
827 hd </> bar `beside` (td ! [bgcolor c2] << spaceHtml)
830 hd </> (bar `beside` treeHtmls morecolors ts)
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"
841 instance HTML HtmlTree where
842 toHtml x = treeHtml treeColors x
844 -- type "length treeColors" to see how many colors are here.
845 treeColors = ["#88ccff","#ffffaa","#ffaaff","#ccffff"] ++ treeColors
848 -- ---------------------------------------------------------------------------
849 -- Html Debugging Combinators
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.
855 debugHtml :: (HTML a) => a -> Html
856 debugHtml obj = table ! [border 0] <<
857 ( th ! [bgcolor "#008888"]
859 << "Debugging Output"
860 </> td << (toHtml (debug' (toHtml obj)))
864 debug' :: Html -> [HtmlTree]
865 debug' (Html markups) = map debug markups
867 debug :: HtmlElement -> HtmlTree
868 debug (HtmlString str) = HtmlLeaf (spaceHtml +++
869 linesToHtml (lines str))
871 markupTag = markupTag,
872 markupContent = markupContent,
873 markupAttrs = markupAttrs
875 case markupContent of
876 Html [] -> HtmlNode hd [] noHtml
877 Html xs -> HtmlNode hd (map debug xs) tl
879 args = if null markupAttrs
881 else " " ++ unwords (map show markupAttrs)
882 hd = font ! [size "1"] << ("<" ++ markupTag ++ args ++ ">")
883 tl = font ! [size "1"] << ("</" ++ markupTag ++ ">")
885 -- ---------------------------------------------------------------------------
888 data HotLink = HotLink {
890 hotLinkContents :: [Html],
891 hotLinkAttributes :: [HtmlAttr]
894 instance HTML HotLink where
895 toHtml hl = anchor ! (href (hotLinkURL hl) : hotLinkAttributes hl)
896 << hotLinkContents hl
898 hotlink :: URL -> [Html] -> HotLink
899 hotlink url h = HotLink {
902 hotLinkAttributes = [] }
905 -- ---------------------------------------------------------------------------
908 -- (Abridged from Erik Meijer's Original Html library)
910 ordList :: (HTML a) => [a] -> Html
911 ordList items = olist << map (li <<) items
913 unordList :: (HTML a) => [a] -> Html
914 unordList items = ulist << map (li <<) items
916 defList :: (HTML a,HTML b) => [(a,b)] -> Html
918 = dlist << [ [ dterm << bold << dt, ddef << dd ] | (dt,dd) <- items ]
921 widget :: String -> String -> [HtmlAttr] -> Html
922 widget w n markupAttrs = input ! ([thetype w,name n] ++ markupAttrs)
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
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 []
944 menu :: String -> [Html] -> Html
946 = select ! [name n] << [ option << p << choice | choice <- choices ]
948 gui :: String -> Html -> Html
949 gui act = form ! [action act,method "POST"]
951 -- ---------------------------------------------------------------------------
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.
958 renderHtml :: (HTML html) => html -> String
961 foldr (.) id (map (renderHtml' 0)
962 (getHtmlElements (tag "HTML" << theHtml))) "\n"
965 "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 FINAL//EN\">\n" ++
966 "<!--Rendered using the Haskell Html Library v0.2-->\n"
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.
973 prettyHtml :: (HTML html) => html -> String
981 renderHtml' :: Int -> HtmlElement -> ShowS
982 renderHtml' _ (HtmlString str) = (++) str
983 renderHtml' n (HtmlTag
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)
993 prettyHtml' :: HtmlElement -> [String]
994 prettyHtml' (HtmlString str) = [str]
997 markupContent = html,
998 markupAttrs = markupAttrs })
999 = if isNoHtml html && elem name validHtmlITags
1001 [rmNL (renderTag True name markupAttrs 0 "")]
1003 [rmNL (renderTag True name markupAttrs 0 "")] ++
1004 shift (concat (map prettyHtml' (getHtmlElements html))) ++
1005 [rmNL (renderTag False name [] 0 "")]
1007 shift = map (\x -> " " ++ x)
1008 rmNL = filter (/= '\n')
1010 -- This prints the Tags The lack of spaces in intentunal, because Html is
1011 -- actually space dependant.
1013 renderTag :: Bool -> String -> [HtmlAttr] -> Int -> ShowS
1014 renderTag x name markupAttrs n r
1015 = open ++ name ++ rest markupAttrs ++ ">" ++ r
1017 open = if x then "<" else "</"
1019 nl = "\n" ++ replicate (n `div` 8) '\t'
1020 ++ replicate (n `mod` 8) ' '
1023 rest attr = " " ++ unwords (map showPair attr) ++ nl
1025 showPair :: HtmlAttr -> String
1026 showPair (HtmlAttr tag val)
1027 = tag ++ " = \"" ++ val ++ "\""