Major Chloe overhaul: compiled templatess
Slava Pestov
parent
63d45679c9
commit
7a9806495f
|
|
@ -134,22 +134,21 @@ TUPLE: protected < filter-responder description capabilities ;
|
|||
swap >>responder ;
|
||||
|
||||
: have-capabilities? ( capabilities -- ? )
|
||||
realm get secure>> secure-connection? not and [ drop f ] [
|
||||
logged-in-user get {
|
||||
{ [ dup not ] [ 2drop f ] }
|
||||
{ [ dup deleted>> 1 = ] [ 2drop f ] }
|
||||
[ capabilities>> subset? ]
|
||||
} cond ;
|
||||
} cond
|
||||
] if ;
|
||||
|
||||
M: protected call-responder* ( path responder -- response )
|
||||
'[
|
||||
, ,
|
||||
dup protected set
|
||||
dup capabilities>> have-capabilities?
|
||||
[ call-next-method ] [
|
||||
[ drop ] [ [ description>> ] [ capabilities>> ] bi ] bi*
|
||||
realm get login-required*
|
||||
] if
|
||||
] if-secure-realm ;
|
||||
] if ;
|
||||
|
||||
: <auth-boilerplate> ( responder -- responder' )
|
||||
<boilerplate> { realm "boilerplate" } >>template ;
|
||||
|
|
|
|||
|
|
@ -36,7 +36,8 @@ IN: furnace.auth.features.registration
|
|||
|
||||
URL" $realm" <redirect>
|
||||
] >>submit
|
||||
<auth-boilerplate> ;
|
||||
<auth-boilerplate>
|
||||
<secure-realm-only> ;
|
||||
|
||||
: allow-registration ( login -- login )
|
||||
<register-action> "register" add-responder ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,19 @@
|
|||
USING: html.forms furnace.chloe-tags tools.test ;
|
||||
IN: furnace.chloe-tags.tests
|
||||
|
||||
[ f ] [ f parse-query-attr ] unit-test
|
||||
|
||||
[ f ] [ "" parse-query-attr ] unit-test
|
||||
|
||||
[ H{ { "a" "b" } } ] [
|
||||
begin-form
|
||||
"b" "a" set-value
|
||||
"a" parse-query-attr
|
||||
] unit-test
|
||||
|
||||
[ H{ { "a" "b" } { "c" "d" } } ] [
|
||||
begin-form
|
||||
"b" "a" set-value
|
||||
"d" "c" set-value
|
||||
"a,c" parse-query-attr
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,121 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays kernel combinators assocs
|
||||
namespaces sequences splitting words
|
||||
fry urls multiline present qualified
|
||||
xml
|
||||
xml.data
|
||||
xml.entities
|
||||
xml.writer
|
||||
xml.utilities
|
||||
html.components
|
||||
html.elements
|
||||
html.forms
|
||||
html.templates
|
||||
html.templates.chloe
|
||||
html.templates.chloe.compiler
|
||||
html.templates.chloe.syntax
|
||||
http
|
||||
http.server
|
||||
http.server.redirection
|
||||
http.server.responses
|
||||
furnace ;
|
||||
QUALIFIED-WITH: assocs a
|
||||
IN: furnace.chloe-tags
|
||||
|
||||
! Chloe tags
|
||||
: parse-query-attr ( string -- assoc )
|
||||
[ f ] [ "," split [ dup value ] H{ } map>assoc ] if-empty ;
|
||||
|
||||
: a-url-path ( href rest -- string )
|
||||
dup [ value ] when
|
||||
[ [ "/" ?tail drop "/" ] dip present 3append ] when* ;
|
||||
|
||||
: a-url ( href rest query value-name -- url )
|
||||
dup [ >r 3drop r> value ] [
|
||||
drop
|
||||
<url>
|
||||
swap parse-query-attr >>query
|
||||
-rot a-url-path >>path
|
||||
adjust-url relative-to-request
|
||||
] if ;
|
||||
|
||||
: compile-a-url ( tag -- )
|
||||
{
|
||||
[ "href" required-attr compile-attr ]
|
||||
[ "rest" optional-attr compile-attr ]
|
||||
[ "query" optional-attr compile-attr ]
|
||||
[ "value" optional-attr compile-attr ]
|
||||
} cleave [ a-url ] [code] ;
|
||||
|
||||
CHLOE: atom
|
||||
[ compile-children>string ] [ compile-a-url ] bi
|
||||
[ add-atom-feed ] [code] ;
|
||||
|
||||
CHLOE: write-atom drop [ write-atom-feeds ] [code] ;
|
||||
|
||||
: compile-link-attrs ( tag -- )
|
||||
#! Side-effects current namespace.
|
||||
attrs>> '[ [ , _ link-attr ] each-responder ] [code] ;
|
||||
|
||||
: a-start-tag ( tag -- )
|
||||
[ compile-link-attrs ] [ compile-a-url ] bi
|
||||
[ <a =href a> ] [code] ;
|
||||
|
||||
: a-end-tag ( tag -- )
|
||||
drop [ </a> ] [code] ;
|
||||
|
||||
CHLOE: a [ a-start-tag ] [ compile-children ] [ a-end-tag ] tri ;
|
||||
|
||||
: compile-hidden-form-fields ( for -- )
|
||||
'[
|
||||
, [ "," split [ hidden render ] each ] when*
|
||||
nested-forms get " " join f like nested-forms-key hidden-form-field
|
||||
[ modify-form ] each-responder
|
||||
] [code] ;
|
||||
|
||||
: compile-form-attrs ( method action attrs -- )
|
||||
[ <form ] [code]
|
||||
[ compile-attr [ =method ] [code] ]
|
||||
[ compile-attr [ resolve-base-path =action ] [code] ]
|
||||
[ compile-attrs ]
|
||||
tri*
|
||||
[ form> ] [code] ;
|
||||
|
||||
: form-start-tag ( tag -- )
|
||||
[
|
||||
[ "method" optional-attr "post" or ]
|
||||
[ "action" required-attr ]
|
||||
[ attrs>> non-chloe-attrs-only ] tri
|
||||
compile-form-attrs
|
||||
]
|
||||
[ "for" optional-attr compile-hidden-form-fields ] bi ;
|
||||
|
||||
: form-end-tag ( tag -- )
|
||||
drop [ </form> ] [code] ;
|
||||
|
||||
CHLOE: form
|
||||
{
|
||||
[ compile-link-attrs ]
|
||||
[ form-start-tag ]
|
||||
[ compile-children ]
|
||||
[ form-end-tag ]
|
||||
} cleave ;
|
||||
|
||||
STRING: button-tag-markup
|
||||
<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
<button type="submit"></button>
|
||||
</t:form>
|
||||
;
|
||||
|
||||
: add-tag-attrs ( attrs tag -- )
|
||||
attrs>> swap update ;
|
||||
|
||||
CHLOE: button
|
||||
button-tag-markup string>xml body>>
|
||||
{
|
||||
[ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ]
|
||||
[ [ attrs>> non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
|
||||
[ [ children>> ] dip "button" tag-named (>>children) ]
|
||||
[ nip ]
|
||||
} 2cleave compile-chloe-tag ;
|
||||
|
|
@ -130,7 +130,8 @@ M: conversations call-responder*
|
|||
over post-data>> >>post-data
|
||||
over url>> >>url
|
||||
] change
|
||||
url>> path>> split-path
|
||||
[ url>> url set ]
|
||||
[ url>> path>> split-path ] bi
|
||||
conversations get responder>> call-responder ;
|
||||
|
||||
\ end-aside-post DEBUG add-input-logging
|
||||
|
|
|
|||
|
|
@ -1,30 +1,14 @@
|
|||
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays kernel combinators assocs
|
||||
continuations namespaces sequences splitting words
|
||||
vocabs.loader classes strings
|
||||
fry urls multiline present
|
||||
xml
|
||||
xml.data
|
||||
xml.entities
|
||||
xml.writer
|
||||
html.components
|
||||
html.elements
|
||||
html.forms
|
||||
html.templates
|
||||
html.templates.chloe
|
||||
html.templates.chloe.syntax
|
||||
http
|
||||
http.server
|
||||
http.server.redirection
|
||||
http.server.responses
|
||||
qualified ;
|
||||
QUALIFIED-WITH: assocs a
|
||||
EXCLUDE: xml.utilities => children>string ;
|
||||
USING: namespaces assocs sequences kernel classes splitting
|
||||
vocabs.loader accessors strings combinators arrays
|
||||
continuations present fry
|
||||
urls html.elements
|
||||
http http.server http.server.redirection ;
|
||||
IN: furnace
|
||||
|
||||
: nested-responders ( -- seq )
|
||||
responder-nesting get a:values ;
|
||||
responder-nesting get values ;
|
||||
|
||||
: each-responder ( quot -- )
|
||||
nested-responders swap each ; inline
|
||||
|
|
@ -63,10 +47,25 @@ M: url adjust-url
|
|||
|
||||
M: string adjust-url ;
|
||||
|
||||
GENERIC: link-attr ( tag responder -- )
|
||||
|
||||
M: object link-attr 2drop ;
|
||||
|
||||
GENERIC: modify-form ( responder -- )
|
||||
|
||||
M: object modify-form drop ;
|
||||
|
||||
: hidden-form-field ( value name -- )
|
||||
over [
|
||||
<input
|
||||
"hidden" =type
|
||||
=name
|
||||
present =value
|
||||
input/>
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: nested-forms-key "__n" ;
|
||||
|
||||
: request-params ( request -- assoc )
|
||||
dup method>> {
|
||||
{ "GET" [ url>> query>> ] }
|
||||
|
|
@ -110,98 +109,4 @@ SYMBOL: exit-continuation
|
|||
: with-exit-continuation ( quot -- )
|
||||
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
|
||||
|
||||
! Chloe tags
|
||||
: parse-query-attr ( string -- assoc )
|
||||
[ f ] [ "," split [ dup value ] H{ } map>assoc ] if-empty ;
|
||||
|
||||
: a-url-path ( tag -- string )
|
||||
[ "href" required-attr ]
|
||||
[ "rest" optional-attr dup [ value ] when ] bi
|
||||
[ [ "/" ?tail drop "/" ] dip present 3append ] when* ;
|
||||
|
||||
: a-url ( tag -- url )
|
||||
dup "value" optional-attr
|
||||
[ value ] [
|
||||
<url>
|
||||
swap
|
||||
[ a-url-path >>path ]
|
||||
[ "query" optional-attr parse-query-attr >>query ]
|
||||
bi
|
||||
adjust-url relative-to-request
|
||||
] ?if ;
|
||||
|
||||
CHLOE: atom [ children>string ] [ a-url ] bi add-atom-feed ;
|
||||
|
||||
CHLOE: write-atom drop write-atom-feeds ;
|
||||
|
||||
GENERIC: link-attr ( tag responder -- )
|
||||
|
||||
M: object link-attr 2drop ;
|
||||
|
||||
: link-attrs ( tag -- )
|
||||
#! Side-effects current namespace.
|
||||
'[ , _ link-attr ] each-responder ;
|
||||
|
||||
: a-start-tag ( tag -- )
|
||||
[ <a [ link-attrs ] [ a-url =href ] bi a> ] with-scope ;
|
||||
|
||||
CHLOE: a
|
||||
[ a-start-tag ]
|
||||
[ process-tag-children ]
|
||||
[ drop </a> ]
|
||||
tri ;
|
||||
|
||||
: hidden-form-field ( value name -- )
|
||||
over [
|
||||
<input
|
||||
"hidden" =type
|
||||
=name
|
||||
present =value
|
||||
input/>
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: nested-forms-key "__n" ;
|
||||
|
||||
: form-magic ( tag -- )
|
||||
[ modify-form ] each-responder
|
||||
nested-forms get " " join f like nested-forms-key hidden-form-field
|
||||
"for" optional-attr [ "," split [ hidden render ] each ] when* ;
|
||||
|
||||
: form-start-tag ( tag -- )
|
||||
[
|
||||
[
|
||||
<form
|
||||
{
|
||||
[ link-attrs ]
|
||||
[ "method" optional-attr "post" or =method ]
|
||||
[ "action" required-attr resolve-base-path =action ]
|
||||
[ attrs>> non-chloe-attrs-only print-attrs ]
|
||||
} cleave
|
||||
form>
|
||||
]
|
||||
[ form-magic ] bi
|
||||
] with-scope ;
|
||||
|
||||
CHLOE: form
|
||||
[ form-start-tag ]
|
||||
[ process-tag-children ]
|
||||
[ drop </form> ]
|
||||
tri ;
|
||||
|
||||
STRING: button-tag-markup
|
||||
<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
<button type="submit"></button>
|
||||
</t:form>
|
||||
;
|
||||
|
||||
: add-tag-attrs ( attrs tag -- )
|
||||
attrs>> swap update ;
|
||||
|
||||
CHLOE: button
|
||||
button-tag-markup string>xml body>>
|
||||
{
|
||||
[ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ]
|
||||
[ [ attrs>> non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
|
||||
[ [ children>string 1array ] dip "button" tag-named (>>children) ]
|
||||
[ nip ]
|
||||
} 2cleave process-chloe-tag ;
|
||||
"furnace.chloe-tags" require
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors combinators namespaces fry
|
||||
io.servers.connection urls
|
||||
http http.server http.server.redirection http.server.filters
|
||||
furnace ;
|
||||
io.servers.connection urls http http.server
|
||||
http.server.redirection http.server.responses
|
||||
http.server.filters furnace ;
|
||||
IN: furnace.redirection
|
||||
|
||||
: <redirect> ( url -- response )
|
||||
|
|
@ -32,10 +32,14 @@ TUPLE: secure-only < filter-responder ;
|
|||
|
||||
C: <secure-only> secure-only
|
||||
|
||||
: if-secure ( quot -- )
|
||||
>r url get protocol>> "http" =
|
||||
[ url get <secure-redirect> ]
|
||||
r> if ; inline
|
||||
: secure-connection? ( -- ? ) url get protocol>> "https" = ;
|
||||
|
||||
: if-secure ( quot -- response )
|
||||
{
|
||||
{ [ secure-connection? ] [ call ] }
|
||||
{ [ request get method>> "POST" = ] [ drop <400> ] }
|
||||
[ drop url get <secure-redirect> ]
|
||||
} cond ; inline
|
||||
|
||||
M: secure-only call-responder*
|
||||
'[ , , call-next-method ] if-secure ;
|
||||
|
|
|
|||
|
|
@ -4,22 +4,7 @@ namespaces xml html.components html.forms
|
|||
splitting unicode.categories furnace accessors ;
|
||||
IN: html.templates.chloe.tests
|
||||
|
||||
[ f ] [ f parse-query-attr ] unit-test
|
||||
|
||||
[ f ] [ "" parse-query-attr ] unit-test
|
||||
|
||||
[ H{ { "a" "b" } } ] [
|
||||
begin-form
|
||||
"b" "a" set-value
|
||||
"a" parse-query-attr
|
||||
] unit-test
|
||||
|
||||
[ H{ { "a" "b" } { "c" "d" } } ] [
|
||||
begin-form
|
||||
"b" "a" set-value
|
||||
"d" "c" set-value
|
||||
"a,c" parse-query-attr
|
||||
] unit-test
|
||||
reset-templates
|
||||
|
||||
: run-template
|
||||
with-string-writer [ "\r\n\t" member? not ] filter
|
||||
|
|
|
|||
|
|
@ -1,78 +1,53 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel sequences combinators kernel namespaces
|
||||
classes.tuple assocs splitting words arrays memoize
|
||||
io io.files io.encodings.utf8 io.streams.string
|
||||
unicode.case mirrors fry math urls present
|
||||
multiline xml xml.data xml.writer xml.utilities
|
||||
USING: accessors kernel sequences combinators kernel fry
|
||||
namespaces classes.tuple assocs splitting words arrays memoize
|
||||
io io.files io.encodings.utf8 io.streams.string unicode.case
|
||||
mirrors math urls present multiline quotations xml xml.data
|
||||
html.forms
|
||||
html.elements
|
||||
html.components
|
||||
html.templates
|
||||
html.templates.chloe.compiler
|
||||
html.templates.chloe.components
|
||||
html.templates.chloe.syntax ;
|
||||
IN: html.templates.chloe
|
||||
|
||||
! Chloe is Ed's favorite web designer
|
||||
SYMBOL: tag-stack
|
||||
|
||||
TUPLE: chloe path ;
|
||||
|
||||
C: <chloe> chloe
|
||||
|
||||
DEFER: process-template
|
||||
CHLOE: chloe compile-children ;
|
||||
|
||||
: chloe-attrs-only ( assoc -- assoc' )
|
||||
[ drop url>> chloe-ns = ] assoc-filter ;
|
||||
|
||||
: non-chloe-attrs-only ( assoc -- assoc' )
|
||||
[ drop url>> chloe-ns = not ] assoc-filter ;
|
||||
|
||||
: chloe-tag? ( tag -- ? )
|
||||
dup xml? [ body>> ] when
|
||||
{
|
||||
{ [ dup tag? not ] [ f ] }
|
||||
{ [ dup url>> chloe-ns = not ] [ f ] }
|
||||
[ t ]
|
||||
} cond nip ;
|
||||
|
||||
: process-tag-children ( tag -- )
|
||||
[ process-template ] each ;
|
||||
|
||||
CHLOE: chloe process-tag-children ;
|
||||
|
||||
: children>string ( tag -- string )
|
||||
[ process-tag-children ] with-string-writer ;
|
||||
|
||||
CHLOE: title children>string set-title ;
|
||||
CHLOE: title compile-children>string [ set-title ] [code] ;
|
||||
|
||||
CHLOE: write-title
|
||||
drop
|
||||
"head" tag-stack get member?
|
||||
"title" tag-stack get member? not and
|
||||
[ <title> write-title </title> ] [ write-title ] if ;
|
||||
[ <title> write-title </title> ] [ write-title ] ? [code] ;
|
||||
|
||||
CHLOE: style
|
||||
dup "include" optional-attr dup [
|
||||
swap children>string empty? [
|
||||
"style tag cannot have both an include attribute and a body" throw
|
||||
] unless
|
||||
utf8 file-contents
|
||||
dup "include" optional-attr [
|
||||
utf8 file-contents [ add-style ] [code-with]
|
||||
] [
|
||||
drop children>string
|
||||
] if add-style ;
|
||||
compile-children>string [ add-style ] [code]
|
||||
] ?if ;
|
||||
|
||||
CHLOE: write-style
|
||||
drop <style> write-style </style> ;
|
||||
drop [ <style> write-style </style> ] [code] ;
|
||||
|
||||
CHLOE: even "index" value even? [ process-tag-children ] [ drop ] if ;
|
||||
CHLOE: even
|
||||
[ "index" value even? swap when ] process-children ;
|
||||
|
||||
CHLOE: odd "index" value odd? [ process-tag-children ] [ drop ] if ;
|
||||
CHLOE: odd
|
||||
[ "index" value odd? swap when ] process-children ;
|
||||
|
||||
: (bind-tag) ( tag quot -- )
|
||||
[
|
||||
[ "name" required-attr ] keep
|
||||
'[ , process-tag-children ]
|
||||
] dip call ; inline
|
||||
[ "name" required-attr compile-attr ] keep
|
||||
] dip process-children ; inline
|
||||
|
||||
CHLOE: each [ with-each-value ] (bind-tag) ;
|
||||
|
||||
|
|
@ -80,22 +55,23 @@ CHLOE: bind-each [ with-each-object ] (bind-tag) ;
|
|||
|
||||
CHLOE: bind [ with-form ] (bind-tag) ;
|
||||
|
||||
: error-message-tag ( tag -- )
|
||||
children>string render-error ;
|
||||
|
||||
CHLOE: comment drop ;
|
||||
|
||||
CHLOE: call-next-template drop call-next-template ;
|
||||
CHLOE: call-next-template
|
||||
drop reset-buffer \ call-next-template , ;
|
||||
|
||||
: attr>word ( value -- word/f )
|
||||
":" split1 swap lookup ;
|
||||
|
||||
: if-satisfied? ( tag -- ? )
|
||||
[ "code" optional-attr [ attr>word dup [ execute ] when ] [ t ] if* ]
|
||||
[ "value" optional-attr [ value ] [ t ] if* ]
|
||||
bi and ;
|
||||
: if>quot ( tag -- quot )
|
||||
[
|
||||
[ "code" optional-attr [ attr>word [ , ] [ f , ] if* ] [ t , ] if* ]
|
||||
[ "value" optional-attr [ , \ value , ] [ t , ] if* ]
|
||||
bi
|
||||
\ and ,
|
||||
] [ ] make ;
|
||||
|
||||
CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ;
|
||||
CHLOE: if dup if>quot [ swap when ] append process-children ;
|
||||
|
||||
CHLOE-SINGLETON: label
|
||||
CHLOE-SINGLETON: link
|
||||
|
|
@ -112,51 +88,13 @@ CHLOE-TUPLE: choice
|
|||
CHLOE-TUPLE: checkbox
|
||||
CHLOE-TUPLE: code
|
||||
|
||||
: process-chloe-tag ( tag -- )
|
||||
dup main>> dup tags get at
|
||||
[ call ] [ "Unknown chloe tag: " prepend throw ] ?if ;
|
||||
MEMO: template-quot ( chloe -- quot )
|
||||
path>> ".xml" append utf8 <file-reader> read-xml
|
||||
compile-template ;
|
||||
|
||||
: process-tag ( tag -- )
|
||||
{
|
||||
[ main>> >lower tag-stack get push ]
|
||||
[ write-start-tag ]
|
||||
[ process-tag-children ]
|
||||
[ write-end-tag ]
|
||||
[ drop tag-stack get pop* ]
|
||||
} cleave ;
|
||||
|
||||
: expand-attrs ( tag -- tag )
|
||||
dup [ tag? ] [ xml? ] bi or [
|
||||
clone [
|
||||
[ "@" ?head [ value present ] when ] assoc-map
|
||||
] change-attrs
|
||||
] when ;
|
||||
|
||||
: process-template ( xml -- )
|
||||
expand-attrs
|
||||
{
|
||||
{ [ dup chloe-tag? ] [ process-chloe-tag ] }
|
||||
{ [ dup [ tag? ] [ xml? ] bi or ] [ process-tag ] }
|
||||
{ [ t ] [ write-item ] }
|
||||
} cond ;
|
||||
|
||||
: process-chloe ( xml -- )
|
||||
[
|
||||
V{ } clone tag-stack set
|
||||
|
||||
nested-template? get [
|
||||
process-template
|
||||
] [
|
||||
{
|
||||
[ prolog>> write-prolog ]
|
||||
[ before>> write-chunk ]
|
||||
[ process-template ]
|
||||
[ after>> write-chunk ]
|
||||
} cleave
|
||||
] if
|
||||
] with-scope ;
|
||||
: reset-templates ( -- ) \ template-quot reset-memoized ;
|
||||
|
||||
M: chloe call-template*
|
||||
path>> ".xml" append utf8 <file-reader> read-xml process-chloe ;
|
||||
template-quot call ;
|
||||
|
||||
INSTANCE: chloe template
|
||||
|
|
|
|||
|
|
@ -0,0 +1,127 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs namespaces kernel sequences accessors combinators
|
||||
strings splitting io io.streams.string xml.writer xml.data
|
||||
xml.entities html.forms html.templates.chloe.syntax ;
|
||||
IN: html.templates.chloe.compiler
|
||||
|
||||
: chloe-attrs-only ( assoc -- assoc' )
|
||||
[ drop url>> chloe-ns = ] assoc-filter ;
|
||||
|
||||
: non-chloe-attrs-only ( assoc -- assoc' )
|
||||
[ drop url>> chloe-ns = not ] assoc-filter ;
|
||||
|
||||
: chloe-tag? ( tag -- ? )
|
||||
dup xml? [ body>> ] when
|
||||
{
|
||||
{ [ dup tag? not ] [ f ] }
|
||||
{ [ dup url>> chloe-ns = not ] [ f ] }
|
||||
[ t ]
|
||||
} cond nip ;
|
||||
|
||||
SYMBOL: string-buffer
|
||||
|
||||
SYMBOL: tag-stack
|
||||
|
||||
DEFER: compile-element
|
||||
|
||||
: compile-children ( tag -- )
|
||||
[ compile-element ] each ;
|
||||
|
||||
: [write] ( string -- ) string-buffer get push-all ;
|
||||
|
||||
: reset-buffer ( -- )
|
||||
string-buffer get [
|
||||
[ >string , \ write , ] [ delete-all ] bi
|
||||
] unless-empty ;
|
||||
|
||||
: [code] ( quot -- )
|
||||
reset-buffer % ;
|
||||
|
||||
: [code-with] ( obj quot -- )
|
||||
reset-buffer [ , ] [ % ] bi* ;
|
||||
|
||||
: expand-attr ( value -- )
|
||||
[ value write ] [code-with] ;
|
||||
|
||||
: compile-attr ( value -- )
|
||||
reset-buffer "@" ?head [ , \ value ] when , ;
|
||||
|
||||
: compile-attrs ( assoc -- )
|
||||
[
|
||||
" " [write]
|
||||
swap name>string [write]
|
||||
"=\"" [write]
|
||||
"@" ?head [ expand-attr ] [ escape-quoted-string [write] ] if
|
||||
"\"" [write]
|
||||
] assoc-each ;
|
||||
|
||||
: compile-start-tag ( tag -- )
|
||||
"<" [write]
|
||||
[ name>string [write] ] [ compile-attrs ] bi
|
||||
">" [write] ;
|
||||
|
||||
: compile-end-tag ( tag -- )
|
||||
"</" [write]
|
||||
name>string [write]
|
||||
">" [write] ;
|
||||
|
||||
: compile-tag ( tag -- )
|
||||
{
|
||||
[ main>> tag-stack get push ]
|
||||
[ compile-start-tag ]
|
||||
[ compile-children ]
|
||||
[ compile-end-tag ]
|
||||
[ drop tag-stack get pop* ]
|
||||
} cleave ;
|
||||
|
||||
: compile-chloe-tag ( tag -- )
|
||||
! "Unknown chloe tag: " prepend throw
|
||||
dup main>> dup tags get at
|
||||
[ curry assert-depth ] [ 2drop ] ?if ;
|
||||
|
||||
: compile-element ( element -- )
|
||||
{
|
||||
{ [ dup chloe-tag? ] [ compile-chloe-tag ] }
|
||||
{ [ dup [ tag? ] [ xml? ] bi or ] [ compile-tag ] }
|
||||
{ [ dup string? ] [ escape-string [write] ] }
|
||||
{ [ dup comment? ] [ drop ] }
|
||||
[ [ write-item ] [code-with] ]
|
||||
} cond ;
|
||||
|
||||
: with-compiler ( quot -- quot' )
|
||||
[
|
||||
SBUF" " string-buffer set
|
||||
V{ } clone tag-stack set
|
||||
call
|
||||
reset-buffer
|
||||
] [ ] make ; inline
|
||||
|
||||
: compile-nested-template ( xml -- quot )
|
||||
[ compile-element ] with-compiler ;
|
||||
|
||||
: compile-chunk ( seq -- )
|
||||
[ compile-element ] each ;
|
||||
|
||||
: process-children ( tag quot -- )
|
||||
reset-buffer
|
||||
[
|
||||
[
|
||||
SBUF" " string-buffer set
|
||||
compile-children
|
||||
reset-buffer
|
||||
] [ ] make ,
|
||||
] [ % ] bi* ;
|
||||
|
||||
: compile-children>string ( tag -- )
|
||||
[ with-string-writer ] process-children ;
|
||||
|
||||
: compile-template ( xml -- quot )
|
||||
[
|
||||
{
|
||||
[ prolog>> [ write-prolog ] [code-with] ]
|
||||
[ before>> compile-chunk ]
|
||||
[ compile-element ]
|
||||
[ after>> compile-chunk ]
|
||||
} cleave
|
||||
] with-compiler ;
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs sequences kernel parser fry quotations
|
||||
classes.tuple
|
||||
html.components
|
||||
html.templates.chloe.compiler
|
||||
html.templates.chloe.syntax ;
|
||||
IN: html.templates.chloe.components
|
||||
|
||||
: singleton-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 -- )
|
||||
[ drop "name" required-attr compile-attr ] [ compile-component-attrs ] 2bi
|
||||
[ render ] [code] ;
|
||||
|
||||
: CHLOE-TUPLE:
|
||||
scan-word
|
||||
[ name>> ] [ '[ , tuple-component-tag ] ] bi
|
||||
define-chloe-tag ;
|
||||
parsing
|
||||
|
|
@ -21,7 +21,7 @@ tags global [ H{ } clone or ] change-at
|
|||
|
||||
: chloe-ns "http://factorcode.org/chloe/1.0" ; inline
|
||||
|
||||
MEMO: chloe-name ( string -- name )
|
||||
: chloe-name ( string -- name )
|
||||
name new
|
||||
swap >>main
|
||||
chloe-ns >>url ;
|
||||
|
|
@ -32,30 +32,3 @@ MEMO: chloe-name ( string -- name )
|
|||
|
||||
: optional-attr ( tag name -- value )
|
||||
chloe-name swap at ;
|
||||
|
||||
: singleton-component-tag ( tag class -- )
|
||||
[ "name" required-attr ] dip render ;
|
||||
|
||||
: CHLOE-SINGLETON:
|
||||
scan-word
|
||||
[ name>> ] [ '[ , singleton-component-tag ] ] bi
|
||||
define-chloe-tag ;
|
||||
parsing
|
||||
|
||||
: attrs>slots ( tag tuple -- )
|
||||
[ attrs>> ] [ <mirror> ] bi*
|
||||
'[
|
||||
swap main>> dup "name" =
|
||||
[ 2drop ] [ , set-at ] if
|
||||
] assoc-each ;
|
||||
|
||||
: tuple-component-tag ( tag class -- )
|
||||
[ drop "name" required-attr ]
|
||||
[ new [ attrs>slots ] keep ]
|
||||
2bi render ;
|
||||
|
||||
: CHLOE-TUPLE:
|
||||
scan-word
|
||||
[ name>> ] [ '[ , tuple-component-tag ] ] bi
|
||||
define-chloe-tag ;
|
||||
parsing
|
||||
|
|
|
|||
|
|
@ -37,10 +37,11 @@ SYMBOL: indenter
|
|||
[ [ empty? ] [ string? ] bi and not ] filter
|
||||
] when ;
|
||||
|
||||
: name>string ( name -- string )
|
||||
[ main>> ] [ space>> ] bi [ ":" swap 3append ] unless-empty ;
|
||||
|
||||
: print-name ( name -- )
|
||||
dup space>> f like
|
||||
[ write CHAR: : write1 ] when*
|
||||
main>> write ;
|
||||
name>string write ;
|
||||
|
||||
: print-attrs ( assoc -- )
|
||||
[
|
||||
|
|
|
|||
Loading…
Reference in New Issue