Merge branch 'master' of git://factorcode.org/git/factor

db4
sheeple 2009-02-06 12:22:04 -06:00
commit e0706040cb
19 changed files with 124 additions and 84 deletions

View File

@ -10,7 +10,6 @@ xml.writer
xml.traversal xml.traversal
xml.syntax xml.syntax
html.components html.components
html.elements
html.forms html.forms
html.templates html.templates
html.templates.chloe html.templates.chloe
@ -20,6 +19,7 @@ http
http.server http.server
http.server.redirection http.server.redirection
http.server.responses http.server.responses
io.streams.string
furnace.utilities ; furnace.utilities ;
IN: furnace.chloe-tags IN: furnace.chloe-tags
@ -58,62 +58,67 @@ CHLOE: write-atom drop [ write-atom-feeds ] [code] ;
#! Side-effects current namespace. #! Side-effects current namespace.
'[ [ [ _ ] dip link-attr ] each-responder ] [code] ; '[ [ [ _ ] dip link-attr ] each-responder ] [code] ;
: a-start-tag ( tag -- ) : process-attrs ( assoc -- newassoc )
[ <a ] [code] [ "@" ?head [ value present ] when ] assoc-map ;
[ attrs>> non-chloe-attrs-only compile-attrs ]
[ compile-link-attrs ]
[ compile-a-url ]
tri
[ =href a> ] [code] ;
: a-end-tag ( tag -- ) : non-chloe-attrs ( tag -- )
drop [ </a> ] [code] ; attrs>> non-chloe-attrs-only [ process-attrs ] [code-with] ;
: a-attrs ( tag -- )
[ non-chloe-attrs ]
[ compile-link-attrs ]
[ compile-a-url ] tri
[ present swap "href" swap [ set-at ] keep ] [code] ;
CHLOE: a CHLOE: a
[ [
[ a-start-tag ] [ compile-children ] [ a-end-tag ] tri [ a-attrs ]
[ compile-children>string ] bi
[ <unescaped> [XML <a><-></a> XML] second swap >>attrs ]
[xml-code]
] compile-with-scope ; ] compile-with-scope ;
CHLOE: base CHLOE: base
compile-a-url [ <base =href base/> ] [code] ; compile-a-url [ [XML <base href=<->/> XML] ] [xml-code] ;
: compile-hidden-form-fields ( for -- ) : compile-hidden-form-fields ( for -- )
'[ '[
<div "display: none;" =style div> _ [ "," split [ hidden render>xml ] map ] [ f ] if*
_ [ "," split [ hidden render ] each ] when* nested-forms get " " join f like nested-forms-key hidden-form-field>xml
nested-forms get " " join f like nested-forms-key hidden-form-field [ [ modify-form ] each-responder ] with-string-writer <unescaped>
[ modify-form ] each-responder [XML <div style="display: none;"><-><-><-></div> XML]
</div>
] [code] ; ] [code] ;
: compile-form-attrs ( method action attrs -- ) : (compile-form-attrs) ( method action -- )
[ <form ] [code] ! Leaves an assoc on the stack at runtime
[ compile-attr [ =method ] [code] ] [ compile-attr [ "method" pick set-at ] [code] ]
[ compile-attr [ resolve-base-path =action ] [code] ] [ compile-attr [ resolve-base-path "action" pick set-at ] [code] ]
[ compile-attrs ] bi* ;
tri*
[ form> ] [code] ;
: form-start-tag ( tag -- ) : compile-method/action ( tag -- )
[ ! generated code is ( assoc -- assoc )
[ "method" optional-attr "post" or ] [ "method" optional-attr "post" or ]
[ "action" required-attr ] [ "action" required-attr ] bi
[ attrs>> non-chloe-attrs-only ] tri (compile-form-attrs) ;
compile-form-attrs
]
[ "for" optional-attr compile-hidden-form-fields ] bi ;
: form-end-tag ( tag -- ) : compile-form-attrs ( tag -- )
drop [ </form> ] [code] ; [ non-chloe-attrs ]
[ compile-link-attrs ]
[ compile-method/action ] tri ;
: hidden-fields ( tag -- )
"for" optional-attr compile-hidden-form-fields ;
CHLOE: form CHLOE: form
[ [
{ [ compile-form-attrs ]
[ compile-link-attrs ] [ hidden-fields ]
[ form-start-tag ] [ compile-children>string ] tri
[ compile-children ] [
[ form-end-tag ] <unescaped> [XML <form><-><-></form> XML] second
} cleave swap >>attrs
write-xml
] [code]
] compile-with-scope ; ] compile-with-scope ;
: button-tag-markup ( -- xml ) : button-tag-markup ( -- xml )
@ -121,13 +126,13 @@ CHLOE: form
<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0"> <t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
<div style="display: inline;"><button type="submit"></button></div> <div style="display: inline;"><button type="submit"></button></div>
</t:form> </t:form>
XML> ; XML> body>> clone ;
: add-tag-attrs ( attrs tag -- ) : add-tag-attrs ( attrs tag -- )
attrs>> swap update ; attrs>> swap update ;
CHLOE: button CHLOE: button
button-tag-markup body>> button-tag-markup
{ {
[ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ] [ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ]
[ [ attrs>> non-chloe-attrs-only ] dip "button" deep-tag-named add-tag-attrs ] [ [ attrs>> non-chloe-attrs-only ] dip "button" deep-tag-named add-tag-attrs ]

View File

@ -30,7 +30,7 @@ M: base-path-check-responder call-responder*
"a/b/c" split-path main-responder get call-responder body>> "a/b/c" split-path main-responder get call-responder body>>
] unit-test ] unit-test
[ "<input type='hidden' name='foo' value='&amp;&amp;&amp;'/>" ] [ "<input type=\"hidden\" value=\"&amp;&amp;&amp;\" name=\"foo\"/>" ]
[ [ "&&&" "foo" hidden-form-field ] with-string-writer ] [ [ "&&&" "foo" hidden-form-field ] with-string-writer ]
unit-test unit-test

View File

@ -5,7 +5,7 @@ strings random accessors quotations hashtables sequences
continuations fry calendar combinators combinators.short-circuit continuations fry calendar combinators combinators.short-circuit
destructors alarms io.sockets db db.tuples db.types destructors alarms io.sockets db db.tuples db.types
http http.server http.server.dispatchers http.server.filters http http.server http.server.dispatchers http.server.filters
html.elements furnace.cache furnace.scopes furnace.utilities ; furnace.cache furnace.scopes furnace.utilities ;
IN: furnace.sessions IN: furnace.sessions
TUPLE: session < scope user-agent client ; TUPLE: session < scope user-agent client ;

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces make assocs sequences kernel classes splitting USING: namespaces make assocs sequences kernel classes splitting
words vocabs.loader accessors strings combinators arrays words vocabs.loader accessors strings combinators arrays
continuations present fry urls html.elements http http.server continuations present fry urls http http.server xml.syntax xml.writer
http.server.redirection http.server.remapping ; http.server.redirection http.server.remapping ;
IN: furnace.utilities IN: furnace.utilities
@ -81,14 +81,13 @@ GENERIC: modify-form ( responder -- )
M: object modify-form drop ; M: object modify-form drop ;
: hidden-form-field ( value name -- ) : hidden-form-field>xml ( value name -- xml )
over [ over [
<input [XML <input type="hidden" value=<-> name=<->/> XML]
"hidden" =type ] [ drop ] if ;
=name
present =value : hidden-form-field ( value name -- )
input/> hidden-form-field>xml write-xml ;
] [ 2drop ] if ;
: nested-forms-key "__n" ; : nested-forms-key "__n" ;

View File

@ -11,7 +11,7 @@ IN: html.components
GENERIC: render* ( value name renderer -- xml ) GENERIC: render* ( value name renderer -- xml )
: render ( name renderer -- ) : render>xml ( name renderer -- xml )
prepare-value prepare-value
[ [
dup validation-error? dup validation-error?
@ -20,7 +20,10 @@ GENERIC: render* ( value name renderer -- xml )
if if
] 2dip ] 2dip
render* render*
swap 2array write-xml ; swap 2array ;
: render ( name renderer -- )
render>xml write-xml ;
SINGLETON: label SINGLETON: label

