contrib/httpd/html.factor

   1 ! Copyright (C) 2004, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: callback-responder generic hashtables help http tools
   4 io kernel math namespaces prototype-js sequences strings styles
   5 words xml ;
   6 IN: html
   7
   8 : hex-color, ( triplet -- )
   9     3 head-slice
  10     [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ;
  11
  12 : fg-css, ( color -- )
  13     "color: #" % hex-color, "; " % ;
  14
  15 : bg-css, ( color -- )
  16     "background-color: #" % hex-color, "; " % ;
  17
  18 : style-css, ( flag -- )
  19     dup
  20     { italic bold-italic } member?
  21     "font-style: " % "italic" "normal" ? % "; " %
  22     { bold bold-italic } member?
  23     "font-weight: " % "bold" "normal" ? % "; " % ;
  24
  25 : size-css, ( size -- )
  26     "font-size: " % # "pt; " % ;
  27
  28 : font-css, ( font -- )
  29     "font-family: " % % "; " % ;
  30
  31 : hash-apply ( value-hash quot-hash -- )
  32     #! Looks up the key of each pair in the first list in the
  33     #! second list to produce a quotation. The quotation is
  34     #! applied to the value of the pair. If there is no
  35     #! corresponding quotation, the value is popped off the
  36     #! stack.
  37     swap [
  38         swap rot hash dup [ call ] [ 2drop ] if
  39     ] hash-each-with ;
  40
  41 : span-css-style ( style -- str )
  42     [
  43         H{
  44             { foreground  [ fg-css,        ] }
  45             { background  [ bg-css,        ] }
  46             { font        [ font-css,      ] }
  47             { font-style  [ style-css,     ] }
  48             { font-size   [ size-css,      ] }
  49         } hash-apply
  50     ] "" make ;
  51
  52 : span-tag ( style quot -- )
  53     over span-css-style dup empty? [
  54         drop call
  55     ] [
  56         <span =style span> call </span>
  57     ] if ;
  58
  59 : border-css, ( border -- )
  60     "border: 1px solid #" % hex-color, "; " % ;
  61
  62 : padding-css, ( padding -- ) "padding: " % # "px; " % ;
  63
  64 : pre-css, ( -- )
  65     "white-space: pre; font-family:monospace; " % ;
  66
  67 : div-css-style ( style -- str )
  68     [
  69         H{
  70             { page-color [ bg-css, ] }
  71             { border-color [ border-css, ] }
  72             { border-width [ padding-css, ] }
  73             { wrap-margin [ [ pre-css, ] unless ] }
  74         } hash-apply
  75     ] "" make ;
  76
  77 : div-tag ( style quot -- )
  78     swap div-css-style dup empty? [
  79         drop call
  80     ] [
  81         <div =style div> call </div>
  82     ] if ;
  83
  84 : do-escaping ( string style -- string )
  85     html swap hash [ chars>entities ] unless ;
  86
  87 GENERIC: browser-link-href ( presented -- href )
  88
  89 M: object browser-link-href drop f ;
  90
  91 : resolve-file-link ( path -- link )
  92     #! The file responder needs relative links not absolute
  93     #! links.
  94     "doc-root" get [
  95         ?head [ "/" ?head drop ] when
  96     ] when* "/" ?tail drop ;
  97
  98 M: pathname browser-link-href
  99     pathname-string
 100     "/" swap resolve-file-link url-encode append ;
 101
 102 : object-link-tag ( style quot -- )
 103     presented pick hash browser-link-href
 104     [ <a =href a> call </a> ] [ call ] if* ;
 105
 106 TUPLE: nested-stream ;
 107
 108 C: nested-stream [ set-delegate ] keep ;
 109
 110 M: nested-stream stream-close drop ;
 111
 112 TUPLE: html-stream ;
 113
 114 C: html-stream ( stream -- stream ) [ set-delegate ] keep ;
 115
 116 M: html-stream stream-write1 ( char stream -- )
 117     >r ch>string r> stream-write ;
 118
 119 : delegate-write delegate stream-write ;
 120
 121 M: html-stream stream-write ( str stream -- )
 122     >r chars>entities r> delegate-write ;
 123
 124 : with-html-style ( quot style stream -- )
 125     [ [ swap span-tag ] object-link-tag ] with-stream* ; inline
 126
 127 M: html-stream with-stream-style ( quot style stream -- )
 128     [ drop call ] -rot with-html-style ;
 129
 130 M: html-stream stream-format ( str style stream -- )
 131     [ do-escaping stdio get delegate-write ] -rot
 132     with-html-style ;
 133
 134 : with-html-stream ( quot -- )
 135     stdio get <html-stream> swap with-stream* ;
 136
 137 : make-outliner-quot
 138     [
 139         <div "padding-left: 20px; " =style div>
 140             with-html-stream
 141         </div>
 142     ] curry ;
 143
 144 : html-outliner ( caption contents -- )
 145     "+ " get-random-id dup >r
 146     rot make-outliner-quot updating-anchor call
 147     <span r> =id "display: none; " =style span> </span> ;
 148
 149 : outliner-tag ( style quot -- )
 150     outline pick hash [ html-outliner ] [ call ] if* ;
 151
 152 M: html-stream with-nested-stream ( quot style stream -- )
 153     [
 154         [
 155             [
 156                 [
 157                     stdio get <nested-stream> swap with-stream*
 158                 ] div-tag
 159             ] object-link-tag
 160         ] outliner-tag
 161     ] with-stream* ;
 162
 163 : border-spacing-css,
 164     "padding: " % first2 max 2 /i # "px; " % ;
 165
 166 : table-style ( style -- str )
 167     [
 168         H{
 169             { table-border [ border-css,         ] }
 170             { table-gap    [ border-spacing-css, ] }
 171         } hash-apply
 172     ] "" make ;
 173
 174 : table-attrs ( style -- )
 175     table-style " border-collapse: collapse;" append =style ;
 176
 177 M: html-stream with-stream-table ( grid quot style stream -- )
 178     [
 179         <table dup table-attrs table> rot [
 180             <tr> [
 181                 <td "top" =valign over table-style =style td>
 182                     pick H{ } swap with-nesting
 183                 </td>
 184             ] each </tr>
 185         ] each 2drop </table>
 186     ] with-stream* ;
 187
 188 M: html-stream stream-terpri [ <br/> ] with-stream* ;
 189
 190 : default-css ( -- )
 191   <style "text/css" =type style>
 192     "a:link { text-decoration: none; color: black; }" print
 193     "a:visited { text-decoration: none; color: black; }" print
 194     "a:active { text-decoration: none; color: black; }" print
 195     "a:hover, A:hover { text-decoration: underline; color: black; }" print
 196   </style> ;
 197
 198 : xhtml-preamble
 199     xml-preamble print
 200     "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" print ;
 201
 202 : html-document ( title quot -- )
 203     xhtml-preamble
 204     swap chars>entities
 205     <html " xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\" lang=\"en\"" write html>
 206         <head>
 207             <title> write </title>
 208             default-css
 209             include-prototype-js
 210         </head>
 211         <body>
 212             call
 213         </body>
 214     </html> ;
 215
 216 : simple-html-document ( title quot -- )
 217     swap [ <pre> with-html-stream </pre> ] html-document ;