! 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 ;