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 kernel lists namespaces presentation sequences
stdio streams strings unparser url-encoding ;

: html-entities ( -- alist )
    [
        [[ CHAR: < "&lt;"   ]]
        [[ CHAR: > "&gt;"   ]]
        [[ CHAR: & "&amp;"  ]]
        [[ CHAR: ' "&apos;" ]]
        [[ CHAR: " "&quot;" ]]
    ] ;

: char>entity ( ch -- str )
    dup >r html-entities assoc dup r> ? ;

: chars>entities ( str -- str )
    #! Convert <, >, &, ' and " to HTML entities.
    [
        [
            dup html-entities assoc [ % ] [ , ] ?ifte
        ] seq-each
    ] make-string ;

: >hex-color ( triplet -- hex )
    [ CHAR: # , [ >hex 2 CHAR: 0 pad % ] each ] make-string ;

: fg-css, ( color -- )
    "color: " , >hex-color , "; " , ;

: bold-css, ( flag -- )
    [ "font-weight: bold; " , ] when ;

: italics-css, ( flag -- )
    [ "font-style: italic; " , ] when ;

: underline-css, ( flag -- )
    [ "text-decoration: underline; " , ] when ;

: size-css, ( size -- )
    "font-size: " , unparse , "; " , ;

: font-css, ( font -- )
    "font-family: " , , "; " , ;

: css-style ( style -- )
    [
        [
            [ "fg"        fg-css, ]
            [ "bold"      bold-css, ]
            [ "italics"   italics-css, ]
            [ "underline" underline-css, ]
            [ "size"      size-css, ]
            [ "font"      font-css, ]
        ] assoc-apply
    ] make-string ;

: 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 [
        ?string-head [ "/" ?string-head drop ] when
    ] when* "/" ?string-tail drop ;

: file-link-href ( path -- href )
    [ "/" , resolve-file-link url-encode , ] make-string ;

: file-link-tag ( style quot -- )
    over "file-link" swap assoc [
        <a href= file-link-href a> call </a>
    ] [
        call
    ] ifte* ;

: browser-link-href ( style -- href )
    dup "browser-link-word" swap assoc url-encode
    swap "browser-link-vocab" swap assoc url-encode
    "responder" get url-encode
    [ "/responder/" , , "/?vocab=" , , "&word=" , , ] make-string ;

: browser-link-tag ( style quot -- style )
    over "browser-link-word" swap assoc [
        <a href= over browser-link-href a> call </a>
    ] [
        call
    ] ifte ;

: icon-tag ( string style quot -- )
    over "icon" swap assoc dup [
        <img src= "/responder/resource/" swap cat2 img/>
        #! Ignore the quotation, since no further style
        #! can be applied
        3drop
    ] [
        drop call
    ] ifte ;

TUPLE: html-stream ;

M: html-stream stream-write-attr ( str style stream -- )
    wrapper-stream-scope [
        [
            [
                [
                    [ drop chars>entities write ] span-tag
                ] file-link-tag
            ] icon-tag
        ] browser-link-tag
    ] bind ;

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:
    #!
    #! link - an object path
    #! fg - an rgb triplet in a list
    #! bg - an rgb triplet in a list
    #! bold
    #! italics
    #! underline
    #! size
    #! link - an object path
    [ >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`
minor cleanups here and there 2005-04-19 20:28:01 -04:00			`USING: generic kernel lists namespaces presentation sequences`
			`stdio streams strings unparser url-encoding ;`
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			`] ;`

<namespace> [ ... ] bind ==> [ ... ] with-scope 2004-08-08 21:24:01 -04:00			`: char>entity ( ch -- str )`
			`dup >r html-entities assoc dup r> ? ;`

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			`[`
			`[`
			`dup html-entities assoc [ % ] [ , ] ?ifte`
			`] seq-each`
			`] make-string ;`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00
html stream generates css 2004-08-22 16:04:55 -04:00			`: >hex-color ( triplet -- hex )`
minor cleanups here and there 2005-04-19 20:28:01 -04:00			`[ CHAR: # , [ >hex 2 CHAR: 0 pad % ] each ] make-string ;`
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 -- )`
			`"color: " , >hex-color , "; " , ;`
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			`: bold-css, ( flag -- )`
			`[ "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			`: italics-css, ( flag -- )`
			`[ "font-style: italic; " , ] 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 -- )`
			`[ "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 -- )`
			`"font-size: " , unparse , "; " , ;`
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 -- )`
			`"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			`[`
			`[`
			`[ "fg" fg-css, ]`
			`[ "bold" bold-css, ]`
			`[ "italics" italics-css, ]`
			`[ "underline" underline-css, ]`
			`[ "size" size-css, ]`
			`[ "font" font-css, ]`
			`] assoc-apply`
			`] make-string ;`
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 [`
hashtables were sized wrong; rename str- words to string- 2005-03-05 16:33:40 -05:00			`?string-head [ "/" ?string-head drop ] when`
			`] when* "/" ?string-tail drop ;`
file responder directory listing 2004-08-30 20:24:19 -04:00
			`: file-link-href ( path -- href )`
make-string and make-list replace <> and [, ,] 2004-11-11 15:15:43 -05:00			`[ "/" , resolve-file-link url-encode , ] make-string ;`
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 -- )`
			`over "file-link" swap assoc [`
			`<a href= file-link-href a> call </a>`
			`] [`
			`call`
			`] ifte* ;`
file responder directory listing 2004-08-30 20:24:19 -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			`: browser-link-href ( style -- href )`
			`dup "browser-link-word" swap assoc url-encode`
			`swap "browser-link-vocab" swap assoc url-encode`
			`"responder" get url-encode`
			`[ "/responder/" , , "/?vocab=" , , "&word=" , , ] make-string ;`

			`: browser-link-tag ( style quot -- style )`
			`over "browser-link-word" swap assoc [`
			`<a href= over browser-link-href a> call </a>`
			`] [`
			`call`
			`] ifte ;`

html-tags imported, file responder shows icons 2004-09-02 19:38:05 -04:00			`: icon-tag ( string style quot -- )`
			`over "icon" swap assoc dup [`
html link fixes 2004-09-23 16:50:30 -04:00			`<img src= "/responder/resource/" swap cat2 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
stream word renaming 2005-02-14 22:15:02 -05:00			`M: html-stream stream-write-attr ( str style stream -- )`
tuples used for i/o streams, removed traits metaclass 2005-01-30 15:57:25 -05:00			`wrapper-stream-scope [`
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`
generic.factor cleanups; started generalized dispatching 2004-12-11 18:18:43 -05:00			`] bind ;`
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:`
			`#!`
			`#! link - an object path`
			`#! fg - an rgb triplet in a list`
			`#! bg - an rgb triplet in a list`
			`#! bold`
html stream generates css 2004-08-22 16:04:55 -04:00			`#! italics`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00			`#! underline`
html stream generates css 2004-08-22 16:04:55 -04:00			`#! size`
			`#! link - an object path`
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 ;`