View File

@ -128,7 +128,7 @@ ARTICLE: "html.templates.chloe.tags.form" "Chloe link and form tags"
"<a href=\"http://mysite.org/wiki/view/Factor\"" "<a href=\"http://mysite.org/wiki/view/Factor\""
" class=\"small-link\">" " class=\"small-link\">"
" View" " View"
"s</a>" "</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:base" } { "Outputs an HTML " { $snippet "<base>" } " tag. The attributes are interpreted in the same manner as the attributes of " { $snippet "t:a" } "." } }
@ -261,8 +261,8 @@ $nl
ARTICLE: "html.templates.chloe.extend.components.example" "An example of a custom Chloe component" ARTICLE: "html.templates.chloe.extend.components.example" "An example of a custom Chloe component"
"As an example, let's develop a custom Chloe component which renders an image stored in a form value. Since the component does not require any configuration, we can define a singleton class:" "As an example, let's develop a custom Chloe component which renders an image stored in a form value. Since the component does not require any configuration, we can define a singleton class:"
{ $code "SINGLETON: image" } { $code "SINGLETON: image" }
"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 "xml.literals" } ":"
{ $code "M: image render* 2drop <img =src img/> ;" } { $code "M: image render* 2drop [XML <img src=<-> /> XML] ;" }
"Finally, we can define a Chloe component:" "Finally, we can define a Chloe component:"
{ $code "COMPONENT: 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" } ":"

View File

