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] ;
: a-start-tag ( tag -- )
[ compile-link-attrs ] [ compile-a-url ] bi
[ <a =href a> ] [code] ;
[ <a ] [code]
[ non-chloe-attrs-only compile-attrs ]
[ compile-link-attrs ]
[ compile-a-url ]
tri
[ =href a> ] [code] ;
: a-end-tag ( tag -- )
drop [ </a> ] [code] ;
@ -70,6 +74,9 @@ CHLOE: a
[ a-start-tag ] [ compile-children ] [ a-end-tag ] tri
] compile-with-scope ;
CHLOE: base
compile-a-url [ <base =href base/> ] [code] ;
: compile-hidden-form-fields ( for -- )
'[
<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." } ;
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
{ $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 ] [
[ "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

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

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

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

@ -113,6 +113,7 @@ SYMBOL: html
"hr"
"link"
"img"
"base"
] [ define-open-html-word ] each
! Define some attributes
@ -124,7 +125,7 @@ SYMBOL: html
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
"media" "title" "multiple" "checked"
"summary" "cellspacing" "align" "scope" "abbr"
"nofollow" "alt"
"nofollow" "alt" "target"
] [ define-attribute-word ] each
>>
@ -133,12 +134,16 @@ SYMBOL: 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 ;
: simple-page ( title quot -- )
: simple-page ( title head-quot body-quot -- )
#! Call the quotation, with all output going to the
#! body of an html page with the given title.
spin
xhtml-preamble
<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>
</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 -- )" } } }
{ $description "Defines compilation semantics for the Chloe tag named " { $snippet "tag" } ". The definition body receives a " { $link tag } " on the stack." } ;
HELP: CHLOE-SINGLETON:
{ $syntax "CHLOE-SINGLETON: name" }
{ $description "Defines a Chloe tag named " { $snippet "name" } " rendering an HTML component with singleton 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: COMPONENT:
{ $syntax "COMPONENT: name" }
{ $description "Defines a Chloe tag named " { $snippet "name" } " rendering the HTML component with class word " { $snippet "name" } ". See " { $link "html.components" } "." } ;
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." } ;
@ -135,6 +131,7 @@ ARTICLE: "html.templates.chloe.tags.form" "Chloe link and form tags"
"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" } {
"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
@ -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" } ":"
{ $code "M: image render* 2drop <img =src img/> ;" }
"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" } ":"
{ $code "<t:image t:name='image' />" } ;
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" } ":"
{ $subsection POSTPONE: CHLOE-SINGLETON: }
{ $subsection POSTPONE: CHLOE-TUPLE: }
{ $subsection POSTPONE: COMPONENT: }
{ $subsection "html.templates.chloe.extend.components.example" } ;
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-SINGLETON: label
CHLOE-SINGLETON: link
CHLOE-SINGLETON: inspector
CHLOE-SINGLETON: comparison
CHLOE-SINGLETON: html
CHLOE-SINGLETON: hidden
CHLOE-TUPLE: farkup
CHLOE-TUPLE: field
CHLOE-TUPLE: textarea
CHLOE-TUPLE: password
CHLOE-TUPLE: choice
CHLOE-TUPLE: checkbox
CHLOE-TUPLE: code
COMPONENT: label
COMPONENT: link
COMPONENT: inspector
COMPONENT: comparison
COMPONENT: html
COMPONENT: hidden
COMPONENT: farkup
COMPONENT: field
COMPONENT: textarea
COMPONENT: password
COMPONENT: choice
COMPONENT: checkbox
COMPONENT: code
SYMBOL: template-cache

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

@ -1,35 +1,31 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sequences kernel parser fry quotations
classes.tuple
classes.tuple classes.singleton
html.components
html.templates.chloe.compiler
html.templates.chloe.syntax ;
IN: html.templates.chloe.components
GENERIC: component-tag ( tag class -- )
: singleton-component-tag ( tag class -- )
M: singleton-class component-tag ( tag class -- )
[ "name" required-attr compile-attr ]
[ literalize [ render ] [code-with] ]
bi* ;
: CHLOE-SINGLETON:
scan-word
[ name>> ] [ '[ _ singleton-component-tag ] ] bi
define-chloe-tag ;
parsing
: compile-component-attrs ( tag class -- )
[ attrs>> [ drop main>> "name" = not ] assoc-filter ] dip
[ all-slots swap '[ name>> _ at compile-attr ] each ]
[ [ boa ] [code-with] ]
bi ;
: tuple-component-tag ( tag class -- )
M: tuple-class component-tag ( tag class -- )
[ drop "name" required-attr compile-attr ] [ compile-component-attrs ] 2bi
[ render ] [code] ;
: CHLOE-TUPLE:
: COMPONENT:
scan-word
[ name>> ] [ '[ _ tuple-component-tag ] ] bi
[ name>> ] [ '[ _ component-tag ] ] bi
define-chloe-tag ;
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 ;
: http-error. ( error -- )
"Internal server error" [
[ print-error nl :c ] with-html-stream
"Internal server error" [ ] [
[ print-error nl :c ] with-html-writer
] simple-page ;
: <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> ;
: directory. ( path -- )
dup file-name [
dup file-name [ ] [
[ <h1> file-name escape-string write </h1> ]
[
<ul>