Major Chloe overhaul: compiled templatess

basis/furnace/auth/auth.factor

@@ -134,22 +134,21 @@ TUPLE: protected < filter-responder description capabilities ;
         swap >>responder ;
 
 : have-capabilities? ( capabilities -- ? )
-    logged-in-user get {
+    realm get secure>> secure-connection? not and [ drop f ] [
-        { [ dup not ] [ 2drop f ] }
+        logged-in-user get {
-        { [ dup deleted>> 1 = ] [ 2drop f ] }
+            { [ dup not ] [ 2drop f ] }
-        [ capabilities>> subset? ]
+            { [ dup deleted>> 1 = ] [ 2drop f ] }
-    } cond ;
+            [ capabilities>> subset? ]
+        } cond
+    ] if ;
 
 M: protected call-responder* ( path responder -- response )
-    '[
+    dup protected set
-        , ,
+    dup capabilities>> have-capabilities?
-        dup protected set
+    [ call-next-method ] [
-        dup capabilities>> have-capabilities?
+        [ drop ] [ [ description>> ] [ capabilities>> ] bi ] bi*
-        [ call-next-method ] [
+        realm get login-required*
-            [ drop ] [ [ description>> ] [ capabilities>> ] bi ] bi*
+    ] if ;
-            realm get login-required*
-        ] if
-    ] if-secure-realm ;
 
 : <auth-boilerplate> ( responder -- responder' )
     <boilerplate> { realm "boilerplate" } >>template ;

basis/furnace/auth/features/registration/registration.factor

@@ -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 ;

basis/furnace/chloe-tags/chloe-tags-tests.factor

@@ -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

basis/furnace/chloe-tags/chloe-tags.factor

@@ -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 ;

basis/furnace/conversations/conversations.factor

@@ -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

basis/furnace/furnace.factor

@@ -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
+USING: namespaces assocs sequences kernel classes splitting
-continuations namespaces sequences splitting words
+vocabs.loader accessors strings combinators arrays
-vocabs.loader classes strings
+continuations present fry
-fry urls multiline present
+urls html.elements
-xml
+http http.server http.server.redirection ;
-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 ;
 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
+"furnace.chloe-tags" require
-: 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 ;

basis/furnace/redirection/redirection.factor

@@ -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
+io.servers.connection urls http http.server
-http http.server http.server.redirection http.server.filters
+http.server.redirection http.server.responses
-furnace ;
+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 -- )
+: secure-connection? ( -- ? ) url get protocol>> "https" = ;
-    >r url get protocol>> "http" =
+
-    [ url get <secure-redirect> ]
+: if-secure ( quot -- response )
-    r> if ; inline
+    {
+        { [ 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 ;

basis/html/templates/chloe/chloe-tests.factor

@@ -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
+reset-templates
-
-[ 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
 
 : run-template
     with-string-writer [ "\r\n\t" member? not ] filter

basis/html/templates/chloe/chloe.factor

@@ -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
+USING: accessors kernel sequences combinators kernel fry
-classes.tuple assocs splitting words arrays memoize
+namespaces classes.tuple assocs splitting words arrays memoize
-io io.files io.encodings.utf8 io.streams.string
+io io.files io.encodings.utf8 io.streams.string unicode.case
-unicode.case mirrors fry math urls present
+mirrors math urls present multiline quotations xml xml.data
-multiline xml xml.data xml.writer xml.utilities
 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' )
+CHLOE: title compile-children>string [ set-title ] [code] ;
-    [ 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: 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 [
+    dup "include" optional-attr [
-        swap children>string empty? [
+        utf8 file-contents [ add-style ] [code-with]
-            "style tag cannot have both an include attribute and a body" throw
-        ] unless
-        utf8 file-contents
     ] [
-        drop children>string
+        compile-children>string [ add-style ] [code]
-    ] if add-style ;
+    ] ?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
+        [ "name" required-attr compile-attr ] keep
-        '[ , process-tag-children ]
+    ] dip process-children ; inline
-    ] dip call ; 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 -- ? )
+: if>quot ( tag -- quot )
-    [ "code" optional-attr [ attr>word dup [ execute ] when ] [ t ] if* ]
+    [
-    [ "value" optional-attr [ value ] [ t ] if* ]
+        [ "code" optional-attr [ attr>word [ , ] [ f , ] if* ] [ t , ] if* ]
-    bi and ;
+        [ "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 -- )
+MEMO: template-quot ( chloe -- quot )
-    dup main>> dup tags get at
+    path>> ".xml" append utf8 <file-reader> read-xml
-    [ call ] [ "Unknown chloe tag: " prepend throw ] ?if ;
+    compile-template ;
 
-: process-tag ( tag -- )
+: reset-templates ( -- ) \ template-quot reset-memoized ;
-    {
-        [ 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 ;
 
 M: chloe call-template*
-    path>> ".xml" append utf8 <file-reader> read-xml process-chloe ;
+    template-quot call ;
 
 INSTANCE: chloe template

basis/html/templates/chloe/compiler/compiler.factor

@@ -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 ;

basis/html/templates/chloe/components/components.factor

@@ -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

basis/html/templates/chloe/syntax/syntax.factor

@@ -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

basis/xml/writer/writer.factor

@@ -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
+    name>string write ;
-    [ write CHAR: : write1 ] when*
-    main>> write ;
 
 : print-attrs ( assoc -- )
     [