1 -----------------------------------------------------------------------------
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/base/LICENSE)
8 -- Maintainer : Andy Gill <andy@galconn.com>
9 -- Stability : experimental
10 -- Portability : portable
12 -- An Html combinator library
14 -----------------------------------------------------------------------------
22 import qualified Text.Html.BlockTable as BT
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
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 >,etc.
37 - ..just..plain..normal..text... but using © and &amb;, etc.
41 - <thetag {..attrs..}> ..content.. </thetag>
43 | HtmlTag { -- tag with internal markup
45 markupAttrs :: [HtmlAttr],
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).
55 data HtmlAttr = HtmlAttr String String
58 newtype Html = Html { getHtmlElements :: [HtmlElement] }
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.
66 toHtmlFromList :: [a] -> Html
68 toHtmlFromList xs = Html (concat [ x | (Html x) <- map toHtml xs])
70 instance HTML Html where
73 instance HTML Char where
75 toHtmlFromList [] = Html []
76 toHtmlFromList str = Html [HtmlString (stringToHtmlString str)]
78 instance (HTML a) => HTML [a] where
79 toHtml xs = toHtmlFromList xs
81 class ADDATTRS a where
82 (!) :: a -> [HtmlAttr] -> a
84 instance (ADDATTRS b) => ADDATTRS (a -> b) where
85 fn ! attr = \ arg -> fn arg ! attr
87 instance ADDATTRS Html where
88 (Html htmls) ! attr = Html (map addAttrs htmls)
90 addAttrs (html@(HtmlTag { markupAttrs = markupAttrs }) )
91 = html { markupAttrs = markupAttrs ++ attr }
95 (<<) :: (HTML a) => (Html -> b) -> a -> b
96 fn << arg = fn (toHtml arg)
99 concatHtml :: (HTML a) => [a] -> Html
100 concatHtml as = Html (concat (map (getHtmlElements.toHtml) as))
102 (+++) :: (HTML a,HTML b) => a -> b -> Html
103 a +++ b = Html (getHtmlElements (toHtml a) ++ getHtmlElements (toHtml b))
109 isNoHtml (Html xs) = null xs
112 tag :: String -> Html -> Html
113 tag str htmls = Html [
117 markupContent = htmls }]
119 itag :: String -> Html
120 itag str = tag str noHtml
122 emptyAttr :: String -> HtmlAttr
123 emptyAttr s = HtmlAttr s ""
125 intAttr :: String -> Int -> HtmlAttr
126 intAttr s i = HtmlAttr s (show i)
128 strAttr :: String -> String -> HtmlAttr
129 strAttr s t = HtmlAttr s t
133 foldHtml :: (String -> [HtmlAttr] -> [a] -> a)
137 foldHtml f g (HtmlTag str attr fmls)
138 = f str attr (map (foldHtml f g) fmls)
139 foldHtml f g (HtmlString str)
143 -- Processing Strings into Html friendly things.
144 -- This converts a String to a Html String.
145 stringToHtmlString :: String -> String
146 stringToHtmlString = concatMap fixChar
150 fixChar '&' = "&"
151 fixChar '"' = """
154 -- ---------------------------------------------------------------------------
157 instance Show Html where
158 showsPrec _ html = showString (prettyHtml html)
159 showList htmls = showString (concat (map show htmls))
161 instance Show HtmlAttr where
162 showsPrec _ (HtmlAttr str val) =
168 -- ---------------------------------------------------------------------------
173 -- ---------------------------------------------------------------------------
176 -- This is not processed for special chars.
177 -- use stringToHtml or lineToHtml instead, for user strings,
178 -- because they understand special chars, like '<'.
180 primHtml :: String -> Html
181 primHtml x = Html [HtmlString x]
183 -- ---------------------------------------------------------------------------
186 stringToHtml :: String -> Html
187 stringToHtml = primHtml . stringToHtmlString
189 -- This converts a string, but keeps spaces as non-line-breakable
191 lineToHtml :: String -> Html
192 lineToHtml = primHtml . concatMap htmlizeChar2 . stringToHtmlString
194 htmlizeChar2 ' ' = " "
197 -- ---------------------------------------------------------------------------
200 -- (automatically generated)
202 address :: Html -> Html
203 anchor :: Html -> Html
204 applet :: Html -> Html
208 blockquote :: Html -> Html
212 caption :: Html -> Html
213 center :: Html -> Html
216 define :: Html -> Html
217 dlist :: Html -> Html
218 dterm :: Html -> Html
219 emphasize :: Html -> Html
220 fieldset :: Html -> Html
223 frame :: Html -> Html
224 frameset :: Html -> Html
231 header :: Html -> Html
235 italics :: Html -> Html
236 keyboard :: Html -> Html
237 legend :: Html -> Html
240 noframes :: Html -> Html
241 olist :: Html -> Html
242 option :: Html -> Html
243 paragraph :: Html -> Html
246 sample :: Html -> Html
247 select :: Html -> Html
248 small :: Html -> Html
249 strong :: Html -> Html
250 style :: Html -> Html
253 table :: Html -> Html
255 textarea :: Html -> 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
267 ulist :: Html -> Html
268 underline :: Html -> Html
269 variable :: Html -> Html
271 address = tag "ADDRESS"
273 applet = tag "APPLET"
275 basefont = itag "BASEFONT"
277 blockquote = tag "BLOCKQUOTE"
281 caption = tag "CAPTION"
282 center = tag "CENTER"
289 fieldset = tag "FIELDSET"
293 frameset = tag "FRAMESET"
306 legend = tag "LEGEND"
309 noframes = tag "NOFRAMES"
311 option = tag "OPTION"
316 select = tag "SELECT"
318 strong = tag "STRONG"
324 textarea = tag "TEXTAREA"
326 thebase = itag "BASE"
333 thetitle = tag "TITLE"
340 -- ---------------------------------------------------------------------------
343 -- (automatically generated)
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
359 clear :: String -> HtmlAttr
360 code :: String -> HtmlAttr
361 codebase :: String -> HtmlAttr
362 color :: String -> HtmlAttr
363 cols :: String -> HtmlAttr
364 colspan :: Int -> 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
377 lang :: String -> HtmlAttr
378 link :: String -> HtmlAttr
379 marginheight :: Int -> HtmlAttr
380 marginwidth :: Int -> HtmlAttr
381 maxlength :: Int -> HtmlAttr
382 method :: String -> HtmlAttr
384 name :: String -> 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
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
414 action = strAttr "ACTION"
415 align = strAttr "ALIGN"
416 alink = strAttr "ALINK"
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"
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"
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"
483 -- ---------------------------------------------------------------------------
486 -- (automatically generated)
488 validHtmlTags :: [String]
549 validHtmlITags :: [String]
561 validHtmlAttrs :: [String]
632 -- ---------------------------------------------------------------------------
669 -- ---------------------------------------------------------------------------
672 linesToHtml :: [String] -> Html
674 linesToHtml [] = noHtml
675 linesToHtml (x:[]) = lineToHtml x
676 linesToHtml (x:xs) = lineToHtml x +++ br +++ linesToHtml xs
679 -- ---------------------------------------------------------------------------
680 -- Html abbriviations
682 primHtmlChar :: String -> Html
688 primHtmlChar = \ x -> primHtml ("&" ++ x ++ ";")
689 copyright = primHtmlChar "copy"
690 spaceHtml = primHtmlChar "nbsp"
691 bullet = primHtmlChar "#149"
695 -- ---------------------------------------------------------------------------
698 class HTMLTABLE ht where
699 cell :: ht -> HtmlTable
701 instance HTMLTABLE HtmlTable where
704 instance HTMLTABLE Html where
707 cellFn x y = h ! (add x colspan $ add y rowspan $ [])
709 add n fn rest = fn n : rest
714 -- We internally represent the Cell inside a Table with an
715 -- object of the type
717 -- Int -> Int -> Html
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.
724 = HtmlTable (BT.BlockTable (Int -> Int -> Html))
727 (</>),above,(<->),beside :: (HTMLTABLE ht1,HTMLTABLE ht2)
728 => ht1 -> ht2 -> HtmlTable
729 aboves,besides :: (HTMLTABLE ht) => [ht] -> HtmlTable
730 simpleTable :: [HtmlAttr] -> [HtmlAttr] -> [[Html]] -> Html
733 mkHtmlTable :: BT.BlockTable (Int -> Int -> Html) -> HtmlTable
734 mkHtmlTable r = HtmlTable r
736 -- We give both infix and nonfix, take your pick.
737 -- Notice that there is no concept of a row/column
740 above a b = combine BT.above (cell a) (cell b)
742 beside a b = combine BT.beside (cell a) (cell b)
746 combine fn (HtmlTable a) (HtmlTable b) = mkHtmlTable (a `fn` b)
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.
752 aboves [] = error "aboves []"
753 aboves xs = foldr1 (</>) (map cell xs)
754 besides [] = error "besides []"
755 besides xs = foldr1 (<->) (map cell xs)
757 -- renderTable takes the HtmlTable, and renders it back into
760 renderTable :: BT.BlockTable (Int -> Int -> Html) -> Html
763 [tr << [theCell x y | (theCell,(x,y)) <- theRow ]
764 | theRow <- BT.getMatrix theTable]
766 instance HTML HtmlTable where
767 toHtml (HtmlTable tab) = renderTable tab
769 instance Show HtmlTable where
770 showsPrec _ (HtmlTable tab) = shows (renderTable tab)
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.
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.
786 simpleTable attr cellAttr lst
789 . map (besides . map ((td ! cellAttr) . toHtml))
793 -- ---------------------------------------------------------------------------
794 -- Tree Displaying Combinators
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.
802 | HtmlNode Html [HtmlTree] Html
804 treeHtml :: [String] -> HtmlTree -> Html
805 treeHtml colors h = table ! [
808 cellspacing 2] << treeHtml' colors h
810 manycolors = scanr (:) []
812 treeHtmls :: [[String]] -> [HtmlTree] -> HtmlTable
813 treeHtmls c ts = aboves (zipWith treeHtml' c ts)
815 treeHtml' :: [String] -> HtmlTree -> HtmlTable
816 treeHtml' (c:_) (HtmlLeaf leaf) = cell
820 treeHtml' (c:cs@(c2:_)) (HtmlNode hopen ts hclose) =
821 if null ts && isNoHtml hclose
826 hd </> bar `beside` (td ! [bgcolor c2] << spaceHtml)
829 hd </> (bar `beside` treeHtmls morecolors ts)
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"
840 instance HTML HtmlTree where
841 toHtml x = treeHtml treeColors x
843 -- type "length treeColors" to see how many colors are here.
844 treeColors = ["#88ccff","#ffffaa","#ffaaff","#ccffff"] ++ treeColors
847 -- ---------------------------------------------------------------------------
848 -- Html Debugging Combinators
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.
854 debugHtml :: (HTML a) => a -> Html
855 debugHtml obj = table ! [border 0] <<
856 ( th ! [bgcolor "#008888"]
858 << "Debugging Output"
859 </> td << (toHtml (debug' (toHtml obj)))
863 debug' :: Html -> [HtmlTree]
864 debug' (Html markups) = map debug markups
866 debug :: HtmlElement -> HtmlTree
867 debug (HtmlString str) = HtmlLeaf (spaceHtml +++
868 linesToHtml (lines str))
870 markupTag = markupTag,
871 markupContent = markupContent,
872 markupAttrs = markupAttrs
874 case markupContent of
875 Html [] -> HtmlNode hd [] noHtml
876 Html xs -> HtmlNode hd (map debug xs) tl
878 args = if null markupAttrs
880 else " " ++ unwords (map show markupAttrs)
881 hd = font ! [size "1"] << ("<" ++ markupTag ++ args ++ ">")
882 tl = font ! [size "1"] << ("</" ++ markupTag ++ ">")
884 -- ---------------------------------------------------------------------------
887 data HotLink = HotLink {
889 hotLinkContents :: [Html],
890 hotLinkAttributes :: [HtmlAttr]
893 instance HTML HotLink where
894 toHtml hl = anchor ! (href (hotLinkURL hl) : hotLinkAttributes hl)
895 << hotLinkContents hl
897 hotlink :: URL -> [Html] -> HotLink
898 hotlink url h = HotLink {
901 hotLinkAttributes = [] }
904 -- ---------------------------------------------------------------------------
907 -- (Abridged from Erik Meijer's Original Html library)
909 ordList :: (HTML a) => [a] -> Html
910 ordList items = olist << map (li <<) items
912 unordList :: (HTML a) => [a] -> Html
913 unordList items = ulist << map (li <<) items
915 defList :: (HTML a,HTML b) => [(a,b)] -> Html
917 = dlist << [ [ dterm << bold << dt, ddef << dd ] | (dt,dd) <- items ]
920 widget :: String -> String -> [HtmlAttr] -> Html
921 widget w n markupAttrs = input ! ([thetype w,name n] ++ markupAttrs)
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
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 []
943 menu :: String -> [Html] -> Html
945 = select ! [name n] << [ option << p << choice | choice <- choices ]
947 gui :: String -> Html -> Html
948 gui act = form ! [action act,method "POST"]
950 -- ---------------------------------------------------------------------------
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.
957 renderHtml :: (HTML html) => html -> String
960 foldr (.) id (map (renderHtml' 0)
961 (getHtmlElements (tag "HTML" << theHtml))) "\n"
964 "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 FINAL//EN\">\n" ++
965 "<!--Rendered using the Haskell Html Library v0.2-->\n"
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.
972 prettyHtml :: (HTML html) => html -> String
980 renderHtml' :: Int -> HtmlElement -> ShowS
981 renderHtml' _ (HtmlString str) = (++) str
982 renderHtml' n (HtmlTag
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)
992 prettyHtml' :: HtmlElement -> [String]
993 prettyHtml' (HtmlString str) = [str]
996 markupContent = html,
997 markupAttrs = markupAttrs })
998 = if isNoHtml html && elem name validHtmlITags
1000 [rmNL (renderTag True name markupAttrs 0 "")]
1002 [rmNL (renderTag True name markupAttrs 0 "")] ++
1003 shift (concat (map prettyHtml' (getHtmlElements html))) ++
1004 [rmNL (renderTag False name [] 0 "")]
1006 shift = map (\x -> " " ++ x)
1007 rmNL = filter (/= '\n')
1009 -- This prints the Tags The lack of spaces in intentunal, because Html is
1010 -- actually space dependant.
1012 renderTag :: Bool -> String -> [HtmlAttr] -> Int -> ShowS
1013 renderTag x name markupAttrs n r
1014 = open ++ name ++ rest markupAttrs ++ ">" ++ r
1016 open = if x then "<" else "</"
1018 nl = "\n" ++ replicate (n `div` 8) '\t'
1019 ++ replicate (n `mod` 8) ' '
1022 rest attr = " " ++ unwords (map showPair attr) ++ nl
1024 showPair :: HtmlAttr -> String
1025 showPair (HtmlAttr tag val)
1026 = tag ++ " = \"" ++ val ++ "\""