! 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 parser
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 [ % ] [ , ] ?ifte ] each
] "" make ;
: hex-color, ( triplet -- )
[ >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: " % % "; " % ;
: 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
] ifte ;
: 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
] ifte* ;
: 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
] ifte ;
: icon-tag ( string style quot -- )
over icon swap assoc dup [
#! Ignore the quotation, since no further style
#! can be applied
3drop
] [
drop call
] ifte ;
TUPLE: html-stream ;
M: html-stream stream-write1 ( char stream -- )
[
dup html-entities assoc [ write ] [ write1 ] ?ifte
] with-wrapper ;
M: html-stream stream-format ( str style stream -- )
[
[
[
[
[ drop chars>entities write ] span-tag
] file-link-tag
] icon-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
#! icon
#! 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 ;