@ -135,7 +135,7 @@ TUPLE: person first-name last-name ;
[ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test [ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test
[ "<form method='post' action='foo'><div style='display: none;'><input type='hidden' name='__n' value='a'/></div></form>" ] [ [ "<form method=\"post\" action=\"foo\"><div style=\"display: none;\"><input type=\"hidden\" value=\"a\" name=\"__n\"/></div></form>" ] [
[ [
"test10" test-template call-template "test10" test-template call-template
] run-template ] run-template

View File

@ -8,7 +8,6 @@ logging continuations
xml.data xml.writer xml.syntax strings xml.data xml.writer xml.syntax strings
html.forms html.forms
html html
html.elements
html.components html.components
html.templates html.templates
html.templates.chloe.compiler html.templates.chloe.compiler
@ -28,7 +27,9 @@ CHLOE: write-title
drop drop
"head" tag-stack get member? "head" tag-stack get member?
"title" tag-stack get member? not and "title" tag-stack get member? not and
[ <title> write-title </title> ] [ write-title ] ? [code] ; [ get-title [XML <title><-></title> XML] ]
[ get-title ] ?
[xml-code] ;
CHLOE: style CHLOE: style
dup "include" optional-attr [ dup "include" optional-attr [
@ -39,10 +40,9 @@ CHLOE: style
CHLOE: write-style CHLOE: write-style
drop [ drop [
<style "text/css" =type style> get-style
write-style [XML <style type="text/css"> <-> </style> XML]
</style> ] [xml-code] ;
] [code] ;
CHLOE: even CHLOE: even
[ "index" value even? swap when ] process-children ; [ "index" value even? swap when ] process-children ;

View File

@ -42,6 +42,9 @@ DEFER: compile-element
: [code-with] ( obj quot -- ) : [code-with] ( obj quot -- )
reset-buffer [ , ] [ % ] bi* ; reset-buffer [ , ] [ % ] bi* ;
: [xml-code] ( quot -- )
[ write-xml ] compose [code] ;
: expand-attr ( value -- ) : expand-attr ( value -- )
[ value present write ] [code-with] ; [ value present write ] [code-with] ;

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel fry io io.encodings.utf8 io.files USING: accessors kernel fry io io.encodings.utf8 io.files
debugger prettyprint continuations namespaces boxes sequences debugger prettyprint continuations namespaces boxes sequences
arrays strings html io.streams.string arrays strings html io.streams.string assocs
quotations xml.data xml.writer xml.syntax ; quotations xml.data xml.writer xml.syntax ;
IN: html.templates IN: html.templates
@ -34,8 +34,11 @@ SYMBOL: title
: set-title ( string -- ) : set-title ( string -- )
title get >box ; title get >box ;
: get-title ( -- string )
title get value>> ;
: write-title ( -- ) : write-title ( -- )
title get value>> write ; get-title write ;
SYMBOL: style SYMBOL: style
@ -43,24 +46,30 @@ SYMBOL: style
"\n" style get push-all "\n" style get push-all
style get push-all ; style get push-all ;
: get-style ( -- string )
style get >string ;
: write-style ( -- ) : write-style ( -- )
style get >string write ; get-style write ;
SYMBOL: atom-feeds SYMBOL: atom-feeds
: add-atom-feed ( title url -- ) : add-atom-feed ( title url -- )
2array atom-feeds get push ; 2array atom-feeds get push ;
: write-atom-feeds ( -- ) : get-atom-feeds ( -- xml )
atom-feeds get [ atom-feeds get [
first2 [XML [XML
<link <link
rel="alternate" rel="alternate"
type="application/atom+xml" type="application/atom+xml"
title=<-> title=<->
href=<->/> href=<->/>
XML] write-xml XML]
] each ; ] { } assoc>map ;
: write-atom-feeds ( -- )
get-atom-feeds write-xml ;
SYMBOL: nested-template? SYMBOL: nested-template?

View File

@ -1,4 +1,7 @@
USING: unicode.case tools.test namespaces ; ! Copyright (C) 2008, 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: unicode.case unicode.case.private tools.test namespaces strings unicode.normalize ;
IN: unicode.case.tests
\ >upper must-infer \ >upper must-infer
\ >lower must-infer \ >lower must-infer
@ -9,12 +12,21 @@ USING: unicode.case tools.test namespaces ;
[ "\u0003C3a\u0003C2 \u0003C3\u0003C2 \u0003C3a\u0003C2" ] [ "\u0003A3A\u0003A3 \u0003A3\u0003A3 \u0003A3A\u0003A3" >lower ] unit-test [ "\u0003C3a\u0003C2 \u0003C3\u0003C2 \u0003C3a\u0003C2" ] [ "\u0003A3A\u0003A3 \u0003A3\u0003A3 \u0003A3A\u0003A3" >lower ] unit-test
[ t ] [ "hello how are you?" lower? ] unit-test [ t ] [ "hello how are you?" lower? ] unit-test
[ [
[ f ] [ i-dot? ] unit-test
[ f ] [ lt? ] unit-test
"tr" locale set "tr" locale set
[ t ] [ i-dot? ] unit-test
[ f ] [ lt? ] unit-test
[ "i\u000131i \u000131jj" ] [ "i\u000131I\u000307 IJj" >lower ] unit-test [ "i\u000131i \u000131jj" ] [ "i\u000131I\u000307 IJj" >lower ] unit-test
[ "I\u000307\u000131i Ijj" ] [ "i\u000131I\u000307 IJj" >title ] unit-test [ "I\u000307\u000131i Ijj" ] [ "i\u000131I\u000307 IJj" >title ] unit-test
[ "I\u000307II\u000307 IJJ" ] [ "i\u000131I\u000307 IJj" >upper ] unit-test [ "I\u000307II\u000307 IJJ" ] [ "i\u000131I\u000307 IJj" >upper ] unit-test
"lt" locale set "lt" locale set
! Lithuanian casing tests [ f ] [ i-dot? ] unit-test
[ t ] [ lt? ] unit-test
[ "i\u000307\u000300" ] [ HEX: CC 1string nfd >lower ] unit-test
[ "\u00012f\u000307" ] [ HEX: 12E 1string nfd >lower nfc ] unit-test
[ "I\u000300" ] [ "i\u000307\u000300" >upper ] unit-test
! [ "I\u000300" ] [ "i\u000307\u000300" >title ] unit-test
] with-scope ] with-scope
[ t ] [ "asdf" lower? ] unit-test [ t ] [ "asdf" lower? ] unit-test

View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Daniel Ehrenberg. ! Copyright (C) 2008, 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: unicode.data sequences namespaces USING: unicode.data sequences namespaces
sbufs make unicode.syntax unicode.normalize math hints sbufs make unicode.syntax unicode.normalize math hints
unicode.categories combinators unicode.syntax assocs unicode.categories combinators unicode.syntax assocs combinators.short-circuit
strings splitting kernel accessors unicode.breaks fry locals ; strings splitting kernel accessors unicode.breaks fry locals ;
QUALIFIED: ascii QUALIFIED: ascii
IN: unicode.case IN: unicode.case
@ -26,6 +26,9 @@ SYMBOL: locale ! Just casing locale, or overall?
: i-dot? ( -- ? ) : i-dot? ( -- ? )
locale get { "tr" "az" } member? ; locale get { "tr" "az" } member? ;
: lt? ( -- ? )
locale get "lt" = ;
: lithuanian? ( -- ? ) locale get "lt" = ; : lithuanian? ( -- ? ) locale get "lt" = ;
: dot-over ( -- ch ) HEX: 307 ; : dot-over ( -- ch ) HEX: 307 ;
@ -37,18 +40,21 @@ SYMBOL: locale ! Just casing locale, or overall?
: mark-above? ( ch -- ? ) : mark-above? ( ch -- ? )
combining-class 230 = ; combining-class 230 = ;
: with-rest ( seq quot: ( seq -- seq ) -- seq ) :: with-rest ( seq quot: ( seq -- seq ) -- seq )
[ unclip ] dip swap slip prefix ; inline seq unclip quot dip prefix ; inline
: add-dots ( seq -- seq ) : add-dots ( seq -- seq )
[ [ "" ] [ [ [ { } ] [
dup first mark-above? [
[ CHAR: combining-dot-above prefix ] when dup first
{ [ mark-above? ] [ CHAR: combining-ogonek = ] } 1||
[ CHAR: combining-dot-above prefix ] when
] map
] if-empty ] with-rest ; inline ] if-empty ] with-rest ; inline
: lithuanian>lower ( string -- lower ) : lithuanian>lower ( string -- lower )
"i" split add-dots "i" join "I" split add-dots "I" join
"j" split add-dots "i" join ; inline "J" split add-dots "J" join ; inline
: turk>upper ( string -- upper-i ) : turk>upper ( string -- upper-i )
"i" "I\u000307" replace ; inline "i" "I\u000307" replace ; inline
@ -88,13 +94,16 @@ SYMBOL: locale ! Just casing locale, or overall?
PRIVATE> PRIVATE>
: >lower ( string -- lower ) : >lower ( string -- lower )
i-dot? [ turk>lower ] when final-sigma i-dot? [ turk>lower ] when
lt? [ lithuanian>lower ] when
final-sigma
[ lower>> ] [ ch>lower ] map-case ; [ lower>> ] [ ch>lower ] map-case ;
HINTS: >lower string ; HINTS: >lower string ;
: >upper ( string -- upper ) : >upper ( string -- upper )
i-dot? [ turk>upper ] when i-dot? [ turk>upper ] when
lt? [ lithuanian>upper ] when
[ upper>> ] [ ch>upper ] map-case ; [ upper>> ] [ ch>upper ] map-case ;
HINTS: >upper string ; HINTS: >upper string ;
@ -103,6 +112,7 @@ HINTS: >upper string ;
: (>title) ( string -- title ) : (>title) ( string -- title )
i-dot? [ turk>upper ] when i-dot? [ turk>upper ] when
lt? [ lithuanian>upper ] when
[ title>> ] [ ch>title ] map-case ; inline [ title>> ] [ ch>title ] map-case ; inline
: title-word ( string -- title ) : title-word ( string -- title )

View File

@ -3,7 +3,6 @@
USING: kernel sequences accessors namespaces combinators words USING: kernel sequences accessors namespaces combinators words
assocs db.tuples arrays splitting strings validators urls assocs db.tuples arrays splitting strings validators urls
html.forms html.forms
html.elements
html.components html.components
furnace furnace
furnace.boilerplate furnace.boilerplate