Merge branch 'master' into public

* master:
  Minor tweak
  Wiki: cache Farkup HTML output
  Major Chloe overhaul: compiled templatess
  Better logging
  Fix bug spotted by Ed
  Remove unnecessary dependency on peg.expr
  Tweak stage2
  Tweak deploy tests to take less time
  Removing multimehtod dependency in perisistent.heaps
  Fixing xml.generator tests

basis/bootstrap/stage2.factor

@@ -50,7 +50,7 @@ SYMBOL: bootstrap-time
 
     default-image-name "output-image" set-global
 
-    "threads math compiler help io random tools ui ui.tools unicode handbook" "include" set-global
+    "math compiler threads help io tools ui ui.tools random unicode handbook" "include" set-global
     "" "exclude" set-global
 
     parse-command-line

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/http/http.factor

@@ -113,7 +113,7 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s
                 { [ dup real? ] [ number>string ] }
                 [ ]
             } cond
-            check-cookie-string "=" swap check-cookie-string 3append ,
+            [ check-cookie-string ] bi@ "=" swap 3append ,
         ]
     } case ;
 

basis/io/servers/connection/connection.factor

@@ -73,7 +73,7 @@ M: threaded-server handle-client* handler>> call ;
     ] with-stream ;
 
 : thread-name ( server-name addrspec -- string )
-    unparse " connection from " swap 3append ;
+    unparse-short " connection from " swap 3append ;
 
 : accept-connection ( threaded-server -- )
     [ accept ] [ addr>> ] bi

basis/persistent/heaps/heaps.factor

@@ -1,4 +1,4 @@
-USING: kernel accessors multi-methods locals combinators math arrays
+USING: kernel accessors locals combinators math arrays
 assocs namespaces sequences ;
 IN: persistent.heaps
 ! These are minheaps
@@ -36,14 +36,15 @@ PRIVATE>
 
 GENERIC: sift-down ( value prio left right -- heap )
 
-METHOD: sift-down { empty-heap empty-heap } <branch> ;
+: singleton-sift-down ( value prio singleton empty -- heap )
-
-METHOD: sift-down { singleton-heap empty-heap }
     3dup drop prio>> <= [ <branch> ] [
         drop -rot [ [ value>> ] [ prio>> ] bi ] 2dip
         <singleton-heap> <persistent-heap> <branch>
     ] if ;
 
+M: empty-heap sift-down 
+    over singleton-heap? [ singleton-sift-down ] [ <branch> ] if ;
+
 :: reroot-left ( value prio left right -- heap )
     left value>> left prio>>
     value prio left left>> left right>> sift-down
@@ -54,7 +55,7 @@ METHOD: sift-down { singleton-heap empty-heap }
     value prio right left>> right right>> sift-down
     <branch> ;
 
-METHOD: sift-down { branch branch }
+M: branch sift-down ! both arguments are branches
     3dup [ prio>> <= ] both-with? [ <branch> ] [
         2dup [ prio>> ] bi@ <= [ reroot-left ] [ reroot-right ] if
     ] if ;

basis/tools/deploy/backend/backend.factor

@@ -42,9 +42,9 @@ IN: tools.deploy.backend
 
 : bootstrap-profile ( -- profile )
     {
-        { "threads"  deploy-threads?  }
         { "math"     deploy-math?     }
         { "compiler" deploy-compiler? }
+        { "threads"  deploy-threads?  }
         { "ui"       deploy-ui?       }
         { "random"   deploy-random?   }
     } [ nip get ] assoc-filter keys

basis/tools/deploy/deploy-tests.factor

@@ -26,7 +26,7 @@ namespaces continuations layouts accessors ;
 
 [ t ] [ 1300000 small-enough? ] unit-test
 
