From dc1d7c76b7d656760511a4e1b13ce7f4549cdf34 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 29 Sep 2008 04:10:00 -0500 Subject: [PATCH] Clean up some web framework code --- basis/furnace/chloe-tags/chloe-tags.factor | 11 ++++++-- basis/html/components/components-docs.factor | 2 +- basis/html/components/components-tests.factor | 2 +- basis/html/components/components.factor | 8 +++--- basis/html/elements/elements.factor | 11 +++++--- basis/html/templates/chloe/chloe-docs.factor | 16 +++++------ basis/html/templates/chloe/chloe.factor | 27 +++++++++---------- .../chloe/components/components.factor | 18 +++++-------- basis/http/server/server.factor | 4 +-- basis/http/server/static/static.factor | 2 +- 10 files changed, 52 insertions(+), 49 deletions(-) diff --git a/basis/furnace/chloe-tags/chloe-tags.factor b/basis/furnace/chloe-tags/chloe-tags.factor index 0cd1d6bd38..697c885a01 100644 --- a/basis/furnace/chloe-tags/chloe-tags.factor +++ b/basis/furnace/chloe-tags/chloe-tags.factor @@ -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 - [ ] [code] ; + [ ] [code] ; : a-end-tag ( tag -- ) drop [ ] [code] ; @@ -70,6 +74,9 @@ CHLOE: a [ a-start-tag ] [ compile-children ] [ a-end-tag ] tri ] compile-with-scope ; +CHLOE: base + compile-a-url [ ] [code] ; + : compile-hidden-form-fields ( for -- ) '[
diff --git a/basis/html/components/components-docs.factor b/basis/html/components/components-docs.factor index d7690b30e2..d131cc3e03 100644 --- a/basis/html/components/components-docs.factor +++ b/basis/html/components/components-docs.factor @@ -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 } } diff --git a/basis/html/components/components-tests.factor b/basis/html/components/components-tests.factor index 56c7118ab9..c0b7eec914 100644 --- a/basis/html/components/components-tests.factor +++ b/basis/html/components/components-tests.factor @@ -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 diff --git a/basis/html/components/components.factor b/basis/html/components/components.factor index 18e1aad9eb..dafc9dd06b 100644 --- a/basis/html/components/components.factor +++ b/basis/html/components/components.factor @@ -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 - + nip + > [ =target ] when* dup link-href =href a> link-title present escape-string write ; @@ -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 diff --git a/basis/html/elements/elements.factor b/basis/html/elements/elements.factor index c7281df54d..0ee6955e29 100644 --- a/basis/html/elements/elements.factor +++ b/basis/html/elements/elements.factor @@ -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 "" write-html "" 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 - swap write + + write + call + call ; inline diff --git a/basis/html/templates/chloe/chloe-docs.factor b/basis/html/templates/chloe/chloe-docs.factor index b97a4c5c35..f390aad238 100644 --- a/basis/html/templates/chloe/chloe-docs.factor +++ b/basis/html/templates/chloe/chloe-docs.factor @@ -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" } } } + { { $snippet "t:base" } { "Outputs an HTML " { $snippet "" } " 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 ;" } "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 "" } ; 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" diff --git a/basis/html/templates/chloe/chloe.factor b/basis/html/templates/chloe/chloe.factor index e83040b00d..1bc4684d5c 100644 --- a/basis/html/templates/chloe/chloe.factor +++ b/basis/html/templates/chloe/chloe.factor @@ -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 diff --git a/basis/html/templates/chloe/components/components.factor b/basis/html/templates/chloe/components/components.factor index 77d7c937be..3041120d43 100644 --- a/basis/html/templates/chloe/components/components.factor +++ b/basis/html/templates/chloe/components/components.factor @@ -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 diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor index 64c85a24d2..518081899e 100755 --- a/basis/http/server/server.factor +++ b/basis/http/server/server.factor @@ -153,8 +153,8 @@ main-responder global [ <404> 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 ) diff --git a/basis/http/server/static/static.factor b/basis/http/server/static/static.factor index abb504ed94..5ae18156b0 100755 --- a/basis/http/server/static/static.factor +++ b/basis/http/server/static/static.factor @@ -60,7 +60,7 @@ TUPLE: file-responder root hook special allow-listings ; dup escape-string write ; : directory. ( path -- ) - dup file-name [ + dup file-name [ ] [ [

file-name escape-string write

] [