Move HTML components to html.components, refactor
Slava Pestov
parent
36b3a411b1
commit
f693c69c40
|
|
@ -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
|
||||||
|
|
||||||
|
[ "<jimmy>" ] [
|
||||||
|
[
|
||||||
|
"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=''jimmy''/>" ] [
|
||||||
|
[
|
||||||
|
"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&bar'><Link Title></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
|
||||||
|
|
@ -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 ;
|
||||||
|
|
@ -1,8 +1,5 @@
|
||||||
IN: html.elements.tests
|
IN: html.elements.tests
|
||||||
USING: tools.test html html.elements io.streams.string ;
|
USING: tools.test html.elements io.streams.string ;
|
||||||
|
|
||||||
: make-html-string
|
|
||||||
[ with-html-stream ] with-string-writer ;
|
|
||||||
|
|
||||||
[ "<a href='h&o'>" ]
|
[ "<a href='h&o'>" ]
|
||||||
[ [ <a "h&o" =href a> ] make-html-string ] unit-test
|
[ [ <a "h&o" =href a> ] with-string-writer ] unit-test
|
||||||
|
|
|
||||||
|
|
@ -57,6 +57,8 @@ SYMBOL: html
|
||||||
: print-html ( str -- )
|
: print-html ( str -- )
|
||||||
write-html "\n" write-html ;
|
write-html "\n" write-html ;
|
||||||
|
|
||||||
|
<<
|
||||||
|
|
||||||
: html-word ( name def effect -- )
|
: html-word ( name def effect -- )
|
||||||
#! Define 'word creating' word to allow
|
#! Define 'word creating' word to allow
|
||||||
#! dynamically creating words.
|
#! dynamically creating words.
|
||||||
|
|
@ -137,30 +139,46 @@ SYMBOL: html
|
||||||
dup "=" prepend swap
|
dup "=" prepend swap
|
||||||
[ write-attr ] curry attribute-effect html-word ;
|
[ 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"
|
||||||
"h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
|
"b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
|
||||||
"ol" "li" "form" "a" "p" "html" "head" "body" "title"
|
"script" "div" "span" "select" "option" "style" "input"
|
||||||
"b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
|
] [ define-closed-html-word ] each
|
||||||
"script" "div" "span" "select" "option" "style" "input"
|
|
||||||
] [ define-closed-html-word ] each
|
|
||||||
|
|
||||||
! Define some open HTML tags
|
! Define some open HTML tags
|
||||||
[
|
[
|
||||||
"input"
|
"input"
|
||||||
"br"
|
"br"
|
||||||
"link"
|
"link"
|
||||||
"img"
|
"img"
|
||||||
] [ define-open-html-word ] each
|
] [ define-open-html-word ] each
|
||||||
|
|
||||||
! Define some attributes
|
! Define some attributes
|
||||||
[
|
[
|
||||||
"method" "action" "type" "value" "name"
|
"method" "action" "type" "value" "name"
|
||||||
"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" "xmlns" "lang" "xml:lang"
|
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
|
||||||
"media" "title" "multiple"
|
"media" "title" "multiple"
|
||||||
] [ define-attribute-word ] each
|
] [ define-attribute-word ] each
|
||||||
] with-compilation-unit
|
|
||||||
|
>>
|
||||||
|
|
||||||
|
: 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> ;
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,7 @@
|
||||||
USING: html http io io.streams.string io.styles kernel
|
USING: html.streams html.streams.private
|
||||||
namespaces tools.test xml.writer sbufs sequences html.private ;
|
io io.streams.string io.styles kernel
|
||||||
IN: html.tests
|
namespaces tools.test xml.writer sbufs sequences ;
|
||||||
|
IN: html.streams.tests
|
||||||
|
|
||||||
: make-html-string
|
: make-html-string
|
||||||
[ with-html-stream ] with-string-writer ; inline
|
[ with-html-stream ] with-string-writer ; inline
|
||||||
|
|
@ -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
|
io.streams.string kernel math math.order math.parser namespaces
|
||||||
quotations assocs sequences strings words html.elements
|
quotations assocs sequences strings words html.elements
|
||||||
xml.entities sbufs continuations destructors ;
|
xml.entities sbufs continuations destructors ;
|
||||||
IN: html
|
IN: html.streams
|
||||||
|
|
||||||
GENERIC: browser-link-href ( presented -- href )
|
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 -- )
|
M: html-stream stream-nl ( stream -- )
|
||||||
dup test-last-div? [ drop ] [ [ <br/> ] with-output-stream* ] if ;
|
dup test-last-div? [ drop ] [ [ <br/> ] with-output-stream* ] if ;
|
||||||
|
|
||||||
! Utilities
|
|
||||||
: with-html-stream ( quot -- )
|
: with-html-stream ( quot -- )
|
||||||
output-stream get <html-stream> swap with-output-stream* ; inline
|
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> ;
|
|
||||||
|
|
@ -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; }
|
|
||||||
|
|
@ -56,6 +56,7 @@ IN: validators
|
||||||
|
|
||||||
: v-email ( str -- str )
|
: v-email ( str -- str )
|
||||||
#! From http://www.regular-expressions.info/email.html
|
#! From http://www.regular-expressions.info/email.html
|
||||||
|
60 v-max-length
|
||||||
"e-mail"
|
"e-mail"
|
||||||
R' [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}'i
|
R' [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}'i
|
||||||
v-regexp ;
|
v-regexp ;
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue