! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: html
USING: generic http io kernel lists math namespaces
presentation sequences strings styles words ;
: html-entities ( -- alist )
[
[[ CHAR: < "<" ]]
[[ CHAR: > ">" ]]
[[ CHAR: & "&" ]]
[[ CHAR: ' "'" ]]
[[ CHAR: " """ ]]
] ;
: chars>entities ( str -- str )
#! Convert <, >, &, ' and " to HTML entities.
[
[ dup html-entities assoc [ % ] [ , ] ?if ] each
] "" make ;
: hex-color, ( triplet -- )
3 swap head [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ;
: fg-css, ( color -- )
"color: #" % hex-color, "; " % ;
: style-css, ( flag -- )
dup [ italic bold-italic ] member?
[ "font-style: italic; " % ] when
[ bold bold-italic ] member?
[ "font-weight: bold; " % ] when ;
: underline-css, ( flag -- )
[ "text-decoration: underline; " % ] when ;
: size-css, ( size -- )
"font-size: " % # "; " % ;
: font-css, ( font -- )
"font-family: " % % "; " % ;
: assoc-apply ( value-alist quot-alist -- )
#! 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 [
unswons rot assoc* dup [ cdr call ] [ 2drop ] if
] each-with ;
: css-style ( style -- )
[
[
[ foreground fg-css, ]
[ font font-css, ]
[ font-style style-css, ]
[ font-size size-css, ]
[ underline underline-css, ]
] assoc-apply
] "" make ;
: span-tag ( style quot -- )
over css-style dup "" = [
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 assoc [
call
] [
call
] if* ;
: browser-link-href ( word -- href )
dup word-name swap word-vocabulary
[
"/responder/browser/?vocab=" %
url-encode %
"&word=" %
url-encode %
] "" make ;
: browser-link-tag ( style quot -- style )
over presented swap assoc dup word? [
call
] [
drop call
] if ;
TUPLE: html-stream ;
M: html-stream stream-write1 ( char stream -- )
[
dup html-entities assoc [ write ] [ write1 ] ?if
] with-wrapper ;
M: html-stream stream-format ( str style stream -- )
[
[
[
[ drop chars>entities write ] span-tag
] file-link-tag
] browser-link-tag
] with-wrapper ;
C: html-stream ( stream -- stream )
#! Wraps the given stream in an HTML stream. An HTML stream
#! converts special characters to entities when being
#! written, and supports writing attributed strings with
#! the following attributes:
#!
#! foreground - an rgb triplet in a list
#! background - an rgb triplet in a list
#! font
#! font-style
#! font-size
#! underline
#! file
#! word
#! vocab
[ >r r> set-delegate ] keep ;
: with-html-stream ( quot -- )
[ stdio [ ] change call ] with-scope ;
: html-document ( title quot -- )
swap chars>entities dup
write
write
call
;
: simple-html-document ( title quot -- )
swap [ with-html-stream
] html-document ;