steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Updating HTML output for latest stream protocol

release
Slava Pestov 2007-09-25 20:30:33 -04:00
parent b9ada9413f
commit e0318f769d
5 changed files with 159 additions and 1907 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
extra/html/elements/elements.factor
View File

@ -152,5 +152,5 @@ SYMBOL: html
"size" "href" "class" "border" "rows" "cols" "size" "href" "class" "border" "rows" "cols"
"id" "onclick" "style" "valign" "accesskey" "id" "onclick" "style" "valign" "accesskey"
"src" "language" "colspan" "onchange" "rel" "src" "language" "colspan" "onchange" "rel"
"width" "selected" "onsubmit" "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
] [ define-attribute-word ] each ] [ define-attribute-word ] each

65
extra/html/html-tests.factor
View File

@ -1,30 +1,39 @@
USING: html http io io.streams.string io.styles kernel USING: html http io io.streams.string io.styles kernel
namespaces tools.test xml.writer ; namespaces tools.test xml.writer sbufs sequences html.private ;
IN: temporary IN: temporary
[ : make-html-string
"/responder/foo?z=%20" [ with-html-stream ] string-out ;
] [
"/responder/foo" H{ { "z" " " } } build-url [ ] [
512 <sbuf> <html-stream> drop
] unit-test ] unit-test
[ [ "" ] [
"&lt;html&gt;&amp;&apos;sgml&apos;" [ "" write ] make-html-string
] [ "<html>&'sgml'" chars>entities ] unit-test ] unit-test
[ "" ] [ "a" ] [
[ [ CHAR: a write1 ] make-html-string
] unit-test
[ "&lt;" ] [
[ "<" write ] make-html-string
] unit-test
[ "<" ] [
[ "<" H{ } stdio get format-html-span ] make-html-string
] unit-test
TUPLE: funky town ;
M: funky browser-link-href
"http://www.funky-town.com/" swap funky-town append ;
[ "<a href='http://www.funky-town.com/austin'>&lt;</a>" ] [
[ [
H{ } [ drop ] span-tag "<" "austin" funky construct-boa write-object
] string-out ] make-html-string
] unit-test
: html-format ( string style -- string )
[ format ] with-html-stream ;
[ "hello world" ]
[
[ "hello world" H{ } html-format ] string-out
] unit-test ] unit-test
[ "<span style='font-family: monospace; '>car</span>" ] [ "<span style='font-family: monospace; '>car</span>" ]
@ -32,8 +41,8 @@ IN: temporary
[ [
"car" "car"
H{ { font "monospace" } } H{ { font "monospace" } }
html-format format
] string-out ] make-html-string
] unit-test ] unit-test
[ "<span style='color: #ff00ff; '>car</span>" ] [ "<span style='color: #ff00ff; '>car</span>" ]
@ -41,6 +50,14 @@ IN: temporary
[ [
"car" "car"
H{ { foreground { 1 0 1 1 } } } H{ { foreground { 1 0 1 1 } } }
html-format format
] string-out ] make-html-string
] unit-test
[ "<div style='background-color: #ff00ff; '>cdr</div>" ]
[
[
H{ { page-color { 1 0 1 1 } } }
[ "cdr" write ] with-nesting
] make-html-string
] unit-test ] unit-test

218
extra/html/html.factor
View File

