Text/Html.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Text.Html
   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)
   7 --
   8 -- Maintainer  :  Andy Gill <andy@galconn.com>
   9 -- Stability   :  experimental
  10 -- Portability :  portable
  11 --
  12 -- $Id: Html.hs,v 1.2 2002/04/24 16:31:46 simonmar Exp $
  13 --
  14 -- An Html combinator library
  15 --
  16 -----------------------------------------------------------------------------
  17
  18 module Text.Html (
  19       module Text.Html,
  20       ) where
  21
  22 import Prelude
  23
  24 import qualified Text.Html.BlockTable as BT
  25
  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
  31
  32
  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 &gt;,etc.
  36
  37 data HtmlElement
  38 {-
  39  -    ..just..plain..normal..text... but using &copy; and &amb;, etc.
  40  -}
  41       = HtmlString String
  42 {-
  43  -    <thetag {..attrs..}> ..content.. </thetag>
  44  -}
  45       | HtmlTag {                   -- tag with internal markup
  46               markupTag      :: String,
  47               markupAttrs    :: [HtmlAttr],
  48               markupContent  :: Html
  49               }
  50
  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).
  54  -}
  55
  56
  57 data HtmlAttr = HtmlAttr String String
  58
  59
  60 newtype Html = Html { getHtmlElements :: [HtmlElement] }
  61
  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.
  65
  66 class HTML a where
  67       toHtml     :: a -> Html
  68       toHtmlFromList :: [a] -> Html
  69
  70       toHtmlFromList xs = Html (concat [ x | (Html x) <- map toHtml xs])
  71
  72 instance HTML Html where
  73       toHtml a    = a
  74
  75 instance HTML Char where
  76       toHtml       a = toHtml [a]
  77       toHtmlFromList []  = Html []
  78       toHtmlFromList str = Html [HtmlString (stringToHtmlString str)]
  79
  80 instance (HTML a) => HTML [a] where
  81       toHtml xs = toHtmlFromList xs
  82
  83 class ADDATTRS a where
  84       (!) :: a -> [HtmlAttr] -> a
  85
  86 instance (ADDATTRS b) => ADDATTRS (a -> b) where
  87       fn ! attr = \ arg -> fn arg ! attr
  88
  89 instance ADDATTRS Html where
  90       (Html htmls) ! attr = Html (map addAttrs htmls)
  91         where
  92               addAttrs (html@(HtmlTag { markupAttrs = markupAttrs }) )
  93                               = html { markupAttrs = markupAttrs ++ attr }
  94               addAttrs html = html
  95
  96
  97 (<<)            :: (HTML a) => (Html -> b) -> a        -> b
  98 fn << arg = fn (toHtml arg)
  99
 100
 101 concatHtml :: (HTML a) => [a] -> Html
 102 concatHtml as = Html (concat (map (getHtmlElements.toHtml) as))
 103
 104 (+++) :: (HTML a,HTML b) => a -> b -> Html
 105 a +++ b = Html (getHtmlElements (toHtml a) ++ getHtmlElements (toHtml b))
 106
 107 noHtml :: Html
 108 noHtml = Html []
 109
 110
 111 isNoHtml (Html xs) = null xs
 112
 113
 114 tag  :: String -> Html -> Html
 115 tag str       htmls = Html [
 116       HtmlTag {
 117               markupTag = str,
 118               markupAttrs = [],
 119               markupContent = htmls }]
 120
 121 itag :: String -> Html
 122 itag str = tag str noHtml
 123
 124 emptyAttr :: String -> HtmlAttr
 125 emptyAttr s = HtmlAttr s ""
 126
 127 intAttr :: String -> Int -> HtmlAttr
 128 intAttr s i = HtmlAttr s (show i)
 129
 130 strAttr :: String -> String -> HtmlAttr
 131 strAttr s t = HtmlAttr s t
 132
 133
 134 {-
 135 foldHtml :: (String -> [HtmlAttr] -> [a] -> a)
 136       -> (String -> a)
 137       -> Html
 138       -> a
 139 foldHtml f g (HtmlTag str attr fmls)
 140       = f str attr (map (foldHtml f g) fmls)
 141 foldHtml f g (HtmlString  str)
 142       = g str
 143
 144 -}
 145 -- Processing Strings into Html friendly things.
 146 -- This converts a String to a Html String.
 147 stringToHtmlString :: String -> String
 148 stringToHtmlString = concatMap fixChar
 149     where
 150       fixChar '<' = "&lt;"
 151       fixChar '>' = "&gt;"
 152       fixChar '&' = "&amp;"
 153       fixChar '"' = "&quot;"
 154       fixChar c   = [c]
 155
 156 -- ---------------------------------------------------------------------------
 157 -- Classes
 158
 159 instance Show Html where
 160       showsPrec _ html = showString (prettyHtml html)
 161       showList htmls   = showString (concat (map show htmls))
 162
 163 instance Show HtmlAttr where
 164       showsPrec _ (HtmlAttr str val) =
 165               showString str .
 166               showString "=" .
 167               shows val
 168
 169
 170 -- ---------------------------------------------------------------------------
 171 -- Data types
 172
 173 type URL = String
 174
 175 -- ---------------------------------------------------------------------------
 176 -- Basic primitives
 177
 178 -- This is not processed for special chars.
 179 -- use stringToHtml or lineToHtml instead, for user strings,
 180 -- because they  understand special chars, like '<'.
 181
 182 primHtml      :: String                                -> Html
 183 primHtml x    = Html [HtmlString x]
 184
 185 -- ---------------------------------------------------------------------------
 186 -- Basic Combinators
 187
 188 stringToHtml          :: String                       -> Html
 189 stringToHtml = primHtml . stringToHtmlString
 190
 191 -- This converts a string, but keeps spaces as non-line-breakable
 192
 193 lineToHtml            :: String                       -> Html
 194 lineToHtml = primHtml . concatMap htmlizeChar2 . stringToHtmlString
 195    where
 196       htmlizeChar2 ' ' = "&nbsp;"
 197       htmlizeChar2 c   = [c]
 198
 199 -- ---------------------------------------------------------------------------
 200 -- Html Constructors
 201
 202 -- (automatically generated)
 203
 204 address             :: Html -> Html
 205 anchor              :: Html -> Html
 206 applet              :: Html -> Html
 207 area                ::         Html
 208 basefont            ::         Html
 209 big                 :: Html -> Html
 210 blockquote          :: Html -> Html
 211 body                :: Html -> Html
 212 bold                :: Html -> Html
 213 br                  ::         Html
 214 caption             :: Html -> Html
 215 center              :: Html -> Html
 216 cite                :: Html -> Html
 217 ddef                :: Html -> Html
 218 define              :: Html -> Html
 219 dlist               :: Html -> Html
 220 dterm               :: Html -> Html
 221 emphasize           :: Html -> Html
 222 fieldset            :: Html -> Html
 223 font                :: Html -> Html
 224 form                :: Html -> Html
 225 frame               :: Html -> Html
 226 frameset            :: Html -> Html
 227 h1                  :: Html -> Html
 228 h2                  :: Html -> Html
 229 h3                  :: Html -> Html
 230 h4                  :: Html -> Html
 231 h5                  :: Html -> Html
 232 h6                  :: Html -> Html
 233 header              :: Html -> Html
 234 hr                  ::         Html
 235 image               ::         Html
 236 input               ::         Html
 237 italics             :: Html -> Html
 238 keyboard            :: Html -> Html
 239 legend              :: Html -> Html
 240 li                  :: Html -> Html
 241 meta                ::         Html
 242 noframes            :: Html -> Html
 243 olist               :: Html -> Html
 244 option              :: Html -> Html
 245 paragraph           :: Html -> Html
 246 param               ::         Html
 247 pre                 :: Html -> Html
 248 sample              :: Html -> Html
 249 select              :: Html -> Html
 250 small               :: Html -> Html
 251 strong              :: Html -> Html
 252 style               :: Html -> Html
 253 sub                 :: Html -> Html
 254 sup                 :: Html -> Html
 255 table               :: Html -> Html
 256 td                  :: Html -> Html
 257 textarea            :: Html -> Html
 258 th                  :: Html -> Html
 259 thebase             ::         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
 267 tr                  :: Html -> Html
 268 tt                  :: Html -> Html
 269 ulist               :: Html -> Html
 270 underline           :: Html -> Html
 271 variable            :: Html -> Html
 272
 273 address             =  tag "ADDRESS"
 274 anchor              =  tag "A"
 275 applet              =  tag "APPLET"
 276 area                = itag "AREA"
 277 basefont            = itag "BASEFONT"
 278 big                 =  tag "BIG"
 279 blockquote          =  tag "BLOCKQUOTE"
 280 body                =  tag "BODY"
 281 bold                =  tag "B"
 282 br                  = itag "BR"
 283 caption             =  tag "CAPTION"
 284 center              =  tag "CENTER"
 285 cite                =  tag "CITE"
 286 ddef                =  tag "DD"
 287 define              =  tag "DFN"
 288 dlist               =  tag "DL"
 289 dterm               =  tag "DT"
 290 emphasize           =  tag "EM"
 291 fieldset            =  tag "FIELDSET"
 292 font                =  tag "FONT"
 293 form                =  tag "FORM"
 294 frame               =  tag "FRAME"
 295 frameset            =  tag "FRAMESET"
 296 h1                  =  tag "H1"
 297 h2                  =  tag "H2"
 298 h3                  =  tag "H3"
 299 h4                  =  tag "H4"
 300 h5                  =  tag "H5"
 301 h6                  =  tag "H6"
 302 header              =  tag "HEAD"
 303 hr                  = itag "HR"
 304 image               = itag "IMG"
 305 input               = itag "INPUT"
 306 italics             =  tag "I"
 307 keyboard            =  tag "KBD"
 308 legend              =  tag "LEGEND"
 309 li                  =  tag "LI"
 310 meta                = itag "META"
 311 noframes            =  tag "NOFRAMES"
 312 olist               =  tag "OL"
 313 option              =  tag "OPTION"
 314 paragraph           =  tag "P"
 315 param               = itag "PARAM"
 316 pre                 =  tag "PRE"
 317 sample              =  tag "SAMP"
 318 select              =  tag "SELECT"
 319 small               =  tag "SMALL"
 320 strong              =  tag "STRONG"
 321 style               =  tag "STYLE"
 322 sub                 =  tag "SUB"
 323 sup                 =  tag "SUP"
 324 table               =  tag "TABLE"
 325 td                  =  tag "TD"
 326 textarea            =  tag "TEXTAREA"
 327 th                  =  tag "TH"
 328 thebase             = itag "BASE"
 329 thecode             =  tag "CODE"
 330 thediv              =  tag "DIV"
 331 thehtml             =  tag "HTML"
 332 thelink             =  tag "LINK"
 333 themap              =  tag "MAP"
 334 thespan             =  tag "SPAN"
 335 thetitle            =  tag "TITLE"
 336 tr                  =  tag "TR"
 337 tt                  =  tag "TT"
 338 ulist               =  tag "UL"
 339 underline           =  tag "U"
 340 variable            =  tag "VAR"
 341
 342 -- ---------------------------------------------------------------------------
 343 -- Html Attributes
 344
 345 -- (automatically generated)
 346
 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
 360 checked             ::           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
 367 compact             ::           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
 378 ismap               ::           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
 385 multiple            ::           HtmlAttr
 386 name                :: String -> HtmlAttr
 387 nohref              ::           HtmlAttr
 388 noresize            ::           HtmlAttr
 389 noshade             ::           HtmlAttr
 390 nowrap              ::           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
 397 selected            ::           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
 415
 416 action              =   strAttr "ACTION"
 417 align               =   strAttr "ALIGN"
 418 alink               =   strAttr "ALINK"
 419 alt                 =   strAttr "ALT"
 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"
 460 rel                 =   strAttr "REL"
 461 rev                 =   strAttr "REV"
 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"
 469 src                 =   strAttr "SRC"
 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"
 484
 485 -- ---------------------------------------------------------------------------
 486 -- Html Constructors
 487
 488 -- (automatically generated)
 489
 490 validHtmlTags :: [String]
 491 validHtmlTags = [
 492       "ADDRESS",
 493       "A",
 494       "APPLET",
 495       "BIG",
 496       "BLOCKQUOTE",
 497       "BODY",
 498       "B",
 499       "CAPTION",
 500       "CENTER",
 501       "CITE",
 502       "DD",
 503       "DFN",
 504       "DL",
 505       "DT",
 506       "EM",
 507       "FIELDSET",
 508       "FONT",
 509       "FORM",
 510       "FRAME",
 511       "FRAMESET",
 512       "H1",
 513       "H2",
 514       "H3",
 515       "H4",
 516       "H5",
 517       "H6",
 518       "HEAD",
 519       "I",
 520       "KBD",
 521       "LEGEND",
 522       "LI",
 523       "NOFRAMES",
 524       "OL",
 525       "OPTION",
 526       "P",
 527       "PRE",
 528       "SAMP",
 529       "SELECT",
 530       "SMALL",
 531       "STRONG",
 532       "STYLE",
 533       "SUB",
 534       "SUP",
 535       "TABLE",
 536       "TD",
 537       "TEXTAREA",
 538       "TH",
 539       "CODE",
 540       "DIV",
 541       "HTML",
 542       "LINK",
 543       "MAP",
 544       "TITLE",
 545       "TR",
 546       "TT",
 547       "UL",
 548       "U",
 549       "VAR"]
 550
 551 validHtmlITags :: [String]
 552 validHtmlITags = [
 553       "AREA",
 554       "BASEFONT",
 555       "BR",
 556       "HR",
 557       "IMG",
 558       "INPUT",
 559       "META",
 560       "PARAM",
 561       "BASE"]
 562
 563 validHtmlAttrs :: [String]
 564 validHtmlAttrs = [
 565       "ACTION",
 566       "ALIGN",
 567       "ALINK",
 568       "ALT",
 569       "ALTCODE",
 570       "ARCHIVE",
 571       "BACKGROUND",
 572       "BASE",
 573       "BGCOLOR",
 574       "BORDER",
 575       "BORDERCOLOR",
 576       "CELLPADDING",
 577       "CELLSPACING",
 578       "CHECKED",
 579       "CLEAR",
 580       "CODE",
 581       "CODEBASE",
 582       "COLOR",
 583       "COLS",
 584       "COLSPAN",
 585       "COMPACT",
 586       "CONTENT",
 587       "COORDS",
 588       "ENCTYPE",
 589       "FACE",
 590       "FRAMEBORDER",
 591       "HEIGHT",
 592       "HREF",
 593       "HSPACE",
 594       "HTTPEQUIV",
 595       "ID",
 596       "ISMAP",
 597       "LANG",
 598       "LINK",
 599       "MARGINHEIGHT",
 600       "MARGINWIDTH",
 601       "MAXLENGTH",
 602       "METHOD",
 603       "MULTIPLE",
 604       "NAME",
 605       "NOHREF",
 606       "NORESIZE",
 607       "NOSHADE",
 608       "NOWRAP",
 609       "REL",
 610       "REV",
 611       "ROWS",
 612       "ROWSPAN",
 613       "RULES",
 614       "SCROLLING",
 615       "SELECTED",
 616       "SHAPE",
 617       "SIZE",
 618       "SRC",
 619       "START",
 620       "TARGET",
 621       "TEXT",
 622       "CLASS",
 623       "STYLE",
 624       "TYPE",
 625       "TITLE",
 626       "USEMAP",
 627       "VALIGN",
 628       "VALUE",
 629       "VERSION",
 630       "VLINK",
 631       "VSPACE",
 632       "WIDTH"]
 633
 634 -- ---------------------------------------------------------------------------
 635 -- Html colors
 636
 637 aqua          :: String
 638 black         :: String
 639 blue          :: String
 640 fuchsia       :: String
 641 gray          :: String
 642 green         :: String
 643 lime          :: String
 644 maroon        :: String
 645 navy          :: String
 646 olive         :: String
 647 purple        :: String
 648 red           :: String
 649 silver        :: String
 650 teal          :: String
 651 yellow        :: String
 652 white         :: String
 653
 654 aqua          = "aqua"
 655 black         = "black"
 656 blue          = "blue"
 657 fuchsia       = "fuchsia"
 658 gray          = "gray"
 659 green         = "green"
 660 lime          = "lime"
 661 maroon        = "maroon"
 662 navy          = "navy"
 663 olive         = "olive"
 664 purple        = "purple"
 665 red           = "red"
 666 silver        = "silver"
 667 teal          = "teal"
 668 yellow        = "yellow"
 669 white         = "white"
 670
 671 -- ---------------------------------------------------------------------------
 672 -- Basic Combinators
 673
 674 linesToHtml :: [String]       -> Html
 675
 676 linesToHtml []     = noHtml
 677 linesToHtml (x:[]) = lineToHtml x
 678 linesToHtml (x:xs) = lineToHtml x +++ br +++ linesToHtml xs
 679
 680
 681 -- ---------------------------------------------------------------------------
 682 -- Html abbriviations
 683
 684 primHtmlChar  :: String -> Html
 685 copyright     :: Html
 686 spaceHtml     :: Html
 687 bullet        :: Html
 688 p             :: Html -> Html
 689
 690 primHtmlChar  = \ x -> primHtml ("&" ++ x ++ ";")
 691 copyright     = primHtmlChar "copy"
 692 spaceHtml     = primHtmlChar "nbsp"
 693 bullet        = primHtmlChar "#149"
 694
 695 p             = paragraph
 696
 697 -- ---------------------------------------------------------------------------
 698 -- Html tables
 699
 700 class HTMLTABLE ht where
 701       cell :: ht -> HtmlTable
 702
 703 instance HTMLTABLE HtmlTable where
 704       cell = id
 705
 706 instance HTMLTABLE Html where
 707       cell h =
 708          let
 709               cellFn x y = h ! (add x colspan $ add y rowspan $ [])
 710               add 1 fn rest = rest
 711               add n fn rest = fn n : rest
 712               r = BT.single cellFn
 713          in
 714               mkHtmlTable r
 715
 716 -- We internally represent the Cell inside a Table with an
 717 -- object of the type
 718 -- \pre{
 719 --         Int -> Int -> Html
 720 -- }
 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.
 724
 725 newtype HtmlTable
 726       = HtmlTable (BT.BlockTable (Int -> Int -> Html))
 727
 728
 729 (</>),above,(<->),beside :: (HTMLTABLE ht1,HTMLTABLE ht2)
 730                        => ht1 -> ht2 -> HtmlTable
 731 aboves,besides                 :: (HTMLTABLE ht) => [ht] -> HtmlTable
 732 simpleTable            :: [HtmlAttr] -> [HtmlAttr] -> [[Html]] -> Html
 733
 734
 735 mkHtmlTable :: BT.BlockTable (Int -> Int -> Html) -> HtmlTable
 736 mkHtmlTable r = HtmlTable r
 737
 738 -- We give both infix and nonfix, take your pick.
 739 -- Notice that there is no concept of a row/column
 740 -- of zero items.
 741
 742 above   a b = combine BT.above (cell a) (cell b)
 743 (</>)         = above
 744 beside  a b = combine BT.beside (cell a) (cell b)
 745 (<->) = beside
 746
 747
 748 combine fn (HtmlTable a) (HtmlTable b) = mkHtmlTable (a `fn` b)
 749
 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.
 753
 754 aboves []  = error "aboves []"
 755 aboves xs  = foldr1 (</>) (map cell xs)
 756 besides [] = error "besides []"
 757 besides xs = foldr1 (<->) (map cell xs)
 758
 759 -- renderTable takes the HtmlTable, and renders it back into
 760 -- and Html object.
 761
 762 renderTable :: BT.BlockTable (Int -> Int -> Html) -> Html
 763 renderTable theTable
 764       = concatHtml
 765           [tr << [theCell x y | (theCell,(x,y)) <- theRow ]
 766                       | theRow <- BT.getMatrix theTable]
 767
 768 instance HTML HtmlTable where
 769       toHtml (HtmlTable tab) = renderTable tab
 770
 771 instance Show HtmlTable where
 772       showsPrec _ (HtmlTable tab) = shows (renderTable tab)
 773
 774
 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.
 783 --
 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.
 787
 788 simpleTable attr cellAttr lst
 789       = table ! attr
 790           <<  (aboves
 791               . map (besides . map ((td ! cellAttr) . toHtml))
 792               ) lst
 793
 794
 795 -- ---------------------------------------------------------------------------
 796 -- Tree Displaying Combinators
 797
 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.
 801
 802 data HtmlTree
 803       = HtmlLeaf Html
 804       | HtmlNode Html [HtmlTree] Html
 805
 806 treeHtml :: [String] -> HtmlTree -> Html
 807 treeHtml colors h = table ! [
 808                     border 0,
 809                     cellpadding 0,
 810                     cellspacing 2] << treeHtml' colors h
 811      where
 812       manycolors = scanr (:) []
 813
 814       treeHtmls :: [[String]] -> [HtmlTree] -> HtmlTable
 815       treeHtmls c ts = aboves (zipWith treeHtml' c ts)
 816
 817       treeHtml' :: [String] -> HtmlTree -> HtmlTable
 818       treeHtml' (c:_) (HtmlLeaf leaf) = cell
 819                                          (td ! [width "100%"]
 820                                             << bold
 821                                                << leaf)
 822       treeHtml' (c:cs@(c2:_)) (HtmlNode hopen ts hclose) =
 823           if null ts && isNoHtml hclose
 824           then
 825               cell hd
 826           else if null ts
 827           then
 828               hd </> bar `beside` (td ! [bgcolor c2] << spaceHtml)
 829                  </> tl
 830           else
 831               hd </> (bar `beside` treeHtmls morecolors ts)
 832                  </> tl
 833         where
 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"
 841
 842 instance HTML HtmlTree where
 843       toHtml x = treeHtml treeColors x
 844
 845 -- type "length treeColors" to see how many colors are here.
 846 treeColors = ["#88ccff","#ffffaa","#ffaaff","#ccffff"] ++ treeColors
 847
 848
 849 -- ---------------------------------------------------------------------------
 850 -- Html Debugging Combinators
 851
 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.
 855
 856 debugHtml :: (HTML a) => a -> Html
 857 debugHtml obj = table ! [border 0] <<
 858                   ( th ! [bgcolor "#008888"]
 859                      << underline
 860                        << "Debugging Output"
 861                </>  td << (toHtml (debug' (toHtml obj)))
 862               )
 863   where
 864
 865       debug' :: Html -> [HtmlTree]
 866       debug' (Html markups) = map debug markups
 867
 868       debug :: HtmlElement -> HtmlTree
 869       debug (HtmlString str) = HtmlLeaf (spaceHtml +++
 870                                               linesToHtml (lines str))
 871       debug (HtmlTag {
 872               markupTag = markupTag,
 873               markupContent = markupContent,
 874               markupAttrs  = markupAttrs
 875               }) =
 876               case markupContent of
 877                 Html [] -> HtmlNode hd [] noHtml
 878                 Html xs -> HtmlNode hd (map debug xs) tl
 879         where
 880               args = if null markupAttrs
 881                      then ""
 882                      else "  " ++ unwords (map show markupAttrs)
 883               hd = font ! [size "1"] << ("<" ++ markupTag ++ args ++ ">")
 884               tl = font ! [size "1"] << ("</" ++ markupTag ++ ">")
 885
 886 -- ---------------------------------------------------------------------------
 887 -- Hotlink datatype
 888
 889 data HotLink = HotLink {
 890       hotLinkURL        :: URL,
 891       hotLinkContents   :: [Html],
 892       hotLinkAttributes :: [HtmlAttr]
 893       } deriving Show
 894
 895 instance HTML HotLink where
 896       toHtml hl = anchor ! (href (hotLinkURL hl) : hotLinkAttributes hl)
 897                       << hotLinkContents hl
 898
 899 hotlink :: URL -> [Html] -> HotLink
 900 hotlink url h = HotLink {
 901       hotLinkURL = url,
 902       hotLinkContents = h,
 903       hotLinkAttributes = [] }
 904
 905
 906 -- ---------------------------------------------------------------------------
 907 -- More Combinators
 908
 909 -- (Abridged from Erik Meijer's Original Html library)
 910
 911 ordList   :: (HTML a) => [a] -> Html
 912 ordList items = olist << map (li <<) items
 913
 914 unordList :: (HTML a) => [a] -> Html
 915 unordList items = ulist << map (li <<) items
 916
 917 defList   :: (HTML a,HTML b) => [(a,b)] -> Html
 918 defList items
 919  = dlist << [ [ dterm << bold << dt, ddef << dd ] | (dt,dd) <- items ]
 920
 921
 922 widget :: String -> String -> [HtmlAttr] -> Html
 923 widget w n markupAttrs = input ! ([thetype w,name n] ++ markupAttrs)
 924
 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
 934
 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 []
 944
 945 menu :: String -> [Html] -> Html
 946 menu n choices
 947    = select ! [name n] << [ option << p << choice | choice <- choices ]
 948
 949 gui :: String -> Html -> Html
 950 gui act = form ! [action act,method "POST"]
 951
 952 -- ---------------------------------------------------------------------------
 953 -- Html Rendering
 954
 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.
 958
 959 renderHtml :: (HTML html) => html -> String
 960 renderHtml theHtml =
 961       renderMessage ++
 962          foldr (.) id (map (renderHtml' 0)
 963                            (getHtmlElements (tag "HTML" << theHtml))) "\n"
 964
 965 renderMessage =
 966       "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 FINAL//EN\">\n" ++
 967       "<!--Rendered using the Haskell Html Library v0.2-->\n"
 968
 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.
 972
 973 -- Local Utilities
 974 prettyHtml :: (HTML html) => html -> String
 975 prettyHtml theHtml =
 976         unlines
 977       $ concat
 978       $ map prettyHtml'
 979       $ getHtmlElements
 980       $ toHtml theHtml
 981
 982 renderHtml' :: Int -> HtmlElement -> ShowS
 983 renderHtml' _ (HtmlString str) = (++) str
 984 renderHtml' n (HtmlTag
 985               { markupTag = name,
 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)
 993
 994 prettyHtml' :: HtmlElement -> [String]
 995 prettyHtml' (HtmlString str) = [str]
 996 prettyHtml' (HtmlTag
 997               { markupTag = name,
 998                 markupContent = html,
 999                 markupAttrs = markupAttrs })
1000       = if isNoHtml html && elem name validHtmlITags
1001         then
1002          [rmNL (renderTag True name markupAttrs 0 "")]
1003         else
1004          [rmNL (renderTag True name markupAttrs 0 "")] ++
1005           shift (concat (map prettyHtml' (getHtmlElements html))) ++
1006          [rmNL (renderTag False name [] 0 "")]
1007   where
1008       shift = map (\x -> "   " ++ x)
1009 rmNL = filter (/= '\n')
1010
1011 -- This prints the Tags The lack of spaces in intentunal, because Html is
1012 -- actually space dependant.
1013
1014 renderTag :: Bool -> String -> [HtmlAttr] -> Int -> ShowS
1015 renderTag x name markupAttrs n r
1016       = open ++ name ++ rest markupAttrs ++ ">" ++ r
1017   where
1018       open = if x then "<" else "</"
1019
1020       nl = "\n" ++ replicate (n `div` 8) '\t'
1021                 ++ replicate (n `mod` 8) ' '
1022
1023       rest []   = nl
1024       rest attr = " " ++ unwords (map showPair attr) ++ nl
1025
1026       showPair :: HtmlAttr -> String
1027       showPair (HtmlAttr tag val)
1028               = tag ++ " = \"" ++ val  ++ "\""
1029