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

Further html fixes

db4
Slava Pestov 2008-01-11 01:01:23 -05:00
parent eb2a6a7d22
commit 53ae4f9133
2 changed files with 26 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -54,10 +54,16 @@ M: funky browser-link-href
] make-html-string ] make-html-string
] unit-test ] unit-test
[ "<div style='background-color: #ff00ff; '>cdr</div>" ] [ "<div style='background-color: #ff00ff; white-space: pre; font-family: monospace; '>cdr</div>" ]
[ [
[ [
H{ { page-color { 1 0 1 1 } } } H{ { page-color { 1 0 1 1 } } }
[ "cdr" write ] with-nesting [ "cdr" write ] with-nesting
] make-html-string ] make-html-string
] unit-test ] unit-test
[
"<div style='white-space: pre; font-family: monospace; '></div>"
] [
[ H{ } [ ] with-nesting nl ] make-html-string
] unit-test

29
extra/html/html.factor
View File

@ -10,7 +10,19 @@ GENERIC: browser-link-href ( presented -- href )
M: object browser-link-href drop f ; M: object browser-link-href drop f ;
TUPLE: html-stream ; TUPLE: html-stream last-div? ;
! A hack: stream-nl after with-nesting or tabular-output is
! ignored, so that HTML stream output looks like UI pane output
: test-last-div? ( stream -- ? )
dup html-stream-last-div?
f rot set-html-stream-last-div? ;
: not-a-div ( stream -- stream )
dup test-last-div? drop ; inline
: a-div ( stream -- straem )
t over set-html-stream-last-div? ; inline
: <html-stream> ( stream -- stream ) : <html-stream> ( stream -- stream )
html-stream construct-delegate ; html-stream construct-delegate ;
@ -94,7 +106,7 @@ TUPLE: html-sub-stream style stream ;
TUPLE: html-span-stream ; TUPLE: html-span-stream ;
M: html-span-stream stream-close M: html-span-stream stream-close
end-sub-stream format-html-span ; end-sub-stream not-a-div format-html-span ;
: border-css, ( border -- ) : border-css, ( border -- )
"border: 1px solid #" % hex-color, "; " % ; "border: 1px solid #" % hex-color, "; " % ;
@ -109,10 +121,7 @@ M: html-span-stream stream-close
page-color [ bg-css, ] apply-style page-color [ bg-css, ] apply-style
border-color [ border-css, ] apply-style border-color [ border-css, ] apply-style
border-width [ padding-css, ] apply-style border-width [ padding-css, ] apply-style
! FIXME: This is a hack for webapps.help wrap-margin over at pre-css,
building get empty? [
wrap-margin over at pre-css,
] unless
] make-css ; ] make-css ;
: div-tag ( style quot -- ) : div-tag ( style quot -- )
@ -130,7 +139,7 @@ M: html-span-stream stream-close
TUPLE: html-block-stream ; TUPLE: html-block-stream ;
M: html-block-stream stream-close ( quot style stream -- ) M: html-block-stream stream-close ( quot style stream -- )
end-sub-stream format-html-div ; end-sub-stream a-div format-html-div ;
: border-spacing-css, : border-spacing-css,
"padding: " % first2 max 2 /i # "px; " % ; "padding: " % first2 max 2 /i # "px; " % ;
@ -154,7 +163,7 @@ M: html-stream stream-write1 ( char stream -- )
>r 1string r> stream-write ; >r 1string r> stream-write ;
M: html-stream stream-write ( str stream -- ) M: html-stream stream-write ( str stream -- )
>r escape-string r> delegate stream-write ; not-a-div >r escape-string r> delegate stream-write ;
M: html-stream make-span-stream ( style stream -- stream' ) M: html-stream make-span-stream ( style stream -- stream' )
html-span-stream <html-sub-stream> ; html-span-stream <html-sub-stream> ;
@ -167,7 +176,7 @@ M: html-stream make-block-stream ( style stream -- stream' )
html-block-stream <html-sub-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 -- )
[ a-div [
<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>
@ -181,7 +190,7 @@ M: html-stream make-cell-stream ( style stream -- stream' )
(html-sub-stream) ; (html-sub-stream) ;
M: html-stream stream-nl ( stream -- ) M: html-stream stream-nl ( stream -- )
[ <br/> ] with-stream* ; dup test-last-div? [ drop ] [ [ <br/> ] with-stream* ] if ;
! Utilities ! Utilities
: with-html-stream ( quot -- ) : with-html-stream ( quot -- )