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 >,etc. 31 32data HtmlElement 33{- 34 - ..just..plain..normal..text... but using © 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 '<' = "<" 146 fixChar '>' = ">" 147 fixChar '&' = "&" 148 fixChar '"' = """ 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 ' ' = " " 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