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/core/LICENSE)
8 -- Maintainer : Andy Gill <andy@galconn.com>
9 -- Stability : experimental
10 -- Portability : portable
12 -- $Id: Html.hs,v 1.2 2002/04/24 16:31:46 simonmar Exp $
14 -- An Html combinator library
16 -----------------------------------------------------------------------------
24 import qualified Text.Html.BlockTable as BT
26 infixr 3 </> -- combining table cells
27 infixr 4 <-> -- combining table cells
28 infixr 2 +++ -- combining Html
29 infixr 7 << -- nesting Html
30 infixl 8 ! -- adding optional arguments
33 -- A important property of Html is that all strings inside the
34 -- structure are already in Html friendly format.
35 -- For example, use of >,etc.
39 - ..just..plain..normal..text... but using © and &amb;, etc.
43 - <thetag {..attrs..}> ..content.. </thetag>
45 | HtmlTag { -- tag with internal markup
47 markupAttrs :: [HtmlAttr],
51 {- These are the index-value pairs.
52 - The empty string is a synonym for tags with no arguments.
53 - (not strictly HTML, but anyway).
57 data HtmlAttr = HtmlAttr String String
60 newtype Html = Html { getHtmlElements :: [HtmlElement] }
62 -- Read MARKUP as the class of things that can be validly rendered
63 -- inside MARKUP tag brackets. So this can be one or more Html's,
64 -- or a String, for example.
68 toHtmlFromList :: [a] -> Html
70 toHtmlFromList xs = Html (concat [ x | (Html x) <- map toHtml xs])
72 instance HTML Html where
75 instance HTML Char where
77 toHtmlFromList [] = Html []
78 toHtmlFromList str = Html [HtmlString (stringToHtmlString str)]
80 instance (HTML a) => HTML [a] where
81 toHtml xs = toHtmlFromList xs
83 class ADDATTRS a where
84 (!) :: a -> [HtmlAttr] -> a
86 instance (ADDATTRS b) => ADDATTRS (a -> b) where
87 fn ! attr = \ arg -> fn arg ! attr
89 instance ADDATTRS Html where
90 (Html htmls) ! attr = Html (map addAttrs htmls)
92 addAttrs (html@(HtmlTag { markupAttrs = markupAttrs }) )
93 = html { markupAttrs = markupAttrs ++ attr }
97 (<<) :: (HTML a) => (Html -> b) -> a -> b
98 fn << arg = fn (toHtml arg)
101 concatHtml :: (HTML a) => [a] -> Html
102 concatHtml as = Html (concat (map (getHtmlElements.toHtml) as))
104 (+++) :: (HTML a,HTML b) => a -> b -> Html
105 a +++ b = Html (getHtmlElements (toHtml a) ++ getHtmlElements (toHtml b))
111 isNoHtml (Html xs) = null xs
114 tag :: String -> Html -> Html
115 tag str htmls = Html [
119 markupContent = htmls }]
121 itag :: String -> Html
122 itag str = tag str noHtml
124 emptyAttr :: String -> HtmlAttr
125 emptyAttr s = HtmlAttr s ""
127 intAttr :: String -> Int -> HtmlAttr
128 intAttr s i = HtmlAttr s (show i)
130 strAttr :: String -> String -> HtmlAttr
131 strAttr s t = HtmlAttr s t
135 foldHtml :: (String -> [HtmlAttr] -> [a] -> a)
139 foldHtml f g (HtmlTag str attr fmls)
140 = f str attr (map (foldHtml f g) fmls)
141 foldHtml f g (HtmlString str)
145 -- Processing Strings into Html friendly things.
146 -- This converts a String to a Html String.
147 stringToHtmlString :: String -> String
148 stringToHtmlString = concatMap fixChar
152 fixChar '&' = "&"
153 fixChar '"' = """
156 -- ---------------------------------------------------------------------------
159 instance Show Html where
160 showsPrec _ html = showString (prettyHtml html)
161 showList htmls = showString (concat (map show htmls))
163 instance Show HtmlAttr where
164 showsPrec _ (HtmlAttr str val) =
170 -- ---------------------------------------------------------------------------
175 -- ---------------------------------------------------------------------------
178 -- This is not processed for special chars.
179 -- use stringToHtml or lineToHtml instead, for user strings,
180 -- because they understand special chars, like '<'.
182 primHtml :: String -> Html
183 primHtml x = Html [HtmlString x]
185 -- ---------------------------------------------------------------------------
188 stringToHtml :: String -> Html
189 stringToHtml = primHtml . stringToHtmlString
191 -- This converts a string, but keeps spaces as non-line-breakable
193 lineToHtml :: String -> Html
194 lineToHtml = primHtml . concatMap htmlizeChar2 . stringToHtmlString
196 htmlizeChar2 ' ' = " "
199 -- ---------------------------------------------------------------------------
202 -- (automatically generated)
204 address :: Html -> Html
205 anchor :: Html -> Html
206 applet :: Html -> Html
210 blockquote :: Html -> Html
214 caption :: Html -> Html
215 center :: Html -> Html
218 define :: Html -> Html
219 dlist :: Html -> Html
220 dterm :: Html -> Html
221 emphasize :: Html -> Html
222 fieldset :: Html -> Html
225 frame :: Html -> Html
226 frameset :: Html -> Html
233 header :: Html -> Html
237 italics :: Html -> Html
238 keyboard :: Html -> Html
239 legend :: Html -> Html
242 noframes :: Html -> Html
243 olist :: Html -> Html
244 option :: Html -> Html
245 paragraph :: Html -> Html
248 sample :: Html -> Html
249 select :: Html -> Html
250 small :: Html -> Html
251 strong :: Html -> Html
252 style :: Html -> Html
255 table :: Html -> Html
257 textarea :: Html -> Html
260 thecode :: Html -> Html
261 thediv :: Html -> Html
262 thehtml :: Html -> Html
263 thelink :: Html -> Html
264 themap :: Html -> Html
265 thespan :: Html -> Html
266 thetitle :: Html -> Html
269 ulist :: Html -> Html
270 underline :: Html -> Html
271 variable :: Html -> Html
273 address = tag "ADDRESS"
275 applet = tag "APPLET"
277 basefont = itag "BASEFONT"
279 blockquote = tag "BLOCKQUOTE"
283 caption = tag "CAPTION"
284 center = tag "CENTER"
291 fieldset = tag "FIELDSET"
295 frameset = tag "FRAMESET"
308 legend = tag "LEGEND"
311 noframes = tag "NOFRAMES"
313 option = tag "OPTION"
318 select = tag "SELECT"
320 strong = tag "STRONG"
326 textarea = tag "TEXTAREA"
328 thebase = itag "BASE"
335 thetitle = tag "TITLE"
342 -- ---------------------------------------------------------------------------
345 -- (automatically generated)
347 action :: String -> HtmlAttr
348 align :: String -> HtmlAttr
349 alink :: String -> HtmlAttr
350 alt :: String -> HtmlAttr
351 altcode :: String -> HtmlAttr
352 archive :: String -> HtmlAttr
353 background :: String -> HtmlAttr
354 base :: String -> HtmlAttr
355 bgcolor :: String -> HtmlAttr
356 border :: Int -> HtmlAttr
357 bordercolor :: String -> HtmlAttr
358 cellpadding :: Int -> HtmlAttr
359 cellspacing :: Int -> HtmlAttr
361 clear :: String -> HtmlAttr
362 code :: String -> HtmlAttr
363 codebase :: String -> HtmlAttr
364 color :: String -> HtmlAttr
365 cols :: String -> HtmlAttr
366 colspan :: Int -> HtmlAttr
368 content :: String -> HtmlAttr
369 coords :: String -> HtmlAttr
370 enctype :: String -> HtmlAttr
371 face :: String -> HtmlAttr
372 frameborder :: Int -> HtmlAttr
373 height :: Int -> HtmlAttr
374 href :: String -> HtmlAttr
375 hspace :: Int -> HtmlAttr
376 httpequiv :: String -> HtmlAttr
377 identifier :: String -> HtmlAttr
379 lang :: String -> HtmlAttr
380 link :: String -> HtmlAttr
381 marginheight :: Int -> HtmlAttr
382 marginwidth :: Int -> HtmlAttr
383 maxlength :: Int -> HtmlAttr
384 method :: String -> HtmlAttr
386 name :: String -> HtmlAttr
391 rel :: String -> HtmlAttr
392 rev :: String -> HtmlAttr
393 rows :: String -> HtmlAttr
394 rowspan :: Int -> HtmlAttr
395 rules :: String -> HtmlAttr
396 scrolling :: String -> HtmlAttr
398 shape :: String -> HtmlAttr
399 size :: String -> HtmlAttr
400 src :: String -> HtmlAttr
401 start :: Int -> HtmlAttr
402 target :: String -> HtmlAttr
403 text :: String -> HtmlAttr
404 theclass :: String -> HtmlAttr
405 thestyle :: String -> HtmlAttr
406 thetype :: String -> HtmlAttr
407 title :: String -> HtmlAttr
408 usemap :: String -> HtmlAttr
409 valign :: String -> HtmlAttr
410 value :: String -> HtmlAttr
411 version :: String -> HtmlAttr
412 vlink :: String -> HtmlAttr
413 vspace :: Int -> HtmlAttr
414 width :: String -> HtmlAttr
416 action = strAttr "ACTION"
417 align = strAttr "ALIGN"
418 alink = strAttr "ALINK"
420 altcode = strAttr "ALTCODE"
421 archive = strAttr "ARCHIVE"
422 background = strAttr "BACKGROUND"
423 base = strAttr "BASE"
424 bgcolor = strAttr "BGCOLOR"
425 border = intAttr "BORDER"
426 bordercolor = strAttr "BORDERCOLOR"
427 cellpadding = intAttr "CELLPADDING"
428 cellspacing = intAttr "CELLSPACING"
429 checked = emptyAttr "CHECKED"
430 clear = strAttr "CLEAR"
431 code = strAttr "CODE"
432 codebase = strAttr "CODEBASE"
433 color = strAttr "COLOR"
434 cols = strAttr "COLS"
435 colspan = intAttr "COLSPAN"
436 compact = emptyAttr "COMPACT"
437 content = strAttr "CONTENT"
438 coords = strAttr "COORDS"
439 enctype = strAttr "ENCTYPE"
440 face = strAttr "FACE"
441 frameborder = intAttr "FRAMEBORDER"
442 height = intAttr "HEIGHT"
443 href = strAttr "HREF"
444 hspace = intAttr "HSPACE"
445 httpequiv = strAttr "HTTPEQUIV"
446 identifier = strAttr "ID"
447 ismap = emptyAttr "ISMAP"
448 lang = strAttr "LANG"
449 link = strAttr "LINK"
450 marginheight = intAttr "MARGINHEIGHT"
451 marginwidth = intAttr "MARGINWIDTH"
452 maxlength = intAttr "MAXLENGTH"
453 method = strAttr "METHOD"
454 multiple = emptyAttr "MULTIPLE"
455 name = strAttr "NAME"
456 nohref = emptyAttr "NOHREF"
457 noresize = emptyAttr "NORESIZE"
458 noshade = emptyAttr "NOSHADE"
459 nowrap = emptyAttr "NOWRAP"
462 rows = strAttr "ROWS"
463 rowspan = intAttr "ROWSPAN"
464 rules = strAttr "RULES"
465 scrolling = strAttr "SCROLLING"
466 selected = emptyAttr "SELECTED"
467 shape = strAttr "SHAPE"
468 size = strAttr "SIZE"
470 start = intAttr "START"
471 target = strAttr "TARGET"
472 text = strAttr "TEXT"
473 theclass = strAttr "CLASS"
474 thestyle = strAttr "STYLE"
475 thetype = strAttr "TYPE"
476 title = strAttr "TITLE"
477 usemap = strAttr "USEMAP"
478 valign = strAttr "VALIGN"
479 value = strAttr "VALUE"
480 version = strAttr "VERSION"
481 vlink = strAttr "VLINK"
482 vspace = intAttr "VSPACE"
483 width = strAttr "WIDTH"
485 -- ---------------------------------------------------------------------------
488 -- (automatically generated)
490 validHtmlTags :: [String]
551 validHtmlITags :: [String]
563 validHtmlAttrs :: [String]
634 -- ---------------------------------------------------------------------------
671 -- ---------------------------------------------------------------------------
674 linesToHtml :: [String] -> Html
676 linesToHtml [] = noHtml
677 linesToHtml (x:[]) = lineToHtml x
678 linesToHtml (x:xs) = lineToHtml x +++ br +++ linesToHtml xs
681 -- ---------------------------------------------------------------------------
682 -- Html abbriviations
684 primHtmlChar :: String -> Html
690 primHtmlChar = \ x -> primHtml ("&" ++ x ++ ";")
691 copyright = primHtmlChar "copy"
692 spaceHtml = primHtmlChar "nbsp"
693 bullet = primHtmlChar "#149"
697 -- ---------------------------------------------------------------------------
700 class HTMLTABLE ht where
701 cell :: ht -> HtmlTable
703 instance HTMLTABLE HtmlTable where
706 instance HTMLTABLE Html where
709 cellFn x y = h ! (add x colspan $ add y rowspan $ [])
711 add n fn rest = fn n : rest
716 -- We internally represent the Cell inside a Table with an
717 -- object of the type
719 -- Int -> Int -> Html
721 -- When we render it later, we find out how many columns
722 -- or rows this cell will span over, and can
723 -- include the correct colspan/rowspan command.
726 = HtmlTable (BT.BlockTable (Int -> Int -> Html))
729 (</>),above,(<->),beside :: (HTMLTABLE ht1,HTMLTABLE ht2)
730 => ht1 -> ht2 -> HtmlTable
731 aboves,besides :: (HTMLTABLE ht) => [ht] -> HtmlTable
732 simpleTable :: [HtmlAttr] -> [HtmlAttr] -> [[Html]] -> Html
735 mkHtmlTable :: BT.BlockTable (Int -> Int -> Html) -> HtmlTable
736 mkHtmlTable r = HtmlTable r
738 -- We give both infix and nonfix, take your pick.
739 -- Notice that there is no concept of a row/column
742 above a b = combine BT.above (cell a) (cell b)
744 beside a b = combine BT.beside (cell a) (cell b)
748 combine fn (HtmlTable a) (HtmlTable b) = mkHtmlTable (a `fn` b)
750 -- Both aboves and besides presume a non-empty list.
751 -- here is no concept of a empty row or column in these
752 -- table combinators.
754 aboves [] = error "aboves []"
755 aboves xs = foldr1 (</>) (map cell xs)
756 besides [] = error "besides []"
757 besides xs = foldr1 (<->) (map cell xs)
759 -- renderTable takes the HtmlTable, and renders it back into
762 renderTable :: BT.BlockTable (Int -> Int -> Html) -> Html
765 [tr << [theCell x y | (theCell,(x,y)) <- theRow ]
766 | theRow <- BT.getMatrix theTable]
768 instance HTML HtmlTable where
769 toHtml (HtmlTable tab) = renderTable tab
771 instance Show HtmlTable where
772 showsPrec _ (HtmlTable tab) = shows (renderTable tab)
775 -- If you can't be bothered with the above, then you
776 -- can build simple tables with simpleTable.
777 -- Just provide the attributes for the whole table,
778 -- attributes for the cells (same for every cell),
779 -- and a list of lists of cell contents,
780 -- and this function will build the table for you.
781 -- It does presume that all the lists are non-empty,
782 -- and there is at least one list.
784 -- Different length lists means that the last cell
785 -- gets padded. If you want more power, then
786 -- use the system above, or build tables explicitly.
788 simpleTable attr cellAttr lst
791 . map (besides . map ((td ! cellAttr) . toHtml))
795 -- ---------------------------------------------------------------------------
796 -- Tree Displaying Combinators
798 -- The basic idea is you render your structure in the form
799 -- of this tree, and then use treeHtml to turn it into a Html
800 -- object with the structure explicit.
804 | HtmlNode Html [HtmlTree] Html
806 treeHtml :: [String] -> HtmlTree -> Html
807 treeHtml colors h = table ! [
810 cellspacing 2] << treeHtml' colors h
812 manycolors = scanr (:) []
814 treeHtmls :: [[String]] -> [HtmlTree] -> HtmlTable
815 treeHtmls c ts = aboves (zipWith treeHtml' c ts)
817 treeHtml' :: [String] -> HtmlTree -> HtmlTable
818 treeHtml' (c:_) (HtmlLeaf leaf) = cell
822 treeHtml' (c:cs@(c2:_)) (HtmlNode hopen ts hclose) =
823 if null ts && isNoHtml hclose
828 hd </> bar `beside` (td ! [bgcolor c2] << spaceHtml)
831 hd </> (bar `beside` treeHtmls morecolors ts)
834 -- This stops a column of colors being the same
835 -- color as the immeduately outside nesting bar.
836 morecolors = filter ((/= c).head) (manycolors cs)
837 bar = td ! [bgcolor c,width "10"] << spaceHtml
838 hd = td ! [bgcolor c] << hopen
839 tl = td ! [bgcolor c] << hclose
840 treeHtml' _ _ = error "The imposible happens"
842 instance HTML HtmlTree where
843 toHtml x = treeHtml treeColors x
845 -- type "length treeColors" to see how many colors are here.
846 treeColors = ["#88ccff","#ffffaa","#ffaaff","#ccffff"] ++ treeColors
849 -- ---------------------------------------------------------------------------
850 -- Html Debugging Combinators
852 -- This uses the above tree rendering function, and displays the
853 -- Html as a tree structure, allowing debugging of what is
854 -- actually getting produced.
856 debugHtml :: (HTML a) => a -> Html
857 debugHtml obj = table ! [border 0] <<
858 ( th ! [bgcolor "#008888"]
860 << "Debugging Output"
861 </> td << (toHtml (debug' (toHtml obj)))
865 debug' :: Html -> [HtmlTree]
866 debug' (Html markups) = map debug markups
868 debug :: HtmlElement -> HtmlTree
869 debug (HtmlString str) = HtmlLeaf (spaceHtml +++
870 linesToHtml (lines str))
872 markupTag = markupTag,
873 markupContent = markupContent,
874 markupAttrs = markupAttrs
876 case markupContent of
877 Html [] -> HtmlNode hd [] noHtml
878 Html xs -> HtmlNode hd (map debug xs) tl
880 args = if null markupAttrs
882 else " " ++ unwords (map show markupAttrs)
883 hd = font ! [size "1"] << ("<" ++ markupTag ++ args ++ ">")
884 tl = font ! [size "1"] << ("</" ++ markupTag ++ ">")
886 -- ---------------------------------------------------------------------------
889 data HotLink = HotLink {
891 hotLinkContents :: [Html],
892 hotLinkAttributes :: [HtmlAttr]
895 instance HTML HotLink where
896 toHtml hl = anchor ! (href (hotLinkURL hl) : hotLinkAttributes hl)
897 << hotLinkContents hl
899 hotlink :: URL -> [Html] -> HotLink
900 hotlink url h = HotLink {
903 hotLinkAttributes = [] }
906 -- ---------------------------------------------------------------------------
909 -- (Abridged from Erik Meijer's Original Html library)
911 ordList :: (HTML a) => [a] -> Html
912 ordList items = olist << map (li <<) items
914 unordList :: (HTML a) => [a] -> Html
915 unordList items = ulist << map (li <<) items
917 defList :: (HTML a,HTML b) => [(a,b)] -> Html
919 = dlist << [ [ dterm << bold << dt, ddef << dd ] | (dt,dd) <- items ]
922 widget :: String -> String -> [HtmlAttr] -> Html
923 widget w n markupAttrs = input ! ([thetype w,name n] ++ markupAttrs)
925 checkbox :: String -> String -> Html
926 hidden :: String -> String -> Html
927 radio :: String -> String -> Html
928 reset :: String -> String -> Html
929 submit :: String -> String -> Html
930 password :: String -> Html
931 textfield :: String -> Html
932 afile :: String -> Html
933 clickmap :: String -> Html
935 checkbox n v = widget "CHECKBOX" n [value v]
936 hidden n v = widget "HIDDEN" n [value v]
937 radio n v = widget "RADIO" n [value v]
938 reset n v = widget "RESET" n [value v]
939 submit n v = widget "SUBMIT" n [value v]
940 password n = widget "PASSWORD" n []
941 textfield n = widget "TEXT" n []
942 afile n = widget "FILE" n []
943 clickmap n = widget "IMAGE" n []
945 menu :: String -> [Html] -> Html
947 = select ! [name n] << [ option << p << choice | choice <- choices ]
949 gui :: String -> Html -> Html
950 gui act = form ! [action act,method "POST"]
952 -- ---------------------------------------------------------------------------
955 -- Uses the append trick to optimize appending.
956 -- The output is quite messy, because space matters in
957 -- HTML, so we must not generate needless spaces.
959 renderHtml :: (HTML html) => html -> String
962 foldr (.) id (map (renderHtml' 0)
963 (getHtmlElements (tag "HTML" << theHtml))) "\n"
966 "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 FINAL//EN\">\n" ++
967 "<!--Rendered using the Haskell Html Library v0.2-->\n"
969 -- Warning: spaces matters in HTML. You are better using renderHtml.
970 -- This is intentually very inefficent to "encorage" this,
971 -- but the neater version in easier when debugging.
974 prettyHtml :: (HTML html) => html -> String
982 renderHtml' :: Int -> HtmlElement -> ShowS
983 renderHtml' _ (HtmlString str) = (++) str
984 renderHtml' n (HtmlTag
986 markupContent = html,
987 markupAttrs = markupAttrs })
988 = if isNoHtml html && elem name validHtmlITags
989 then renderTag True name markupAttrs n
990 else (renderTag True name markupAttrs n
991 . foldr (.) id (map (renderHtml' (n+2)) (getHtmlElements html))
992 . renderTag False name [] n)
994 prettyHtml' :: HtmlElement -> [String]
995 prettyHtml' (HtmlString str) = [str]
998 markupContent = html,
999 markupAttrs = markupAttrs })
1000 = if isNoHtml html && elem name validHtmlITags
1002 [rmNL (renderTag True name markupAttrs 0 "")]
1004 [rmNL (renderTag True name markupAttrs 0 "")] ++
1005 shift (concat (map prettyHtml' (getHtmlElements html))) ++
1006 [rmNL (renderTag False name [] 0 "")]
1008 shift = map (\x -> " " ++ x)
1009 rmNL = filter (/= '\n')
1011 -- This prints the Tags The lack of spaces in intentunal, because Html is
1012 -- actually space dependant.
1014 renderTag :: Bool -> String -> [HtmlAttr] -> Int -> ShowS
1015 renderTag x name markupAttrs n r
1016 = open ++ name ++ rest markupAttrs ++ ">" ++ r
1018 open = if x then "<" else "</"
1020 nl = "\n" ++ replicate (n `div` 8) '\t'
1021 ++ replicate (n `mod` 8) ' '
1024 rest attr = " " ++ unwords (map showPair attr) ++ nl
1026 showPair :: HtmlAttr -> String
1027 showPair (HtmlAttr tag val)
1028 = tag ++ " = \"" ++ val ++ "\""