Text/Html.hs

   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   :  experimental
   9 -- Portability :  portable
  10 --
  11 -- An Html combinator library
  12 --
  13 -----------------------------------------------------------------------------
  14
  15 module Text.Html (
  16       module Text.Html,
  17       ) where
  18
  19 import Prelude
  20
  21 import qualified Text.Html.BlockTable as BT
  22
  23 infixr 3 </>  -- combining table cells
  24 infixr 4 <->  -- combining table cells
  25 infixr 2 +++  -- combining Html
  26 infixr 7 <<   -- nesting Html
  27 infixl 8 !    -- adding optional arguments
  28
  29
  30 -- A important property of Html is that all strings inside the
  31 -- structure are already in Html friendly format.
  32 -- For example, use of &gt;,etc.
  33
  34 data HtmlElement
  35 {-
  36  -    ..just..plain..normal..text... but using &copy; and &amb;, etc.
  37  -}
  38       = HtmlString String
  39 {-
  40  -    <thetag {..attrs..}> ..content.. </thetag>
  41  -}
  42       | HtmlTag {                   -- tag with internal markup
  43               markupTag      :: String,
  44               markupAttrs    :: [HtmlAttr],
  45               markupContent  :: Html
  46               }
  47
  48 {- These are the index-value pairs.
  49  - The empty string is a synonym for tags with no arguments.
  50  - (not strictly HTML, but anyway).
  51  -}
  52
  53
  54 data HtmlAttr = HtmlAttr String String
  55
  56
  57 newtype Html = Html { getHtmlElements :: [HtmlElement] }
  58
  59 -- Read MARKUP as the class of things that can be validly rendered
  60 -- inside MARKUP tag brackets. So this can be one or more Html's,
  61 -- or a String, for example.
  62
  63 class HTML a where
  64       toHtml     :: a -> Html
  65       toHtmlFromList :: [a] -> Html
  66
  67       toHtmlFromList xs = Html (concat [ x | (Html x) <- map toHtml xs])
  68
  69 instance HTML Html where
  70       toHtml a    = a
  71
  72 instance HTML Char where
  73       toHtml       a = toHtml [a]
  74       toHtmlFromList []  = Html []
  75       toHtmlFromList str = Html [HtmlString (stringToHtmlString str)]
  76
  77 instance (HTML a) => HTML [a] where
  78       toHtml xs = toHtmlFromList xs
  79
  80 class ADDATTRS a where
  81       (!) :: a -> [HtmlAttr] -> a
  82
  83 instance (ADDATTRS b) => ADDATTRS (a -> b) where
  84       fn ! attr = \ arg -> fn arg ! attr
  85
  86 instance ADDATTRS Html where
  87       (Html htmls) ! attr = Html (map addAttrs htmls)
  88         where
  89               addAttrs (html@(HtmlTag { markupAttrs = markupAttrs }) )
  90                               = html { markupAttrs = markupAttrs ++ attr }
  91               addAttrs html = html
  92
  93
  94 (<<)            :: (HTML a) => (Html -> b) -> a        -> b
  95 fn << arg = fn (toHtml arg)
  96
  97
  98 concatHtml :: (HTML a) => [a] -> Html
  99 concatHtml as = Html (concat (map (getHtmlElements.toHtml) as))
 100
 101 (+++) :: (HTML a,HTML b) => a -> b -> Html
 102 a +++ b = Html (getHtmlElements (toHtml a) ++ getHtmlElements (toHtml b))
 103
 104 noHtml :: Html
 105 noHtml = Html []
 106
 107
 108 isNoHtml (Html xs) = null xs
 109
 110
 111 tag  :: String -> Html -> Html
 112 tag str       htmls = Html [
 113       HtmlTag {
 114               markupTag = str,
 115               markupAttrs = [],
 116               markupContent = htmls }]
 117
 118 itag :: String -> Html
 119 itag str = tag str noHtml
 120
 121 emptyAttr :: String -> HtmlAttr
 122 emptyAttr s = HtmlAttr s ""
 123
 124 intAttr :: String -> Int -> HtmlAttr
 125 intAttr s i = HtmlAttr s (show i)
 126
 127 strAttr :: String -> String -> HtmlAttr
 128 strAttr s t = HtmlAttr s t
 129
 130
 131 {-
 132 foldHtml :: (String -> [HtmlAttr] -> [a] -> a)
 133       -> (String -> a)
 134       -> Html
 135       -> a
 136 foldHtml f g (HtmlTag str attr fmls)
 137       = f str attr (map (foldHtml f g) fmls)
 138 foldHtml f g (HtmlString  str)
 139       = g str
 140
 141 -}
 142 -- Processing Strings into Html friendly things.
 143 -- This converts a String to a Html String.
 144 stringToHtmlString :: String -> String
 145 stringToHtmlString = concatMap fixChar
 146     where
 147       fixChar '<' = "&lt;"
 148       fixChar '>' = "&gt;"
 149       fixChar '&' = "&amp;"
 150       fixChar '"' = "&quot;"
 151       fixChar c   = [c]
 152
 153 -- ---------------------------------------------------------------------------
 154 -- Classes
 155
 156 instance Show Html where
 157       showsPrec _ html = showString (prettyHtml html)
 158       showList htmls   = showString (concat (map show htmls))
 159
 160 instance Show HtmlAttr where
 161       showsPrec _ (HtmlAttr str val) =
 162               showString str .
 163               showString "=" .
 164               shows val
 165
 166
 167 -- ---------------------------------------------------------------------------
 168 -- Data types
 169
 170 type URL = String
 171
 172 -- ---------------------------------------------------------------------------
 173 -- Basic primitives
 174
 175 -- This is not processed for special chars.
 176 -- use stringToHtml or lineToHtml instead, for user strings,
 177 -- because they  understand special chars, like '<'.
 178
 179 primHtml      :: String                                -> Html
 180 primHtml x    = Html [HtmlString x]
 181
 182 -- ---------------------------------------------------------------------------
 183 -- Basic Combinators
 184
 185 stringToHtml          :: String                       -> Html
 186 stringToHtml = primHtml . stringToHtmlString
 187
 188 -- This converts a string, but keeps spaces as non-line-breakable
 189
 190 lineToHtml            :: String                       -> Html
 191 lineToHtml = primHtml . concatMap htmlizeChar2 . stringToHtmlString
 192    where
 193       htmlizeChar2 ' ' = "&nbsp;"
 194       htmlizeChar2 c   = [c]
 195
 196 -- ---------------------------------------------------------------------------
 197 -- Html Constructors
 198
 199 -- (automatically generated)
 200
 201 address             :: Html -> Html
 202 anchor              :: Html -> Html
 203 applet              :: Html -> Html
 204 area                ::         Html
 205 basefont            ::         Html
 206 big                 :: Html -> Html
 207 blockquote          :: Html -> Html
 208 body                :: Html -> Html
 209 bold                :: Html -> Html
 210 br                  ::         Html
 211 caption             :: Html -> Html
 212 center              :: Html -> Html
 213 cite                :: Html -> Html
 214 ddef                :: Html -> Html
 215 define              :: Html -> Html
 216 dlist               :: Html -> Html
 217 dterm               :: Html -> Html
 218 emphasize           :: Html -> Html
 219 fieldset            :: Html -> Html
 220 font                :: Html -> Html
 221 form                :: Html -> Html
 222 frame               :: Html -> Html
 223 frameset            :: Html -> Html
 224 h1                  :: Html -> Html
 225 h2                  :: Html -> Html
 226 h3                  :: Html -> Html
 227 h4                  :: Html -> Html
 228 h5                  :: Html -> Html
 229 h6                  :: Html -> Html
 230 header              :: Html -> Html
 231 hr                  ::         Html
 232 image               ::         Html
 233 input               ::         Html
 234 italics             :: Html -> Html
 235 keyboard            :: Html -> Html
 236 legend              :: Html -> Html
 237 li                  :: Html -> Html
 238 meta                ::         Html
 239 noframes            :: Html -> Html
 240 olist               :: Html -> Html
 241 option              :: Html -> Html
 242 paragraph           :: Html -> Html
 243 param               ::         Html
 244 pre                 :: Html -> Html
 245 sample              :: Html -> Html
 246 select              :: Html -> Html
 247 small               :: Html -> Html
 248 strong              :: Html -> Html
 249 style               :: Html -> Html
 250 sub                 :: Html -> Html
 251 sup                 :: Html -> Html
 252 table               :: Html -> Html
 253 td                  :: Html -> Html
 254 textarea            :: Html -> Html
 255 th                  :: Html -> Html
 256 thebase             ::         Html
 257 thecode             :: Html -> Html
 258 thediv              :: Html -> Html
 259 thehtml             :: Html -> Html
 260 thelink             :: Html -> Html
 261 themap              :: Html -> Html
 262 thespan             :: Html -> Html
 263 thetitle            :: Html -> Html
 264 tr                  :: Html -> Html
 265 tt                  :: Html -> Html
 266 ulist               :: Html -> Html
 267 underline           :: Html -> Html
 268 variable            :: Html -> Html
 269
 270 address             =  tag "ADDRESS"
 271 anchor              =  tag "A"
 272 applet              =  tag "APPLET"
 273 area                = itag "AREA"
 274 basefont            = itag "BASEFONT"
 275 big                 =  tag "BIG"
 276 blockquote          =  tag "BLOCKQUOTE"
 277 body                =  tag "BODY"
 278 bold                =  tag "B"
 279 br                  = itag "BR"
 280 caption             =  tag "CAPTION"
 281 center              =  tag "CENTER"
 282 cite                =  tag "CITE"
 283 ddef                =  tag "DD"
 284 define              =  tag "DFN"
 285 dlist               =  tag "DL"
 286 dterm               =  tag "DT"
 287 emphasize           =  tag "EM"
 288 fieldset            =  tag "FIELDSET"
 289 font                =  tag "FONT"
 290 form                =  tag "FORM"
 291 frame               =  tag "FRAME"
 292 frameset            =  tag "FRAMESET"
 293 h1                  =  tag "H1"
 294 h2                  =  tag "H2"
 295 h3                  =  tag "H3"
 296 h4                  =  tag "H4"
 297 h5                  =  tag "H5"
 298 h6                  =  tag "H6"
 299 header              =  tag "HEAD"
 300 hr                  = itag "HR"
 301 image               = itag "IMG"
 302 input               = itag "INPUT"
 303 italics             =  tag "I"
 304 keyboard            =  tag "KBD"
 305 legend              =  tag "LEGEND"
 306 li                  =  tag "LI"
 307 meta                = itag "META"
 308 noframes            =  tag "NOFRAMES"
 309 olist               =  tag "OL"
 310 option              =  tag "OPTION"
 311 paragraph           =  tag "P"
 312 param               = itag "PARAM"
 313 pre                 =  tag "PRE"
 314 sample              =  tag "SAMP"
 315 select              =  tag "SELECT"
 316 small               =  tag "SMALL"
 317 strong              =  tag "STRONG"
 318 style               =  tag "STYLE"
 319 sub                 =  tag "SUB"
 320 sup                 =  tag "SUP"
 321 table               =  tag "TABLE"
 322 td                  =  tag "TD"
 323 textarea            =  tag "TEXTAREA"
 324 th                  =  tag "TH"
 325 thebase             = itag "BASE"
 326 thecode             =  tag "CODE"
 327 thediv              =  tag "DIV"
 328 thehtml             =  tag "HTML"
 329 thelink             =  tag "LINK"
 330 themap              =  tag "MAP"
 331 thespan             =  tag "SPAN"
 332 thetitle            =  tag "TITLE"
 333 tr                  =  tag "TR"
 334 tt                  =  tag "TT"
 335 ulist               =  tag "UL"
 336 underline           =  tag "U"
 337 variable            =  tag "VAR"
 338
 339 -- ---------------------------------------------------------------------------
 340 -- Html Attributes
 341
 342 -- (automatically generated)
 343
 344 action              :: String -> HtmlAttr
 345 align               :: String -> HtmlAttr
 346 alink               :: String -> HtmlAttr
 347 alt                 :: String -> HtmlAttr
 348 altcode             :: String -> HtmlAttr
 349 archive             :: String -> HtmlAttr
 350 background          :: String -> HtmlAttr
 351 base                :: String -> HtmlAttr
 352 bgcolor             :: String -> HtmlAttr
 353 border              :: Int    -> HtmlAttr
 354 bordercolor         :: String -> HtmlAttr
 355 cellpadding         :: Int    -> HtmlAttr
 356 cellspacing         :: Int    -> HtmlAttr
 357 checked             ::           HtmlAttr
 358 clear               :: String -> HtmlAttr
 359 code                :: String -> HtmlAttr
 360 codebase            :: String -> HtmlAttr
 361 color               :: String -> HtmlAttr
 362 cols                :: String -> HtmlAttr
 363 colspan             :: Int    -> HtmlAttr
 364 compact             ::           HtmlAttr
 365 content             :: String -> HtmlAttr
 366 coords              :: String -> HtmlAttr
 367 enctype             :: String -> HtmlAttr
 368 face                :: String -> HtmlAttr
 369 frameborder         :: Int    -> HtmlAttr
 370 height              :: Int    -> HtmlAttr
 371 href                :: String -> HtmlAttr
 372 hspace              :: Int    -> HtmlAttr
 373 httpequiv           :: String -> HtmlAttr
 374 identifier          :: String -> HtmlAttr
 375 ismap               ::           HtmlAttr
 376 lang                :: String -> HtmlAttr
 377 link                :: String -> HtmlAttr
 378 marginheight        :: Int    -> HtmlAttr
 379 marginwidth         :: Int    -> HtmlAttr
 380 maxlength           :: Int    -> HtmlAttr
 381 method              :: String -> HtmlAttr
 382 multiple            ::           HtmlAttr
 383 name                :: String -> HtmlAttr
 384 nohref              ::           HtmlAttr
 385 noresize            ::           HtmlAttr
 386 noshade             ::           HtmlAttr
 387 nowrap              ::           HtmlAttr
 388 rel                 :: String -> HtmlAttr
 389 rev                 :: String -> HtmlAttr
 390 rows                :: String -> HtmlAttr
 391 rowspan             :: Int    -> HtmlAttr
 392 rules               :: String -> HtmlAttr
 393 scrolling           :: String -> HtmlAttr
 394 selected            ::           HtmlAttr
 395 shape               :: String -> HtmlAttr
 396 size                :: String -> HtmlAttr
 397 src                 :: String -> HtmlAttr
 398 start               :: Int    -> HtmlAttr
 399 target              :: String -> HtmlAttr
 400 text                :: String -> HtmlAttr
 401 theclass            :: String -> HtmlAttr
 402 thestyle            :: String -> HtmlAttr
 403 thetype             :: String -> HtmlAttr
 404 title               :: String -> HtmlAttr
 405 usemap              :: String -> HtmlAttr
 406 valign              :: String -> HtmlAttr
 407 value               :: String -> HtmlAttr
 408 version             :: String -> HtmlAttr
 409 vlink               :: String -> HtmlAttr
 410 vspace              :: Int    -> HtmlAttr
 411 width               :: String -> HtmlAttr
 412
 413 action              =   strAttr "ACTION"
 414 align               =   strAttr "ALIGN"
 415 alink               =   strAttr "ALINK"
 416 alt                 =   strAttr "ALT"
 417 altcode             =   strAttr "ALTCODE"
 418 archive             =   strAttr "ARCHIVE"
 419 background          =   strAttr "BACKGROUND"
 420 base                =   strAttr "BASE"
 421 bgcolor             =   strAttr "BGCOLOR"
 422 border              =   intAttr "BORDER"
 423 bordercolor         =   strAttr "BORDERCOLOR"
 424 cellpadding         =   intAttr "CELLPADDING"
 425 cellspacing         =   intAttr "CELLSPACING"
 426 checked             = emptyAttr "CHECKED"
 427 clear               =   strAttr "CLEAR"
 428 code                =   strAttr "CODE"
 429 codebase            =   strAttr "CODEBASE"
 430 color               =   strAttr "COLOR"
 431 cols                =   strAttr "COLS"
 432 colspan             =   intAttr "COLSPAN"
 433 compact             = emptyAttr "COMPACT"
 434 content             =   strAttr "CONTENT"
 435 coords              =   strAttr "COORDS"
 436 enctype             =   strAttr "ENCTYPE"
 437 face                =   strAttr "FACE"
 438 frameborder         =   intAttr "FRAMEBORDER"
 439 height              =   intAttr "HEIGHT"
 440 href                =   strAttr "HREF"
 441 hspace              =   intAttr "HSPACE"
 442 httpequiv           =   strAttr "HTTP-EQUIV"
 443 identifier          =   strAttr "ID"
 444 ismap               = emptyAttr "ISMAP"
 445 lang                =   strAttr "LANG"
 446 link                =   strAttr "LINK"
 447 marginheight        =   intAttr "MARGINHEIGHT"
 448 marginwidth         =   intAttr "MARGINWIDTH"
 449 maxlength           =   intAttr "MAXLENGTH"
 450 method              =   strAttr "METHOD"
 451 multiple            = emptyAttr "MULTIPLE"
 452 name                =   strAttr "NAME"
 453 nohref              = emptyAttr "NOHREF"
 454 noresize            = emptyAttr "NORESIZE"
 455 noshade             = emptyAttr "NOSHADE"
 456 nowrap              = emptyAttr "NOWRAP"
 457 rel                 =   strAttr "REL"
 458 rev                 =   strAttr "REV"
 459 rows                =   strAttr "ROWS"
 460 rowspan             =   intAttr "ROWSPAN"
 461 rules               =   strAttr "RULES"
 462 scrolling           =   strAttr "SCROLLING"
 463 selected            = emptyAttr "SELECTED"
 464 shape               =   strAttr "SHAPE"
 465 size                =   strAttr "SIZE"
 466 src                 =   strAttr "SRC"
 467 start               =   intAttr "START"
 468 target              =   strAttr "TARGET"
 469 text                =   strAttr "TEXT"
 470 theclass            =   strAttr "CLASS"
 471 thestyle            =   strAttr "STYLE"
 472 thetype             =   strAttr "TYPE"
 473 title               =   strAttr "TITLE"
 474 usemap              =   strAttr "USEMAP"
 475 valign              =   strAttr "VALIGN"
 476 value               =   strAttr "VALUE"
 477 version             =   strAttr "VERSION"
 478 vlink               =   strAttr "VLINK"
 479 vspace              =   intAttr "VSPACE"
 480 width               =   strAttr "WIDTH"
 481
 482 -- ---------------------------------------------------------------------------
 483 -- Html Constructors
 484
 485 -- (automatically generated)
 486
 487 validHtmlTags :: [String]
 488 validHtmlTags = [
 489       "ADDRESS",
 490       "A",
 491       "APPLET",
 492       "BIG",
 493       "BLOCKQUOTE",
 494       "BODY",
 495       "B",
 496       "CAPTION",
 497       "CENTER",
 498       "CITE",
 499       "DD",
 500       "DFN",
 501       "DL",
 502       "DT",
 503       "EM",
 504       "FIELDSET",
 505       "FONT",
 506       "FORM",
 507       "FRAME",
 508       "FRAMESET",
 509       "H1",
 510       "H2",
 511       "H3",
 512       "H4",
 513       "H5",
 514       "H6",
 515       "HEAD",
 516       "I",
 517       "KBD",
 518       "LEGEND",
 519       "LI",
 520       "NOFRAMES",
 521       "OL",
 522       "OPTION",
 523       "P",
 524       "PRE",
 525       "SAMP",
 526       "SELECT",
 527       "SMALL",
 528       "STRONG",
 529       "STYLE",
 530       "SUB",
 531       "SUP",
 532       "TABLE",
 533       "TD",
 534       "TEXTAREA",
 535       "TH",
 536       "CODE",
 537       "DIV",
 538       "HTML",
 539       "LINK",
 540       "MAP",
 541       "TITLE",
 542       "TR",
 543       "TT",
 544       "UL",
 545       "U",
 546       "VAR"]
 547
 548 validHtmlITags :: [String]
 549 validHtmlITags = [
 550       "AREA",
 551       "BASEFONT",
 552       "BR",
 553       "HR",
 554       "IMG",
 555       "INPUT",
 556       "META",
 557       "PARAM",
 558       "BASE"]
 559
 560 validHtmlAttrs :: [String]
 561 validHtmlAttrs = [
 562       "ACTION",
 563       "ALIGN",
 564       "ALINK",
 565       "ALT",
 566       "ALTCODE",
 567       "ARCHIVE",
 568       "BACKGROUND",
 569       "BASE",
 570       "BGCOLOR",
 571       "BORDER",
 572       "BORDERCOLOR",
 573       "CELLPADDING",
 574       "CELLSPACING",
 575       "CHECKED",
 576       "CLEAR",
 577       "CODE",
 578       "CODEBASE",
 579       "COLOR",
 580       "COLS",
 581       "COLSPAN",
 582       "COMPACT",
 583       "CONTENT",
 584       "COORDS",
 585       "ENCTYPE",
 586       "FACE",
 587       "FRAMEBORDER",
 588       "HEIGHT",
 589       "HREF",
 590       "HSPACE",
 591       "HTTP-EQUIV",
 592       "ID",
 593       "ISMAP",
 594       "LANG",
 595       "LINK",
 596       "MARGINHEIGHT",
 597       "MARGINWIDTH",
 598       "MAXLENGTH",
 599       "METHOD",
 600       "MULTIPLE",
 601       "NAME",
 602       "NOHREF",
 603       "NORESIZE",
 604       "NOSHADE",
 605       "NOWRAP",
 606       "REL",
 607       "REV",
 608       "ROWS",
 609       "ROWSPAN",
 610       "RULES",
 611       "SCROLLING",
 612       "SELECTED",
 613       "SHAPE",
 614       "SIZE",
 615       "SRC",
 616       "START",
 617       "TARGET",
 618       "TEXT",
 619       "CLASS",
 620       "STYLE",
 621       "TYPE",
 622       "TITLE",
 623       "USEMAP",
 624       "VALIGN",
 625       "VALUE",
 626       "VERSION",
 627       "VLINK",
 628       "VSPACE",
 629       "WIDTH"]
 630
 631 -- ---------------------------------------------------------------------------
 632 -- Html colors
 633
 634 aqua          :: String
 635 black         :: String
 636 blue          :: String
 637 fuchsia       :: String
 638 gray          :: String
 639 green         :: String
 640 lime          :: String
 641 maroon        :: String
 642 navy          :: String
 643 olive         :: String
 644 purple        :: String
 645 red           :: String
 646 silver        :: String
 647 teal          :: String
 648 yellow        :: String
 649 white         :: String
 650
 651 aqua          = "aqua"
 652 black         = "black"
 653 blue          = "blue"
 654 fuchsia       = "fuchsia"
 655 gray          = "gray"
 656 green         = "green"
 657 lime          = "lime"
 658 maroon        = "maroon"
 659 navy          = "navy"
 660 olive         = "olive"
 661 purple        = "purple"
 662 red           = "red"
 663 silver        = "silver"
 664 teal          = "teal"
 665 yellow        = "yellow"
 666 white         = "white"
 667
 668 -- ---------------------------------------------------------------------------
 669 -- Basic Combinators
 670
 671 linesToHtml :: [String]       -> Html
 672
 673 linesToHtml []     = noHtml
 674 linesToHtml (x:[]) = lineToHtml x
 675 linesToHtml (x:xs) = lineToHtml x +++ br +++ linesToHtml xs
 676
 677
 678 -- ---------------------------------------------------------------------------
 679 -- Html abbriviations
 680
 681 primHtmlChar  :: String -> Html
 682 copyright     :: Html
 683 spaceHtml     :: Html
 684 bullet        :: Html
 685 p             :: Html -> Html
 686
 687 primHtmlChar  = \ x -> primHtml ("&" ++ x ++ ";")
 688 copyright     = primHtmlChar "copy"
 689 spaceHtml     = primHtmlChar "nbsp"
 690 bullet        = primHtmlChar "#149"
 691
 692 p             = paragraph
 693
 694 -- ---------------------------------------------------------------------------
 695 -- Html tables
 696
 697 class HTMLTABLE ht where
 698       cell :: ht -> HtmlTable
 699
 700 instance HTMLTABLE HtmlTable where
 701       cell = id
 702
 703 instance HTMLTABLE Html where
 704       cell h =
 705          let
 706               cellFn x y = h ! (add x colspan $ add y rowspan $ [])
 707               add 1 fn rest = rest
 708               add n fn rest = fn n : rest
 709               r = BT.single cellFn
 710          in
 711               mkHtmlTable r
 712
 713 -- We internally represent the Cell inside a Table with an
 714 -- object of the type
 715 -- \pre{
 716 --         Int -> Int -> Html
 717 -- }
 718 -- When we render it later, we find out how many columns
 719 -- or rows this cell will span over, and can
 720 -- include the correct colspan/rowspan command.
 721
 722 newtype HtmlTable
 723       = HtmlTable (BT.BlockTable (Int -> Int -> Html))
 724
 725
 726 (</>),above,(<->),beside :: (HTMLTABLE ht1,HTMLTABLE ht2)
 727                        => ht1 -> ht2 -> HtmlTable
 728 aboves,besides                 :: (HTMLTABLE ht) => [ht] -> HtmlTable
 729 simpleTable            :: [HtmlAttr] -> [HtmlAttr] -> [[Html]] -> Html
 730
 731
 732 mkHtmlTable :: BT.BlockTable (Int -> Int -> Html) -> HtmlTable
 733 mkHtmlTable r = HtmlTable r
 734
 735 -- We give both infix and nonfix, take your pick.
 736 -- Notice that there is no concept of a row/column
 737 -- of zero items.
 738
 739 above   a b = combine BT.above (cell a) (cell b)
 740 (</>)         = above
 741 beside  a b = combine BT.beside (cell a) (cell b)
 742 (<->) = beside
 743
 744
 745 combine fn (HtmlTable a) (HtmlTable b) = mkHtmlTable (a `fn` b)
 746
 747 -- Both aboves and besides presume a non-empty list.
 748 -- here is no concept of a empty row or column in these
 749 -- table combinators.
 750
 751 aboves []  = error "aboves []"
 752 aboves xs  = foldr1 (</>) (map cell xs)
 753 besides [] = error "besides []"
 754 besides xs = foldr1 (<->) (map cell xs)
 755
 756 -- renderTable takes the HtmlTable, and renders it back into
 757 -- and Html object.
 758
 759 renderTable :: BT.BlockTable (Int -> Int -> Html) -> Html
 760 renderTable theTable
 761       = concatHtml
 762           [tr << [theCell x y | (theCell,(x,y)) <- theRow ]
 763                       | theRow <- BT.getMatrix theTable]
 764
 765 instance HTML HtmlTable where
 766       toHtml (HtmlTable tab) = renderTable tab
 767
 768 instance Show HtmlTable where
 769       showsPrec _ (HtmlTable tab) = shows (renderTable tab)
 770
 771
 772 -- If you can't be bothered with the above, then you
 773 -- can build simple tables with simpleTable.
 774 -- Just provide the attributes for the whole table,
 775 -- attributes for the cells (same for every cell),
 776 -- and a list of lists of cell contents,
 777 -- and this function will build the table for you.
 778 -- It does presume that all the lists are non-empty,
 779 -- and there is at least one list.
 780 --
 781 -- Different length lists means that the last cell
 782 -- gets padded. If you want more power, then
 783 -- use the system above, or build tables explicitly.
 784
 785 simpleTable attr cellAttr lst
 786       = table ! attr
 787           <<  (aboves
 788               . map (besides . map ((td ! cellAttr) . toHtml))
 789               ) lst
 790
 791
 792 -- ---------------------------------------------------------------------------
 793 -- Tree Displaying Combinators
 794
 795 -- The basic idea is you render your structure in the form
 796 -- of this tree, and then use treeHtml to turn it into a Html
 797 -- object with the structure explicit.
 798
 799 data HtmlTree
 800       = HtmlLeaf Html
 801       | HtmlNode Html [HtmlTree] Html
 802
 803 treeHtml :: [String] -> HtmlTree -> Html
 804 treeHtml colors h = table ! [
 805                     border 0,
 806                     cellpadding 0,
 807                     cellspacing 2] << treeHtml' colors h
 808      where
 809       manycolors = scanr (:) []
 810
 811       treeHtmls :: [[String]] -> [HtmlTree] -> HtmlTable
 812       treeHtmls c ts = aboves (zipWith treeHtml' c ts)
 813
 814       treeHtml' :: [String] -> HtmlTree -> HtmlTable
 815       treeHtml' (c:_) (HtmlLeaf leaf) = cell
 816                                          (td ! [width "100%"]
 817                                             << bold
 818                                                << leaf)
 819       treeHtml' (c:cs@(c2:_)) (HtmlNode hopen ts hclose) =
 820           if null ts && isNoHtml hclose
 821           then
 822               cell hd
 823           else if null ts
 824           then
 825               hd </> bar `beside` (td ! [bgcolor c2] << spaceHtml)
 826                  </> tl
 827           else
 828               hd </> (bar `beside` treeHtmls morecolors ts)
 829                  </> tl
 830         where
 831               -- This stops a column of colors being the same
 832               -- color as the immeduately outside nesting bar.
 833               morecolors = filter ((/= c).head) (manycolors cs)
 834               bar = td ! [bgcolor c,width "10"] << spaceHtml
 835               hd = td ! [bgcolor c] << hopen
 836               tl = td ! [bgcolor c] << hclose
 837       treeHtml' _ _ = error "The imposible happens"
 838
 839 instance HTML HtmlTree where
 840       toHtml x = treeHtml treeColors x
 841
 842 -- type "length treeColors" to see how many colors are here.
 843 treeColors = ["#88ccff","#ffffaa","#ffaaff","#ccffff"] ++ treeColors
 844
 845
 846 -- ---------------------------------------------------------------------------
 847 -- Html Debugging Combinators
 848
 849 -- This uses the above tree rendering function, and displays the
 850 -- Html as a tree structure, allowing debugging of what is
 851 -- actually getting produced.
 852
 853 debugHtml :: (HTML a) => a -> Html
 854 debugHtml obj = table ! [border 0] <<
 855                   ( th ! [bgcolor "#008888"]
 856                      << underline
 857                        << "Debugging Output"
 858                </>  td << (toHtml (debug' (toHtml obj)))
 859               )
 860   where
 861
 862       debug' :: Html -> [HtmlTree]
 863       debug' (Html markups) = map debug markups
 864
 865       debug :: HtmlElement -> HtmlTree
 866       debug (HtmlString str) = HtmlLeaf (spaceHtml +++
 867                                               linesToHtml (lines str))
 868       debug (HtmlTag {
 869               markupTag = markupTag,
 870               markupContent = markupContent,
 871               markupAttrs  = markupAttrs
 872               }) =
 873               case markupContent of
 874                 Html [] -> HtmlNode hd [] noHtml
 875                 Html xs -> HtmlNode hd (map debug xs) tl
 876         where
 877               args = if null markupAttrs
 878                      then ""
 879                      else "  " ++ unwords (map show markupAttrs)
 880               hd = font ! [size "1"] << ("<" ++ markupTag ++ args ++ ">")
 881               tl = font ! [size "1"] << ("</" ++ markupTag ++ ">")
 882
 883 -- ---------------------------------------------------------------------------
 884 -- Hotlink datatype
 885
 886 data HotLink = HotLink {
 887       hotLinkURL        :: URL,
 888       hotLinkContents   :: [Html],
 889       hotLinkAttributes :: [HtmlAttr]
 890       } deriving Show
 891
 892 instance HTML HotLink where
 893       toHtml hl = anchor ! (href (hotLinkURL hl) : hotLinkAttributes hl)
 894                       << hotLinkContents hl
 895
 896 hotlink :: URL -> [Html] -> HotLink
 897 hotlink url h = HotLink {
 898       hotLinkURL = url,
 899       hotLinkContents = h,
 900       hotLinkAttributes = [] }
 901
 902
 903 -- ---------------------------------------------------------------------------
 904 -- More Combinators
 905
 906 -- (Abridged from Erik Meijer's Original Html library)
 907
 908 ordList   :: (HTML a) => [a] -> Html
 909 ordList items = olist << map (li <<) items
 910
 911 unordList :: (HTML a) => [a] -> Html
 912 unordList items = ulist << map (li <<) items
 913
 914 defList   :: (HTML a,HTML b) => [(a,b)] -> Html
 915 defList items
 916  = dlist << [ [ dterm << bold << dt, ddef << dd ] | (dt,dd) <- items ]
 917
 918
 919 widget :: String -> String -> [HtmlAttr] -> Html
 920 widget w n markupAttrs = input ! ([thetype w,name n] ++ markupAttrs)
 921
 922 checkbox :: String -> String -> Html
 923 hidden   :: String -> String -> Html
 924 radio    :: String -> String -> Html
 925 reset    :: String -> String -> Html
 926 submit   :: String -> String -> Html
 927 password :: String           -> Html
 928 textfield :: String          -> Html
 929 afile    :: String           -> Html
 930 clickmap :: String           -> Html
 931
 932 checkbox n v = widget "CHECKBOX" n [value v]
 933 hidden   n v = widget "HIDDEN"   n [value v]
 934 radio    n v = widget "RADIO"    n [value v]
 935 reset    n v = widget "RESET"    n [value v]
 936 submit   n v = widget "SUBMIT"   n [value v]
 937 password n   = widget "PASSWORD" n []
 938 textfield n  = widget "TEXT"     n []
 939 afile    n   = widget "FILE"     n []
 940 clickmap n   = widget "IMAGE"    n []
 941
 942 menu :: String -> [Html] -> Html
 943 menu n choices
 944    = select ! [name n] << [ option << p << choice | choice <- choices ]
 945
 946 gui :: String -> Html -> Html
 947 gui act = form ! [action act,method "POST"]
 948
 949 -- ---------------------------------------------------------------------------
 950 -- Html Rendering
 951
 952 -- Uses the append trick to optimize appending.
 953 -- The output is quite messy, because space matters in
 954 -- HTML, so we must not generate needless spaces.
 955
 956 renderHtml :: (HTML html) => html -> String
 957 renderHtml theHtml =
 958       renderMessage ++
 959          foldr (.) id (map (renderHtml' 0)
 960                            (getHtmlElements (tag "HTML" << theHtml))) "\n"
 961
 962 renderMessage =
 963       "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 FINAL//EN\">\n" ++
 964       "<!--Rendered using the Haskell Html Library v0.2-->\n"
 965
 966 -- Warning: spaces matters in HTML. You are better using renderHtml.
 967 -- This is intentually very inefficent to "encorage" this,
 968 -- but the neater version in easier when debugging.
 969
 970 -- Local Utilities
 971 prettyHtml :: (HTML html) => html -> String
 972 prettyHtml theHtml =
 973         unlines
 974       $ concat
 975       $ map prettyHtml'
 976       $ getHtmlElements
 977       $ toHtml theHtml
 978
 979 renderHtml' :: Int -> HtmlElement -> ShowS
 980 renderHtml' _ (HtmlString str) = (++) str
 981 renderHtml' n (HtmlTag
 982               { markupTag = name,
 983                 markupContent = html,
 984                 markupAttrs = markupAttrs })
 985       = if isNoHtml html && elem name validHtmlITags
 986         then renderTag True name markupAttrs n
 987         else (renderTag True name markupAttrs n
 988              . foldr (.) id (map (renderHtml' (n+2)) (getHtmlElements html))
 989              . renderTag False name [] n)
 990
 991 prettyHtml' :: HtmlElement -> [String]
 992 prettyHtml' (HtmlString str) = [str]
 993 prettyHtml' (HtmlTag
 994               { markupTag = name,
 995                 markupContent = html,
 996                 markupAttrs = markupAttrs })
 997       = if isNoHtml html && elem name validHtmlITags
 998         then
 999          [rmNL (renderTag True name markupAttrs 0 "")]
1000         else
1001          [rmNL (renderTag True name markupAttrs 0 "")] ++
1002           shift (concat (map prettyHtml' (getHtmlElements html))) ++
1003          [rmNL (renderTag False name [] 0 "")]
1004   where
1005       shift = map (\x -> "   " ++ x)
1006 rmNL = filter (/= '\n')
1007
1008 -- This prints the Tags The lack of spaces in intentunal, because Html is
1009 -- actually space dependant.
1010
1011 renderTag :: Bool -> String -> [HtmlAttr] -> Int -> ShowS
1012 renderTag x name markupAttrs n r
1013       = open ++ name ++ rest markupAttrs ++ ">" ++ r
1014   where
1015       open = if x then "<" else "</"
1016
1017       nl = "\n" ++ replicate (n `div` 8) '\t'
1018                 ++ replicate (n `mod` 8) ' '
1019
1020       rest []   = nl
1021       rest attr = " " ++ unwords (map showPair attr) ++ nl
1022
1023       showPair :: HtmlAttr -> String
1024       showPair (HtmlAttr tag val)
1025               = tag ++ " = \"" ++ val  ++ "\""
1026