factor/library/httpd/html.factor

! 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: < "&lt;"   ]]
        [[ CHAR: > "&gt;"   ]]
        [[ CHAR: & "&amp;"  ]]
        [[ CHAR: ' "&apos;" ]]
        [[ CHAR: " "&quot;" ]]
    ] ;

: 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
    ] [
        <span style= span> call </span>
    ] 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 [
        <a href= file-link-href a> call </a>
    ] [
        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? [
        <a href= browser-link-href a> call </a>
    ] [
        drop call
    ] ifte ;

: icon-tag ( string style quot -- )
    over icon swap assoc dup [
        <img src= "/responder/resource/" swap append img/>
        #! 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 <wrapper-stream> r> set-delegate ] keep ;

: with-html-stream ( quot -- )
    [ stdio [ <html-stream> ] change  call ] with-scope ;

: html-document ( title quot -- )
    swap chars>entities dup
    <html>
        <head>
            <title> write </title>
        </head>
        <body>
            <h1> write </h1>
            call
        </body>
    </html> ;

: simple-html-document ( title quot -- )
    swap [ <pre> with-html-stream </pre> ] html-document ;
tuples used for i/o streams, removed traits metaclass 2005-01-30 15:57:25 -05:00			`! Copyright (C) 2004, 2005 Slava Pestov.`
			`! See http://factor.sf.net/license.txt for BSD license.`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00			`IN: html`
more cleanups; split up huge gadgets vocabulary 2005-08-31 21:06:13 -04:00			`USING: generic http io kernel lists math namespaces parser`
more prettyprinter updates, unparser is gone 2005-08-21 20:50:14 -04:00			`presentation sequences strings styles words ;`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00
			`: html-entities ( -- alist )`
			`[`
[[ car cdr ]] syntax replaces [ car \| cdr ] 2005-01-13 19:49:47 -05:00			`[[ CHAR: < "<" ]]`
			`[[ CHAR: > ">" ]]`
			`[[ CHAR: & "&" ]]`
			`[[ CHAR: ' "'" ]]`
			`[[ CHAR: " """ ]]`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00			`] ;`

			`: chars>entities ( str -- str )`
			`#! Convert <, >, &, ' and " to HTML entities.`
minor cleanups here and there 2005-04-19 20:28:01 -04:00			`[`
generic words are more flexible, sequences cleaned up 2005-05-14 17:18:45 -04:00			`[ dup html-entities assoc [ % ] [ , ] ?ifte ] each`
major cleanup 2005-08-25 15:27:38 -04:00			`] "" make ;`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00
minor UI fixes, updating html streams to not use obsolete style keys 2005-07-11 22:47:38 -04:00			`: hex-color, ( triplet -- )`
			`[ >hex 2 CHAR: 0 pad-left % ] each ;`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00
make-string and make-list replace <> and [, ,] 2004-11-11 15:15:43 -05:00			`: fg-css, ( color -- )`
minor UI fixes, updating html streams to not use obsolete style keys 2005-07-11 22:47:38 -04:00			`"color: #" % hex-color, "; " % ;`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00
minor UI fixes, updating html streams to not use obsolete style keys 2005-07-11 22:47:38 -04:00			`: style-css, ( flag -- )`
big sequences refactoring 2005-07-16 22:16:18 -04:00			`dup [ italic bold-italic ] member?`
minor UI fixes, updating html streams to not use obsolete style keys 2005-07-11 22:47:38 -04:00			`[ "font-style: italic; " % ] when`
big sequences refactoring 2005-07-16 22:16:18 -04:00			`[ bold bold-italic ] member?`
minor UI fixes, updating html streams to not use obsolete style keys 2005-07-11 22:47:38 -04:00			`[ "font-weight: bold; " % ] when ;`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00
make-string and make-list replace <> and [, ,] 2004-11-11 15:15:43 -05:00			`: underline-css, ( flag -- )`
minor UI fixes, updating html streams to not use obsolete style keys 2005-07-11 22:47:38 -04:00			`[ "text-decoration: underline; " % ] when ;`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00
make-string and make-list replace <> and [, ,] 2004-11-11 15:15:43 -05:00			`: size-css, ( size -- )`
more cleanups; split up huge gadgets vocabulary 2005-08-31 21:06:13 -04:00			`"font-size: " % # "; " % ;`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00
make-string and make-list replace <> and [, ,] 2004-11-11 15:15:43 -05:00			`: font-css, ( font -- )`
minor UI fixes, updating html streams to not use obsolete style keys 2005-07-11 22:47:38 -04:00			`"font-family: " % % "; " % ;`
html stream generates css 2004-08-22 16:04:55 -04:00
html-tags imported, file responder shows icons 2004-09-02 19:38:05 -04:00			`: css-style ( style -- )`
make-string and make-list replace <> and [, ,] 2004-11-11 15:15:43 -05:00			`[`
			`[`
minor UI fixes, updating html streams to not use obsolete style keys 2005-07-11 22:47:38 -04:00			`[ foreground fg-css, ]`
			`[ font font-css, ]`
			`[ font-style style-css, ]`
			`[ font-size size-css, ]`
			`[ underline underline-css, ]`
make-string and make-list replace <> and [, ,] 2004-11-11 15:15:43 -05:00			`] assoc-apply`
major cleanup 2005-08-25 15:27:38 -04:00			`] "" make ;`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00
html-tags imported, file responder shows icons 2004-09-02 19:38:05 -04:00			`: span-tag ( style quot -- )`
			`over css-style dup "" = [`
			`drop call`
			`] [`
			`<span style= span> call </span>`
			`] ifte ;`
file responder directory listing 2004-08-30 20:24:19 -04:00
			`: resolve-file-link ( path -- link )`
			`#! The file responder needs relative links not absolute`
			`#! links.`
			`"doc-root" get [`
more sequence cleanups 2005-05-18 16:26:22 -04:00			`?head [ "/" ?head drop ] when`
			`] when* "/" ?tail drop ;`
file responder directory listing 2004-08-30 20:24:19 -04:00
			`: file-link-href ( path -- href )`
major cleanup 2005-08-25 15:27:38 -04:00			`[ "/" % resolve-file-link url-encode % ] "" make ;`
file responder directory listing 2004-08-30 20:24:19 -04:00
html-tags imported, file responder shows icons 2004-09-02 19:38:05 -04:00			`: file-link-tag ( style quot -- )`
handbook updates, and more stream word renamings 2005-07-21 23:36:40 -04:00			`over file swap assoc [`
html-tags imported, file responder shows icons 2004-09-02 19:38:05 -04:00			`<a href= file-link-href a> call </a>`
			`] [`
			`call`
			`] ifte* ;`
file responder directory listing 2004-08-30 20:24:19 -04:00
minor UI fixes, updating html streams to not use obsolete style keys 2005-07-11 22:47:38 -04:00			`: browser-link-href ( word -- href )`
			`dup word-name swap word-vocabulary`
dataflow optimizer work, phasing out 3list/3unlist 2005-07-27 20:13:11 -04:00			`[`
			`"/responder/browser/?vocab=" %`
			`url-encode %`
			`"&word=" %`
			`url-encode %`
major cleanup 2005-08-25 15:27:38 -04:00			`] "" make ;`
add browser style to words to allow browsing source. add browser and cont-responder to factor httpd. add cont-responder tutorial to main doc dicretory. mention location of cont-test.factor in tutorial. change defauly startup location of browser. 2005-02-14 16:44:15 -05:00
			`: browser-link-tag ( style quot -- style )`
minor UI fixes, updating html streams to not use obsolete style keys 2005-07-11 22:47:38 -04:00			`over presented swap assoc dup word? [`
			`<a href= browser-link-href a> call </a>`
add browser style to words to allow browsing source. add browser and cont-responder to factor httpd. add cont-responder tutorial to main doc dicretory. mention location of cont-test.factor in tutorial. change defauly startup location of browser. 2005-02-14 16:44:15 -05:00			`] [`
minor UI fixes, updating html streams to not use obsolete style keys 2005-07-11 22:47:38 -04:00			`drop call`
add browser style to words to allow browsing source. add browser and cont-responder to factor httpd. add cont-responder tutorial to main doc dicretory. mention location of cont-test.factor in tutorial. change defauly startup location of browser. 2005-02-14 16:44:15 -05:00			`] ifte ;`

html-tags imported, file responder shows icons 2004-09-02 19:38:05 -04:00			`: icon-tag ( string style quot -- )`
minor UI fixes, updating html streams to not use obsolete style keys 2005-07-11 22:47:38 -04:00			`over icon swap assoc dup [`
more sequence cleanups 2005-05-18 16:26:22 -04:00			`<img src= "/responder/resource/" swap append img/>`
html-tags imported, file responder shows icons 2004-09-02 19:38:05 -04:00			`#! Ignore the quotation, since no further style`
			`#! can be applied`
			`3drop`
			`] [`
			`drop call`
			`] ifte ;`
html stream generates css 2004-08-22 16:04:55 -04:00
working on layouts; simpler tuple delegation 2005-03-08 22:54:59 -05:00			`TUPLE: html-stream ;`
fix literal dataflow, other fixes 2004-11-28 21:56:58 -05:00
, no longer has the deprecated string append behavior, added stream-write1 generic 2005-07-17 14:48:55 -04:00			`M: html-stream stream-write1 ( char stream -- )`
			`[`
			`dup html-entities assoc [ write ] [ write1 ] ?ifte`
			`] with-wrapper ;`

handbook updates, HTML-format changelog 2005-07-21 21:43:37 -04:00			`M: html-stream stream-format ( str style stream -- )`
fixing matrices; fixing examples 2005-05-03 04:40:13 -04:00			`[`
html-tags imported, file responder shows icons 2004-09-02 19:38:05 -04:00			`[`
			`[`
add browser style to words to allow browsing source. add browser and cont-responder to factor httpd. add cont-responder tutorial to main doc dicretory. mention location of cont-test.factor in tutorial. change defauly startup location of browser. 2005-02-14 16:44:15 -05:00			`[`
			`[ drop chars>entities write ] span-tag`
			`] file-link-tag`
			`] icon-tag`
			`] browser-link-tag`
fixing matrices; fixing examples 2005-05-03 04:40:13 -04:00			`] with-wrapper ;`
fix literal dataflow, other fixes 2004-11-28 21:56:58 -05:00
			`C: html-stream ( stream -- stream )`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00			`#! 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:`
			`#!`
minor UI fixes, updating html streams to not use obsolete style keys 2005-07-11 22:47:38 -04:00			`#! foreground - an rgb triplet in a list`
			`#! background - an rgb triplet in a list`
			`#! font`
			`#! font-style`
			`#! font-size`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00			`#! underline`
simple HTTP client; with-stream* word; various tweaks and cleanups 2005-05-02 00:18:34 -04:00			`#! icon`
			`#! file`
			`#! word`
			`#! vocab`
working on layouts; simpler tuple delegation 2005-03-08 22:54:59 -05:00			`[ >r <wrapper-stream> r> set-delegate ] keep ;`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00
			`: with-html-stream ( quot -- )`
new change word factors out foo get ... foo set pattern 2004-12-04 15:10:46 -05:00			`[ stdio [ <html-stream> ] change call ] with-scope ;`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00
			`: html-document ( title quot -- )`
html-tags imported, file responder shows icons 2004-09-02 19:38:05 -04:00			`swap chars>entities dup`
			`<html>`
			`<head>`
			`<title> write </title>`
			`</head>`
			`<body>`
			`<h1> write </h1>`
			`call`
			`</body>`
			`</html> ;`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00
			`: simple-html-document ( title quot -- )`
html-tags imported, file responder shows icons 2004-09-02 19:38:05 -04:00			`swap [ <pre> with-html-stream </pre> ] html-document ;`