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

Move HTML components to html.components, refactor

db4
Slava Pestov 2008-05-23 17:33:31 -05:00
parent 36b3a411b1
commit f693c69c40
11 changed files with 345 additions and 108 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

145
extra/html/components/components-tests.factor Normal file
View File

@ -0,0 +1,145 @@
IN: html.components.tests
USING: html.components tools.test kernel io.streams.string
io.streams.null accessors ;
[ ] [ blank-values ] unit-test
[ ] [ 3 "hi" set-value ] unit-test
[ 3 ] [ "hi" value ] unit-test
TUPLE: color red green blue ;
[ ] [ 1 2 3 color boa from-tuple ] unit-test
[ 1 ] [ "red" value ] unit-test
[ ] [ "jimmy" "red" set-value ] unit-test
[ "123.5" ] [ 123.5 object>string ] unit-test
[ "jimmy" ] [
[
"red" label render
] with-string-writer
] unit-test
[ ] [ "<jimmy>" "red" set-value ] unit-test
[ "&lt;jimmy&gt;" ] [
[
"red" label render
] with-string-writer
] unit-test
[ "<input type='hidden' name='red' value='<jimmy>'/>" ] [
[
"red" hidden render
] with-string-writer
] unit-test
[ ] [ "'jimmy'" "red" set-value ] unit-test
[ "<input type='text' size='5' name='red' value='&apos;jimmy&apos;'/>" ] [
[
"red" <field> 5 >>size render
] with-string-writer
] unit-test
[ "<input type='password' size='5' name='red' value=''/>" ] [
[
"red" <password> 5 >>size render
] with-string-writer
] unit-test
[ ] [
[
"green" <textarea> render
] with-null-writer
] unit-test
[ ] [
[
"green" <textarea> 25 >>rows 30 >>columns render
] with-null-writer
] unit-test
[ ] [ blank-values ] unit-test
[ ] [ "new york" "city1" set-value ] unit-test
[ ] [
[
"city1"
<choice>
{ "new york" "los angeles" "chicago" } >>choices
render
] with-null-writer
] unit-test
[ ] [ { "los angeles" "new york" } "city2" set-value ] unit-test
[ ] [
[
"city2"
<choice>
{ "new york" "los angeles" "chicago" } >>choices
t >>multiple
render
] with-null-writer
] unit-test
[ ] [
[
"city2"
<choice>
{ "new york" "los angeles" "chicago" } >>choices
t >>multiple
5 >>size
render
] with-null-writer
] unit-test
[ ] [ blank-values ] unit-test
[ ] [ t "delivery" set-value ] unit-test
[ "<input type='checkbox' name='delivery' selected='true'>Delivery</input>" ] [
[
"delivery"
<checkbox>
"Delivery" >>label
render
] with-string-writer
] unit-test
[ ] [ f "delivery" set-value ] unit-test
[ "<input type='checkbox' name='delivery'>Delivery</input>" ] [
[
"delivery"
<checkbox>
"Delivery" >>label
render
] with-string-writer
] unit-test
SINGLETON: link-test
M: link-test link-title drop "<Link Title>" ;
M: link-test link-href drop "http://www.apple.com/foo&bar" ;
[ ] [ link-test "link" set-value ] unit-test
[ "<a href='http://www.apple.com/foo&amp;bar'>&lt;Link Title&gt;</a>" ] [
[ "link" link render ] with-string-writer
] unit-test
[ ] [
"<html>arbitrary <b>markup</b> for the win!</html>" "html" set-value
] unit-test
[ "<html>arbitrary <b>markup</b> for the win!</html>" ] [
[ "html" html render ] with-string-writer
] unit-test

150
extra/html/components/components.factor Normal file
View File

