! Copyright (C) 2004, 2006 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: cont-responder generic hashtables help http inspector io kernel lists prototype-js math namespaces sequences strings styles words xml ; IN: html : hex-color, ( triplet -- ) 3 swap head [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ; : fg-css, ( color -- ) "color: #" % hex-color, "; " % ; : bg-css, ( color -- ) "background-color: #" % hex-color, "; " % ; : style-css, ( flag -- ) dup { italic bold-italic } member? [ "font-style: italic; " % ] when { bold bold-italic } member? [ "font-weight: bold; " % ] when ; : size-css, ( size -- ) "font-size: " % # "pt; " % ; : font-css, ( font -- ) "font-family: " % % "; " % ; : hash-apply ( value-hash quot-hash -- ) #! Looks up the key of each pair in the first list in the #! second list to produce a quotation. The quotation is #! applied to the value of the pair. If there is no #! corresponding quotation, the value is popped off the #! stack. swap [ swap rot hash dup [ call ] [ 2drop ] if ] hash-each-with ; : span-css-style ( style -- str ) [ H{ { foreground [ fg-css, ] } { background [ bg-css, ] } { font [ font-css, ] } { font-style [ style-css, ] } { font-size [ size-css, ] } } hash-apply ] "" make ; : span-tag ( style quot -- ) over span-css-style dup empty? [ drop call ] [ call ] if ; : border-css, ( border -- ) "border: 1px solid #" % hex-color, "; " % ; : padding-css, ( padding -- ) "padding: " % # "px; " % ; : pre-css, ( -- ) "white-space: pre; font-family:monospace; " % ; : div-css-style ( style -- str ) [ H{ { page-color [ bg-css, ] } { border-color [ border-css, ] } { border-width [ padding-css, ] } { wrap-margin [ [ pre-css, ] unless ] } } hash-apply ] "" make ; : div-tag ( style quot -- ) swap div-css-style dup empty? [ drop call ] [
call
] if ; : resolve-file-link ( path -- link ) #! The file responder needs relative links not absolute #! links. "doc-root" get [ ?head [ "/" ?head drop ] when ] when* "/" ?tail drop ; : file-link-href ( path -- href ) [ "/" % resolve-file-link url-encode % ] "" make ; : file-link-tag ( style quot -- ) over file swap hash [ call ] [ call ] if* ; : do-escaping ( string style -- string ) html swap hash [ chars>entities ] unless ; GENERIC: browser-link-href ( presented -- href ) M: object browser-link-href drop f ; M: word browser-link-href "/responder/browser/" swap [ dup word-vocabulary "vocab" set word-name "word" set ] make-hash build-url ; M: link browser-link-href link-name [ \ f ] unless* dup word? [ browser-link-href ] [ "/responder/help/" swap "topic" associate build-url ] if ; : object-link-tag ( style quot -- ) presented pick hash browser-link-href [ call ] [ call ] if* ; TUPLE: nested-stream ; C: nested-stream [ set-delegate ] keep ; M: nested-stream stream-close drop ; TUPLE: html-stream ; C: html-stream ( stream -- stream ) [ set-delegate ] keep ; M: html-stream stream-write1 ( char stream -- ) >r ch>string r> stream-write ; : delegate-write delegate stream-write ; M: html-stream stream-write ( str stream -- ) >r chars>entities r> delegate-write ; M: html-stream stream-format ( str style stream -- ) [ [ [ [ do-escaping stdio get delegate-write ] span-tag ] file-link-tag ] object-link-tag ] with-stream* ; : with-html-stream ( quot -- ) stdio get swap with-stream* ; : make-outliner-quot [
with-html-stream
] curry [ , \ show-final , ] [ ] make ; : html-outliner ( caption contents -- ) "+ " get-random-id dup >r rot make-outliner-quot updating-anchor call =id span> ; : outliner-tag ( style quot -- ) outline pick hash [ html-outliner ] [ call ] if* ; M: html-stream with-nested-stream ( quot style stream -- ) [ [ [ [ stdio get swap with-stream* ] div-tag ] object-link-tag ] outliner-tag ] with-stream* ; M: html-stream stream-terpri [
] with-stream* ; : default-css ( -- ) ; : xhtml-preamble "" print "" print ; : html-document ( title quot -- ) xhtml-preamble swap chars>entities dup write default-css include-prototype-js

write

call ; : simple-html-document ( title quot -- ) swap [
 with-html-stream 
] html-document ;