Text/Html.hs

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