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

Clean up some web framework code

db4
Slava Pestov 2008-09-29 04:10:00 -05:00
parent 46a530c58e
commit dc1d7c76b7
10 changed files with 52 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
basis/furnace/chloe-tags/chloe-tags.factor
View File

@ -59,8 +59,12 @@ CHLOE: write-atom drop [ write-atom-feeds ] [code] ;
attrs>> '[ [ [ _ ] dip link-attr ] each-responder ] [code] ; attrs>> '[ [ [ _ ] dip link-attr ] each-responder ] [code] ;
: a-start-tag ( tag -- ) : a-start-tag ( tag -- )
[ compile-link-attrs ] [ compile-a-url ] bi [ <a ] [code]
[ <a =href a> ] [code] ; [ non-chloe-attrs-only compile-attrs ]
[ compile-link-attrs ]
[ compile-a-url ]
tri
[ =href a> ] [code] ;
: a-end-tag ( tag -- ) : a-end-tag ( tag -- )
drop [ </a> ] [code] ; drop [ </a> ] [code] ;
@ -70,6 +74,9 @@ CHLOE: a
[ a-start-tag ] [ compile-children ] [ a-end-tag ] tri [ a-start-tag ] [ compile-children ] [ a-end-tag ] tri
] compile-with-scope ; ] compile-with-scope ;
CHLOE: base
compile-a-url [ <base =href base/> ] [code] ;
: compile-hidden-form-fields ( for -- ) : compile-hidden-form-fields ( for -- )
'[ '[
<div "display: none;" =style div> <div "display: none;" =style div>

2
basis/html/components/components-docs.factor
View File

@ -29,7 +29,7 @@ HELP: textarea
{ $class-description "Text area components display a multi-line editor for a string value. The " { $slot "rows" } " and " { $slot "cols" } " properties determine the size of the text area." } ; { $class-description "Text area components display a multi-line editor for a string value. The " { $slot "rows" } " and " { $slot "cols" } " properties determine the size of the text area." } ;
HELP: link HELP: link
{ $description "Link components render a link to an object stored at a value, with the link title and URL determined by the " { $link link-title } " and " { $link link-href } " generic words." } ; { $description "Link components render a link to an object stored at a value, with the link title and URL determined by the " { $link link-title } " and " { $link link-href } " generic words. The optional " { $slot "target" } " slot is a target frame to open the link in." } ;
HELP: link-title HELP: link-title
{ $values { "obj" object } { "string" string } } { $values { "obj" object } { "string" string } }

2
basis/html/components/components-tests.factor
View File

@ -163,7 +163,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
[ t ] [ [ t ] [
[ "object" inspector render ] with-string-writer [ "object" inspector render ] with-string-writer
[ "object" value [ describe ] with-html-stream ] with-string-writer [ "object" value [ describe ] with-html-writer ] with-string-writer
= =
] unit-test ] unit-test

8
basis/html/components/components.factor
View File

@ -126,11 +126,11 @@ M: string link-href ;
M: url link-title ; M: url link-title ;
M: url link-href ; M: url link-href ;
SINGLETON: link TUPLE: link target ;
M: link render* M: link render*
2drop nip
<a dup link-href =href a> <a target>> [ =target ] when* dup link-href =href a>
link-title present escape-string write link-title present escape-string write
</a> ; </a> ;
@ -169,7 +169,7 @@ M: farkup render*
SINGLETON: inspector SINGLETON: inspector
M: inspector render* M: inspector render*
2drop [ describe ] with-html-stream ; 2drop [ describe ] with-html-writer ;
! Diff component ! Diff component
SINGLETON: comparison SINGLETON: comparison

11
basis/html/elements/elements.factor
View File

@ -113,6 +113,7 @@ SYMBOL: html
"hr" "hr"
"link" "link"
"img" "img"
"base"
] [ define-open-html-word ] each ] [ define-open-html-word ] each
! Define some attributes ! Define some attributes
@ -124,7 +125,7 @@ SYMBOL: html
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang" "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
"media" "title" "multiple" "checked" "media" "title" "multiple" "checked"
"summary" "cellspacing" "align" "scope" "abbr" "summary" "cellspacing" "align" "scope" "abbr"
"nofollow" "alt" "nofollow" "alt" "target"
] [ define-attribute-word ] each ] [ define-attribute-word ] each
>> >>
@ -133,12 +134,16 @@ SYMBOL: html
"<?xml version=\"1.0\"?>" write-html "<?xml version=\"1.0\"?>" write-html
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">" write-html ; "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">" write-html ;
: simple-page ( title quot -- ) : simple-page ( title head-quot body-quot -- )
#! Call the quotation, with all output going to the #! Call the quotation, with all output going to the
#! body of an html page with the given title. #! body of an html page with the given title.
spin
xhtml-preamble xhtml-preamble
<html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html> <html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
<head> <title> swap write </title> </head> <head>
<title> write </title>
call
</head>
<body> call </body> <body> call </body>
</html> ; inline </html> ; inline