-[ "staging.threads-math-compiler-ui-strip.image" ] [
+[ "staging.math-compiler-threads-ui-strip.image" ] [
     "hello-ui" deploy-config
     [ bootstrap-profile staging-image-name file-name ] bind
 ] unit-test
@@ -39,9 +39,9 @@ namespaces continuations layouts accessors ;
 ! 
 ! [ t ] [ 1500000 small-enough? ] unit-test
 ! 
-! [ ] [ "bunny" shake-and-bake ] unit-test
+[ ] [ "bunny" shake-and-bake ] unit-test
-! 
+
-! [ t ] [ 2500000 small-enough? ] unit-test
+[ t ] [ 2500000 small-enough? ] unit-test
 
 {
     "tools.deploy.test.1"

basis/tools/deploy/test/1/deploy.factor

@@ -1,15 +1,15 @@
 USING: tools.deploy.config ;
 H{
-    { deploy-c-types? f }
-    { deploy-name "tools.deploy.test.1" }
-    { deploy-io 2 }
-    { deploy-random? f }
-    { deploy-math? t }
-    { deploy-compiler? t }
-    { deploy-reflection 2 }
-    { "stop-after-last-window?" t }
     { deploy-threads? t }
+    { deploy-random? f }
+    { deploy-c-types? f }
     { deploy-ui? f }
     { deploy-word-props? f }
     { deploy-word-defs? f }
+    { deploy-math? t }
+    { deploy-io 2 }
+    { deploy-name "tools.deploy.test.1" }
+    { deploy-compiler? t }
+    { deploy-reflection 1 }
+    { "stop-after-last-window?" t }
 }

basis/tools/deploy/test/2/deploy.factor

@@ -1,15 +1,15 @@
 USING: tools.deploy.config ;
 H{
-    { deploy-io 2 }
-    { deploy-ui? f }
     { deploy-threads? t }
+    { deploy-random? f }
     { deploy-c-types? f }
+    { deploy-ui? f }
+    { deploy-word-props? f }
+    { deploy-word-defs? f }
+    { deploy-math? t }
+    { deploy-io 2 }
     { deploy-name "tools.deploy.test.2" }
     { deploy-compiler? t }
-    { deploy-word-props? f }
+    { deploy-reflection 1 }
-    { deploy-reflection 2 }
-    { deploy-word-defs? f }
     { "stop-after-last-window?" t }
-    { deploy-random? f }
-    { deploy-math? t }
 }

basis/tools/deploy/test/3/deploy.factor

@@ -1,15 +1,15 @@
 USING: tools.deploy.config ;
 H{
-    { deploy-io 3 }
-    { deploy-ui? f }
     { deploy-threads? t }
+    { deploy-random? f }
     { deploy-c-types? f }
+    { deploy-ui? f }
+    { deploy-word-props? f }
+    { deploy-word-defs? f }
+    { deploy-math? t }
+    { deploy-io 3 }
     { deploy-name "tools.deploy.test.3" }
     { deploy-compiler? t }
-    { deploy-word-props? f }
+    { deploy-reflection 1 }
-    { deploy-reflection 2 }
-    { deploy-word-defs? f }
     { "stop-after-last-window?" t }
-    { deploy-random? f }
-    { deploy-math? t }
 }

basis/tools/deploy/test/4/deploy.factor

@@ -1,15 +1,15 @@
 USING: tools.deploy.config ;
 H{
-    { deploy-io 2 }
-    { deploy-ui? f }
     { deploy-threads? t }
+    { deploy-random? f }
     { deploy-c-types? f }
+    { deploy-ui? f }
+    { deploy-word-props? f }
+    { deploy-word-defs? f }
+    { deploy-math? t }
+    { deploy-io 2 }
     { deploy-name "tools.deploy.test.4" }
     { deploy-compiler? t }
-    { deploy-word-props? f }
+    { deploy-reflection 1 }
-    { deploy-reflection 2 }
-    { deploy-word-defs? f }
     { "stop-after-last-window?" t }
-    { deploy-random? f }
-    { deploy-math? t }
 }

basis/tools/deploy/test/5/deploy.factor

@@ -1,15 +1,15 @@
 USING: tools.deploy.config ;
 H{
-    { deploy-io 3 }
-    { deploy-ui? f }
     { deploy-threads? t }
+    { deploy-random? f }
     { deploy-c-types? f }
+    { deploy-ui? f }
+    { deploy-word-props? f }
+    { deploy-word-defs? f }
+    { deploy-math? t }
+    { deploy-io 3 }
     { deploy-name "tools.deploy.test.5" }
     { deploy-compiler? t }
-    { deploy-word-props? f }
+    { deploy-reflection 1 }
-    { deploy-reflection 2 }
-    { deploy-word-defs? f }
     { "stop-after-last-window?" t }
-    { deploy-random? f }
-    { deploy-math? t }
 }

basis/xml/generator/generator-tests.factor

@@ -1,3 +1,3 @@
-USING: tools.test io.streams.string xml.generator xml.writer ;
+USING: tools.test io.streams.string xml.generator xml.writer accessors ;
 [ "<html><body><a href=\"blah\"/></body></html>" ]
-[ "html" [ "body" [ "a" { { "href" "blah" } } contained*, ] tag, ] make-xml [ write-item ] with-string-writer ] unit-test
+[ "html" [ "body" [ "a" { { "href" "blah" } } contained*, ] tag, ] make-xml [ body>> write-item ] with-string-writer ] unit-test

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 -- )
     [

extra/lisp/parser/parser.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 James Cash
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel peg peg.ebnf peg.expr math.parser sequences arrays strings
+USING: kernel peg peg.ebnf math.parser sequences arrays strings
 combinators.lib math fry accessors lists combinators.short-circuit ;
 
 IN: lisp.parser

extra/webapps/wiki/view.xml

@@ -5,7 +5,7 @@
 	<t:title><t:label t:name="title" /></t:title>
 
 	<div class="description">
-		<t:farkup t:name="content" />
+		<t:html t:name="html" />
 	</div>
 
 	<p>

extra/webapps/wiki/wiki-common.xml

@@ -41,7 +41,7 @@
 							</t:a>
 						</h2>
 		
-						<t:farkup t:name="content" />
+						<t:html t:name="html" />
 					</t:bind>
 				</td>
 			</t:if>
@@ -52,7 +52,7 @@
 				<td>
 					<t:bind t:name="footer">
 						<small>
-							<t:farkup t:name="content" />
+							<t:html t:name="html" />
 						</small>
 					</t:bind>
 				</td>

extra/webapps/wiki/wiki.factor

@@ -3,7 +3,7 @@
 USING: accessors kernel hashtables calendar random assocs
 namespaces splitting sequences sorting math.order present
 io.files io.encodings.ascii
-syndication
+syndication farkup
 html.components html.forms
 http.server
 http.server.dispatchers
@@ -47,7 +47,7 @@ article "ARTICLES" {
 
 : <article> ( title -- article ) article new swap >>title ;
 
-TUPLE: revision id title author date content description ;
+TUPLE: revision id title author date content html description ;
 
 revision "REVISIONS" {
     { "id" "ID" INTEGER +db-assigned-id+ }
@@ -55,6 +55,7 @@ revision "REVISIONS" {
     { "author" "AUTHOR" { VARCHAR 256 } +not-null+ } ! uid
     { "date" "DATE" TIMESTAMP +not-null+ }
     { "content" "CONTENT" TEXT +not-null+ }
+    { "html" "HTML" TEXT +not-null+ } ! Farkup converted to HTML
     { "description" "DESCRIPTION" TEXT }
 } define-persistent
 
@@ -71,6 +72,9 @@ M: revision feed-entry-url id>> revision-url ;
 : <revision> ( id -- revision )
     revision new swap >>id ;
 
+: compute-html ( revision -- )
+    dup content>> convert-farkup >>html drop ;
+
 : validate-title ( -- )
     { { "title" [ v-one-line ] } } validate-params ;
 
@@ -144,11 +148,13 @@ M: revision feed-entry-url id>> revision-url ;
     [ title>> ] [ id>> ] bi article boa insert-tuple ;
 
 : add-revision ( revision -- )
+    [ compute-html ]
     [ insert-tuple ]
     [
         dup title>> <article> select-tuple
         [ amend-article ] [ add-article ] if*
-    ] bi ;
+    ]
+    tri ;
 
 : <edit-article-action> ( -- action )
     <page-action>

extra/websites/concatenative/concatenative.factor

@@ -4,6 +4,7 @@ USING: accessors kernel sequences assocs io.files io.sockets
 io.sockets.secure io.servers.connection
 namespaces db db.tuples db.sqlite smtp urls
 logging.insomniac
+html.templates.chloe
 http.server
 http.server.dispatchers
 http.server.redirection
@@ -68,6 +69,7 @@ SYMBOL: key-file
 SYMBOL: dh-file
 
 : common-configuration ( -- )
+    reset-templates
     "concatenative.org" 25 <inet> smtp-server set-global
     "noreply@concatenative.org" lost-password-from set-global
     "website@concatenative.org" insomniac-sender set-global