@ -1,10 +1,43 @@
! Copyright (C) 2004, 2006 Slava Pestov. ! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: generic assocs help http io io.styles io.files io.streams.string USING: generic assocs help http io io.styles io.files
kernel math math.parser namespaces xml.writer quotations io.streams.string kernel math math.parser namespaces
assocs sequences strings words html.elements ; quotations assocs sequences strings words html.elements
xml.writer sbufs ;
IN: html IN: html
GENERIC: browser-link-href ( presented -- href )
M: object browser-link-href drop f ;
TUPLE: html-stream ;
: <html-stream> ( stream -- stream )
html-stream construct-delegate ;
<PRIVATE
TUPLE: html-sub-stream style stream ;
: (html-sub-stream) ( style stream -- stream )
html-sub-stream construct-boa
512 <sbuf> <html-stream> over set-delegate ;
: <html-sub-stream> ( style stream class -- stream )
>r (html-sub-stream) r> construct-delegate ; inline
: end-sub-stream ( substream -- string style stream )
dup delegate >string
over html-sub-stream-style
rot html-sub-stream-stream ;
: delegate-write ( string -- )
stdio get delegate stream-write ;
: object-link-tag ( style quot -- )
presented pick at browser-link-href
[ <a =href a> call </a> ] [ call ] if* ; inline
: hex-color, ( triplet -- ) : hex-color, ( triplet -- )
3 head-slice 3 head-slice
[ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ; [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ;
@ -28,166 +61,149 @@ IN: html
: font-css, ( font -- ) : font-css, ( font -- )
"font-family: " % % "; " % ; "font-family: " % % "; " % ;
: hash-apply ( value-hash quot-hash -- ) : apply-style ( style key quot -- style gadget )
#! Looks up the key of each pair in the first list in the >r over at r> when* ; inline
#! second list to produce a quotation. The quotation is
#! applied to the value of the pair. If there is no : make-css ( style quot -- str )
#! corresponding quotation, the value is popped off the "" make nip ; inline
#! stack.
[ swapd at dup [ call ] [ 2drop ] if ] curry assoc-each ;
: span-css-style ( style -- str ) : span-css-style ( style -- str )
[ [
H{ foreground [ fg-css, ] apply-style
{ foreground [ fg-css, ] } background [ bg-css, ] apply-style
{ background [ bg-css, ] } font [ font-css, ] apply-style
{ font [ font-css, ] } font-style [ style-css, ] apply-style
{ font-style [ style-css, ] } font-size [ size-css, ] apply-style
{ font-size [ size-css, ] } ] make-css ;
} hash-apply
] "" make ;
: span-tag ( style quot -- ) : span-tag ( style quot -- )
over span-css-style dup empty? [ over span-css-style dup empty? [
drop call drop call
] [ ] [
<span =style span> call </span> <span =style span> call </span>
] if ; ] if ; inline
: format-html-span ( string style stream -- )
[
[ [ drop delegate-write ] span-tag ] object-link-tag
] with-stream* ;
TUPLE: html-span-stream ;
M: html-span-stream stream-close
end-sub-stream format-html-span ;
: border-css, ( border -- ) : border-css, ( border -- )
"border: 1px solid #" % hex-color, "; " % ; "border: 1px solid #" % hex-color, "; " % ;
: padding-css, ( padding -- ) "padding: " % # "px; " % ; : padding-css, ( padding -- ) "padding: " % # "px; " % ;
: pre-css, ( -- ) : pre-css, ( margin -- )
"white-space: pre; font-family: monospace; " % ; [ "white-space: pre; font-family: monospace; " % ] unless ;
: div-css-style ( style -- str ) : div-css-style ( style -- str )
[ [
H{ page-color [ bg-css, ] apply-style
{ page-color [ bg-css, ] } border-color [ border-css, ] apply-style
{ border-color [ border-css, ] } border-width [ padding-css, ] apply-style
{ border-width [ padding-css, ] } wrap-margin [ pre-css, ] apply-style
{ wrap-margin [ [ pre-css, ] unless ] } ] make-css ;
} hash-apply
] "" make ;
: div-tag ( style quot -- ) : div-tag ( style quot -- )
swap div-css-style dup empty? [ swap div-css-style dup empty? [
drop call drop call
] [ ] [
<div =style div> call </div> <div =style div> call </div>
] if ; ] if ; inline
: do-escaping ( string style -- string ) : format-html-div ( string style stream -- )
html swap at [ chars>entities ] unless ;
GENERIC: browser-link-href ( presented -- href )
M: object browser-link-href drop f ;
: object-link-tag ( style quot -- )
presented pick at browser-link-href
[ <a =href a> call </a> ] [ call ] if* ;
TUPLE: nested-stream ;
: <nested-stream> ( stream -- stream )
nested-stream construct-delegate ;
M: nested-stream stream-close drop ;
TUPLE: html-stream ;
: <html-stream> ( stream -- stream )
html-stream construct-delegate ;
M: html-stream stream-write1 ( char stream -- )
>r 1string r> stream-write ;
: delegate-write delegate stream-write ;
M: html-stream stream-write ( str stream -- )
>r chars>entities r> delegate-write ;
: with-html-style ( quot style stream -- )
[ [ swap span-tag ] object-link-tag ] with-stream* ; inline
M: html-stream with-stream-style ( quot style stream -- )
[ drop call ] -rot with-html-style ;
M: html-stream stream-format ( str style stream -- )
[ do-escaping stdio get delegate-write ] -rot
with-html-style ;
: with-html-stream ( quot -- )
stdio get <html-stream> swap with-stream* ;
M: html-stream with-nested-stream ( quot style stream -- )
[ [
[ [ [ delegate-write ] div-tag ] object-link-tag
[
stdio get <nested-stream> swap with-stream*
] div-tag
] object-link-tag
] with-stream* ; ] with-stream* ;
TUPLE: html-block-stream ;
M: html-block-stream stream-close ( quot style stream -- )
end-sub-stream format-html-div ;
: border-spacing-css, : border-spacing-css,
"padding: " % first2 max 2 /i # "px; " % ; "padding: " % first2 max 2 /i # "px; " % ;
: table-style ( style -- str ) : table-style ( style -- str )
[ [
H{ table-border [ border-css, ] apply-style
{ table-border [ border-css, ] } table-gap [ border-spacing-css, ] apply-style
{ table-gap [ border-spacing-css, ] } ] make-css ;
} hash-apply
] "" make ;
: table-attrs ( style -- ) : table-attrs ( style -- )
table-style " border-collapse: collapse;" append =style ; table-style " border-collapse: collapse;" append =style ;
: do-escaping ( string style -- string )
html swap at [ chars>entities ] unless ;
PRIVATE>
! Stream protocol
M: html-stream stream-write1 ( char stream -- )
>r 1string r> stream-write ;
M: html-stream stream-write ( str stream -- )
>r chars>entities r> delegate stream-write ;
M: html-stream make-span-stream ( style stream -- stream' )
html-span-stream <html-sub-stream> ;
M: html-stream stream-format ( str style stream -- )
>r html over at [ >r chars>entities r> ] unless r>
format-html-span ;
M: html-stream make-block-stream ( style stream -- stream' )
html-block-stream <html-sub-stream> ;
M: html-stream stream-write-table ( grid style stream -- ) M: html-stream stream-write-table ( grid style stream -- )
[ [
<table dup table-attrs table> swap [ <table dup table-attrs table> swap [
<tr> [ <tr> [
<td "top" =valign swap table-style =style td> <td "top" =valign swap table-style =style td>
write-html >string write-html
</td> </td>
] curry* each </tr> ] curry* each </tr>
] curry* each </table> ] curry* each </table>
] with-stream* ; ] with-stream* ;
M: html-stream make-table-cell ( quot style stream -- table-cell ) M: html-stream make-cell-stream ( style stream -- stream' )
2drop [ with-html-stream ] string-out ; (html-sub-stream) ;
M: html-stream stream-nl [ <br/> ] with-stream* ; M: html-stream stream-nl ( stream -- )
[ <br/> ] with-stream* ;
: default-css ( -- ) ! Utilities
<link : with-html-stream ( quot -- )
"stylesheet" =rel "text/css" =type stdio get <html-stream> swap with-stream* ;
"/responder/resources/stylesheet.css" =href
link/> ;
: xhtml-preamble : xhtml-preamble
"<?xml version=\"1.0\"?>" write-html "<?xml version=\"1.0\"?>" write-html
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" write-html ; "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" write-html ;
: html-document* ( body-quot head-quot -- ) : html-document ( body-quot head-quot -- )
#! head-quot is called to produce output to go #! head-quot is called to produce output to go
#! in the html head portion of the document. #! in the html head portion of the document.
#! body-quot is called to produce output to go #! body-quot is called to produce output to go
#! in the html body portion of the document. #! in the html body portion of the document.
xhtml-preamble xhtml-preamble
<html " xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\" lang=\"en\"" write-html html> <html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
<head> call </head> <head> call </head>
<body> call </body> <body> call </body>
</html> ; </html> ;
: html-document ( title quot -- ) : default-css ( -- )
<link
"stylesheet" =rel "text/css" =type
"/responder/resources/extra/html/stylesheet.css" =href
link/> ;
: simple-html-document ( title quot -- )
swap [ swap [
<title> write </title> <title> write </title>
default-css default-css
] html-document* ; ] html-document ;
: simple-html-document ( title quot -- )
swap [ <pre> with-html-stream </pre> ] html-document ;

0
extra/http/server/resources/stylesheet.css → extra/html/stylesheet.css
View File

1781
extra/http/server/resources/prototype.js vendored
View File

File diff suppressed because it is too large Load Diff