16
basis/html/templates/chloe/chloe-docs.factor
View File

@ -27,13 +27,9 @@ HELP: CHLOE:
{ $values { "name" "the tag name" } { "definition" "a quotation with stack effect " { $snippet "( tag -- )" } } } { $values { "name" "the tag name" } { "definition" "a quotation with stack effect " { $snippet "( tag -- )" } } }
{ $description "Defines compilation semantics for the Chloe tag named " { $snippet "tag" } ". The definition body receives a " { $link tag } " on the stack." } ; { $description "Defines compilation semantics for the Chloe tag named " { $snippet "tag" } ". The definition body receives a " { $link tag } " on the stack." } ;
HELP: CHLOE-SINGLETON: HELP: COMPONENT:
{ $syntax "CHLOE-SINGLETON: name" } { $syntax "COMPONENT: name" }
{ $description "Defines a Chloe tag named " { $snippet "name" } " rendering an HTML component with singleton class word " { $snippet "name" } ". See " { $link "html.components" } "." } ; { $description "Defines a Chloe tag named " { $snippet "name" } " rendering the HTML component with class word " { $snippet "name" } ". See " { $link "html.components" } "." } ;
HELP: CHLOE-TUPLE:
{ $syntax "CHLOE-TUPLE: name" }
{ $description "Defines a Chloe tag named " { $snippet "name" } " rendering an HTML component with tuple class word " { $snippet "name" } ". See " { $link "html.components" } "." } ;
HELP: reset-cache HELP: reset-cache
{ $description "Resets the compiled template cache. Chloe automatically recompiles templates when their file changes on disk, however other when redefining Chloe tags or words which they call, the cache may have to be reset manually for the changes to take effect." } ; { $description "Resets the compiled template cache. Chloe automatically recompiles templates when their file changes on disk, however other when redefining Chloe tags or words which they call, the cache may have to be reset manually for the changes to take effect." } ;
@ -135,6 +131,7 @@ ARTICLE: "html.templates.chloe.tags.form" "Chloe link and form tags"
"s</a>" "s</a>"
} }
} } } }
{ { $snippet "t:base" } { "Outputs an HTML " { $snippet "<base>" } " tag. The attributes are interpreted in the same manner as the attributes of " { $snippet "t:a" } "." } }
{ { $snippet "t:form" } { { { $snippet "t:form" } {
"Renders a form; extends the standard XHTML " { $snippet "form" } " tag by providing some integration with other web framework features, for example by adding hidden fields for authentication credentials and session management allowing those features to work with form submission transparently. The following attributes are supported:" "Renders a form; extends the standard XHTML " { $snippet "form" } " tag by providing some integration with other web framework features, for example by adding hidden fields for authentication credentials and session management allowing those features to work with form submission transparently. The following attributes are supported:"
{ $list { $list
@ -264,14 +261,13 @@ ARTICLE: "html.templates.chloe.extend.components.example" "An example of a custo
"Now we define a method on the " { $link render* } " generic word which renders the image using " { $vocab-link "html.elements" } ":" "Now we define a method on the " { $link render* } " generic word which renders the image using " { $vocab-link "html.elements" } ":"
{ $code "M: image render* 2drop <img =src img/> ;" } { $code "M: image render* 2drop <img =src img/> ;" }
"Finally, we can define a Chloe component:" "Finally, we can define a Chloe component:"
{ $code "CHLOE-SINGLETON: image" } { $code "COMPONENT: image" }
"We can use it as follows, assuming the current form has a value named " { $snippet "image" } ":" "We can use it as follows, assuming the current form has a value named " { $snippet "image" } ":"
{ $code "<t:image t:name='image' />" } ; { $code "<t:image t:name='image' />" } ;
ARTICLE: "html.templates.chloe.extend.components" "Extending Chloe with custom components" ARTICLE: "html.templates.chloe.extend.components" "Extending Chloe with custom components"
"Custom HTML components implementing the " { $link render* } " word can be wired up with Chloe using the following syntax from " { $vocab-link "html.templates.chloe.components" } ":" "Custom HTML components implementing the " { $link render* } " word can be wired up with Chloe using the following syntax from " { $vocab-link "html.templates.chloe.components" } ":"
{ $subsection POSTPONE: CHLOE-SINGLETON: } { $subsection POSTPONE: COMPONENT: }
{ $subsection POSTPONE: CHLOE-TUPLE: }
{ $subsection "html.templates.chloe.extend.components.example" } ; { $subsection "html.templates.chloe.extend.components.example" } ;
ARTICLE: "html.templates.chloe" "Chloe templates" ARTICLE: "html.templates.chloe" "Chloe templates"

27
basis/html/templates/chloe/chloe.factor
View File

@ -78,20 +78,19 @@ CHLOE: call-next-template
CHLOE: if dup if>quot [ swap when ] append process-children ; CHLOE: if dup if>quot [ swap when ] append process-children ;
CHLOE-SINGLETON: label COMPONENT: label
CHLOE-SINGLETON: link COMPONENT: link
CHLOE-SINGLETON: inspector COMPONENT: inspector
CHLOE-SINGLETON: comparison COMPONENT: comparison
CHLOE-SINGLETON: html COMPONENT: html
CHLOE-SINGLETON: hidden COMPONENT: hidden
COMPONENT: farkup
CHLOE-TUPLE: farkup COMPONENT: field
CHLOE-TUPLE: field COMPONENT: textarea
CHLOE-TUPLE: textarea COMPONENT: password
CHLOE-TUPLE: password COMPONENT: choice
CHLOE-TUPLE: choice COMPONENT: checkbox
CHLOE-TUPLE: checkbox COMPONENT: code
CHLOE-TUPLE: code
SYMBOL: template-cache SYMBOL: template-cache

18
basis/html/templates/chloe/components/components.factor
View File

@ -1,35 +1,31 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sequences kernel parser fry quotations USING: accessors assocs sequences kernel parser fry quotations
classes.tuple classes.tuple classes.singleton
html.components html.components
html.templates.chloe.compiler html.templates.chloe.compiler
html.templates.chloe.syntax ; html.templates.chloe.syntax ;
IN: html.templates.chloe.components IN: html.templates.chloe.components
: singleton-component-tag ( tag class -- ) GENERIC: component-tag ( tag class -- )
M: singleton-class component-tag ( tag class -- )
[ "name" required-attr compile-attr ] [ "name" required-attr compile-attr ]
[ literalize [ render ] [code-with] ] [ literalize [ render ] [code-with] ]
bi* ; bi* ;
: CHLOE-SINGLETON:
scan-word
[ name>> ] [ '[ _ singleton-component-tag ] ] bi
define-chloe-tag ;
parsing
: compile-component-attrs ( tag class -- ) : compile-component-attrs ( tag class -- )
[ attrs>> [ drop main>> "name" = not ] assoc-filter ] dip [ attrs>> [ drop main>> "name" = not ] assoc-filter ] dip
[ all-slots swap '[ name>> _ at compile-attr ] each ] [ all-slots swap '[ name>> _ at compile-attr ] each ]
[ [ boa ] [code-with] ] [ [ boa ] [code-with] ]
bi ; bi ;
: tuple-component-tag ( tag class -- ) M: tuple-class component-tag ( tag class -- )
[ drop "name" required-attr compile-attr ] [ compile-component-attrs ] 2bi [ drop "name" required-attr compile-attr ] [ compile-component-attrs ] 2bi
[ render ] [code] ; [ render ] [code] ;
: CHLOE-TUPLE: : COMPONENT:
scan-word scan-word
[ name>> ] [ '[ _ tuple-component-tag ] ] bi [ name>> ] [ '[ _ component-tag ] ] bi
define-chloe-tag ; define-chloe-tag ;
parsing parsing

4
basis/http/server/server.factor
View File

@ -153,8 +153,8 @@ main-responder global [ <404> <trivial-responder> or ] change-at
[ add-responder-nesting ] [ call-responder* ] 2bi ; [ add-responder-nesting ] [ call-responder* ] 2bi ;
: http-error. ( error -- ) : http-error. ( error -- )
"Internal server error" [ "Internal server error" [ ] [
[ print-error nl :c ] with-html-stream [ print-error nl :c ] with-html-writer
] simple-page ; ] simple-page ;
: <500> ( error -- response ) : <500> ( error -- response )

2
basis/http/server/static/static.factor
View File

@ -60,7 +60,7 @@ TUPLE: file-responder root hook special allow-listings ;
dup <a =href a> escape-string write </a> ; dup <a =href a> escape-string write </a> ;
: directory. ( path -- ) : directory. ( path -- )
dup file-name [ dup file-name [ ] [
[ <h1> file-name escape-string write </h1> ] [ <h1> file-name escape-string write </h1> ]
[ [
<ul> <ul>