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