@ -0,0 +1,150 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces io math.parser assocs classes
classes.tuple words arrays sequences splitting mirrors
hashtables combinators continuations math strings
fry locals calendar calendar.format xml.entities validators
html.elements ;
IN: html.components
SYMBOL: values
: value values get at ;
: set-value values get set-at ;
: blank-values H{ } clone values set ;
: from-tuple <mirror> values set ;
: values-tuple values get object>> ;
: object>string ( object -- string )
{
{ [ dup real? ] [ number>string ] }
{ [ dup timestamp? ] [ timestamp>string ] }
{ [ dup string? ] [ ] }
{ [ dup not ] [ drop "" ] }
} cond ;
GENERIC: render* ( value name render -- )
: render ( name renderer -- )
over validation-messages get at [
[ value>> ] [ message>> ] bi
[ -rot render* ] dip
render-error
] [
[ [ value ] keep ] dip render*
] if* ;
<PRIVATE
: render-input ( value name type -- )
<input =type =name object>string =value input/> ;
PRIVATE>
SINGLETON: label
M: label render* 2drop object>string escape-string write ;
SINGLETON: hidden
M: hidden render* drop "hidden" render-input ;
: render-field ( value name size type -- )
<input
=type
[ number>string =size ] when*
=name
object>string =value
input/> ;
TUPLE: field size ;
: <field> ( -- field )
field new ;
M: field render* size>> "text" render-field ;
TUPLE: password size ;
: <password> ( -- password )
password new ;
M: password render*
#! Don't send passwords back to the user
[ drop "" ] 2dip size>> "password" render-field ;
! Text areas
TUPLE: textarea rows columns ;
: <textarea> ( -- renderer )
textarea new ;
M: textarea render*
<textarea
[ rows>> [ number>string =rows ] when* ]
[ columns>> [ number>string =cols ] when* ] bi
=name
textarea>
object>string escape-string write
</textarea> ;
! Choice
TUPLE: choice size choices multiple ;
: <choice> ( -- choice )
choice new ;
: render-option ( text selected? -- )
<option [ "true" =selected ] when option>
escape-string write
</option> ;
: render-options ( options selected -- )
'[ dup , member? render-option ] each ;
M: choice render*
<select
swap =name
dup size>> [ number>string =size ] when*
dup multiple>> [ "true" =multiple ] when
select>
[ choices>> ] [ multiple>> ] bi
[ swap ] [ swap 1array ] if
render-options
</select> ;
! Checkboxes
TUPLE: checkbox label ;
: <checkbox> ( -- checkbox )
checkbox new ;
M: checkbox render*
<input
"checkbox" =type
swap =name
swap [ "true" =selected ] when
input>
label>> escape-string write
</input> ;
! Link components
GENERIC: link-title ( obj -- string )
GENERIC: link-href ( obj -- url )
SINGLETON: link
M: link render*
2drop
<a dup link-href =href a>
link-title object>string escape-string write
</a> ;
! HTML component
SINGLETON: html
M: html render* 2drop write ;

7
extra/html/elements/elements-tests.factor
View File

@ -1,8 +1,5 @@
IN: html.elements.tests
USING: tools.test html html.elements io.streams.string ;
: make-html-string
[ with-html-stream ] with-string-writer ;
USING: tools.test html.elements io.streams.string ;
[ "<a href='h&amp;o'>" ]
[ [ <a "h&o" =href a> ] make-html-string ] unit-test
[ [ <a "h&o" =href a> ] with-string-writer ] unit-test

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

@ -57,6 +57,8 @@ SYMBOL: html
: print-html ( str -- )
write-html "\n" write-html ;
<<
: html-word ( name def effect -- )
#! Define 'word creating' word to allow
#! dynamically creating words.
@ -137,30 +139,46 @@ SYMBOL: html
dup "=" prepend swap
[ write-attr ] curry attribute-effect html-word ;
! Define some closed HTML tags
[
! Define some closed HTML tags
[
"h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
"ol" "li" "form" "a" "p" "html" "head" "body" "title"
"b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
"script" "div" "span" "select" "option" "style" "input"
] [ define-closed-html-word ] each
"h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
"ol" "li" "form" "a" "p" "html" "head" "body" "title"
"b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
"script" "div" "span" "select" "option" "style" "input"
] [ define-closed-html-word ] each
! Define some open HTML tags
[
"input"
"br"
"link"
"img"
] [ define-open-html-word ] each
! Define some open HTML tags
[
"input"
"br"
"link"
"img"
] [ define-open-html-word ] each
! Define some attributes
[
"method" "action" "type" "value" "name"
"size" "href" "class" "border" "rows" "cols"
"id" "onclick" "style" "valign" "accesskey"
"src" "language" "colspan" "onchange" "rel"
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
"media" "title" "multiple"
] [ define-attribute-word ] each
] with-compilation-unit
! Define some attributes
[
"method" "action" "type" "value" "name"
"size" "href" "class" "border" "rows" "cols"
"id" "onclick" "style" "valign" "accesskey"
"src" "language" "colspan" "onchange" "rel"
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
"media" "title" "multiple"
] [ define-attribute-word ] each
>>
: xhtml-preamble ( -- )
"<?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 ;
: simple-page ( title quot -- )
#! Call the quotation, with all output going to the
#! body of an html page with the given title.
xhtml-preamble
<html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
<head> <title> swap write </title> </head>
<body> call </body>
</html> ;
: render-error ( message -- )
<span "error" =class span> escape-string write </span> ;

0
extra/html/authors.txt → extra/html/streams/authors.txt
View File

7
extra/html/html-tests.factor → extra/html/streams/streams-tests.factor
View File

@ -1,6 +1,7 @@
USING: html http io io.streams.string io.styles kernel
namespaces tools.test xml.writer sbufs sequences html.private ;
IN: html.tests
USING: html.streams html.streams.private
io io.streams.string io.styles kernel
namespaces tools.test xml.writer sbufs sequences ;
IN: html.streams.tests
: make-html-string
[ with-html-stream ] with-string-writer ; inline

73
extra/html/html.factor → extra/html/streams/streams.factor
View File

@ -4,7 +4,7 @@ USING: generic assocs help http io io.styles io.files continuations
io.streams.string kernel math math.order math.parser namespaces
quotations assocs sequences strings words html.elements
xml.entities sbufs continuations destructors ;
IN: html
IN: html.streams
GENERIC: browser-link-href ( presented -- href )
@ -192,76 +192,5 @@ M: html-stream make-cell-stream ( style stream -- stream' )
M: html-stream stream-nl ( stream -- )
dup test-last-div? [ drop ] [ [ <br/> ] with-output-stream* ] if ;
! Utilities
: with-html-stream ( quot -- )
output-stream get <html-stream> swap with-output-stream* ; inline
: xhtml-preamble
"<?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 ;
: html-document ( body-quot head-quot -- )
#! head-quot is called to produce output to go
#! in the html head portion of the document.
#! body-quot is called to produce output to go
#! in the html body portion of the document.
xhtml-preamble
<html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
<head> call </head>
<body> call </body>
</html> ;
: default-css ( -- )
<link
"stylesheet" =rel "text/css" =type
"/responder/resources/extra/html/stylesheet.css" =href
link/> ;
: simple-html-document ( title quot -- )
swap [
<title> write </title>
default-css
] html-document ;
: vertical-layout ( list -- )
#! Given a list of HTML components, arrange them vertically.
<table>
[ <tr> <td> call </td> </tr> ] each
</table> ;
: horizontal-layout ( list -- )
#! Given a list of HTML components, arrange them horizontally.
<table>
<tr "top" =valign tr> [ <td> call </td> ] each </tr>
</table> ;
: button ( label -- )
#! Output an HTML submit button with the given label.
<input "submit" =type =value input/> ;
: paragraph ( str -- )
#! Output the string as an html paragraph
<p> write </p> ;
: simple-page ( title quot -- )
#! Call the quotation, with all output going to the
#! body of an html page with the given title.
<html>
<head> <title> swap write </title> </head>
<body> call </body>
</html> ;
: styled-page ( title stylesheet-quot quot -- )
#! Call the quotation, with all output going to the
#! body of an html page with the given title. stylesheet-quot
#! is called to generate the required stylesheet.
<html>
<head>
<title> rot write </title>
swap call
</head>
<body> call </body>
</html> ;
: render-error ( message -- )
<span "error" =class span> escape-string write </span> ;

0
extra/html/summary.txt → extra/html/streams/summary.txt
View File

0
extra/html/tags.txt → extra/html/streams/tags.txt
View File

4
extra/html/stylesheet.css
View File

@ -1,4 +0,0 @@
a:link { text-decoration: none; color: black; }
a:visited { text-decoration: none; color: black; }
a:active { text-decoration: none; color: black; }
a:hover { text-decoration: underline; color: black; }

1
extra/validators/validators.factor
View File

@ -56,6 +56,7 @@ IN: validators
: v-email ( str -- str )
#! From http://www.regular-expressions.info/email.html
60 v-max-length
"e-mail"
R' [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}'i
v-regexp ;