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

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/farkup/farkup-docs.factor

@@ -1,6 +1,51 @@
-USING: help.markup help.syntax ;
+USING: help.markup help.syntax strings io ;
 IN: farkup
 
 HELP: convert-farkup
-{ $values { "string" "a string" } { "string'" "a string" } }
+{ $values { "string" string } { "string'" string } }
-{ $description "Parse a string as farkup (Factor mARKUP) and output the result aas an string of HTML." } ;
+{ $description "Parse a Farkup string and convert it to an HTML string." } ;
+
+HELP: write-farkup
+{ $values { "string" string } }
+{ $description "Parse a Farkup string and writes the resulting HTML to " { $link output-stream } "." } ;
+
+HELP: farkup ( string -- farkup )
+{ $values { "string" string } { "farkup" "a Farkup syntax tree node" } }
+{ $description "Parses Farkup and outputs a tree of " { $link "farkup-ast" } "." } ;
+
+HELP: (write-farkup)
+{ $values { "farkup" "a Farkup syntax tree node" } }
+{ $description "Writes a Farkup syntax tree as HTML on " { $link output-stream } "." } ;
+
+ARTICLE: "farkup-ast" "Farkup syntax tree nodes"
+"The " { $link farkup } " word outputs a tree of nodes corresponding to the Farkup syntax of the input string. This tree can be programatically traversed and mutated before being passed on to " { $link write-farkup } "."
+{ $subsection heading1 }
+{ $subsection heading2 }
+{ $subsection heading3 }
+{ $subsection heading4 }
+{ $subsection strong }
+{ $subsection emphasis }
+{ $subsection superscript }
+{ $subsection subscript }
+{ $subsection inline-code }
+{ $subsection paragraph }
+{ $subsection list-item }
+{ $subsection list }
+{ $subsection table }
+{ $subsection table-row }
+{ $subsection link }
+{ $subsection image }
+{ $subsection code } ;
+
+ARTICLE: "farkup" "Farkup"
+"The " { $vocab-link "farkup" } " vocabulary implements Farkup (Factor mARKUP), a simple markup language. Farkup was loosely based on the markup languages employed by MediaWiki and " { $url "http://reddit.com" } "."
+$nl
+"The main entry points for converting Farkup to HTML:"
+{ $subsection convert-farkup }
+{ $subsection write-farkup }
+"The syntax tree of a piece of Farkup can also be inspected and modified:"
+{ $subsection farkup }
+{ $subsection (write-farkup) }
+{ $subsection "farkup-ast" } ;
+
+ABOUT: "farkup"

basis/farkup/farkup-tests.factor

@@ -1,8 +1,11 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: farkup kernel peg peg.ebnf tools.test ;
+USING: farkup kernel peg peg.ebnf tools.test namespaces ;
 IN: farkup.tests
 
+[ "Baz" ] [ "Foo/Bar/Baz" simple-link-title ] unit-test
+[ "Baz" ] [ "Baz" simple-link-title ] unit-test
+
 [ ] [
     "abcd-*strong*\nasdifj\nweouh23ouh23"
     "paragraph" \ farkup rule parse drop
@@ -81,10 +84,15 @@ IN: farkup.tests
 [ "<pre><span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span>\n</pre>" ]
 [ "[c{int main()}]" convert-farkup ] unit-test
 
-[ "<p><img src=\"lol.jpg\"/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
+[ "<p><img src='lol.jpg'/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
-[ "<p><img src=\"lol.jpg\" alt=\"teh lol\"/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
+[ "<p><img src='lol.jpg' alt='teh lol'/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
-[ "<p><a href=\"lol.com\">lol.com</a></p>" ] [ "[[lol.com]]" convert-farkup ] unit-test
+[ "<p><a href='http://lol.com'>http://lol.com</a></p>" ] [ "[[http://lol.com]]" convert-farkup ] unit-test
-[ "<p><a href=\"lol.com\">haha</a></p>" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test
+[ "<p><a href='http://lol.com'>haha</a></p>" ] [ "[[http://lol.com|haha]]" convert-farkup ] unit-test
+[ "<p><a href='Foo/Bar'>Bar</a></p>" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
+
+"/wiki/view/" relative-link-prefix [
+    [ "<p><a href='/wiki/view/Foo/Bar'>Bar</a></p>" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
+] with-variable
 
 [ ] [ "[{}]" convert-farkup drop ] unit-test
 

basis/farkup/farkup.factor

@@ -28,6 +28,12 @@ TUPLE: link href text ;
 TUPLE: image href text ;
 TUPLE: code mode string ;
 
+: absolute-url? ( string -- ? )
+    { "http://" "https://" "ftp://" } [ head? ] with contains? ;
+
+: simple-link-title ( string -- string' )
+    dup absolute-url? [ "/" last-split1 swap or ] unless ;
+
 EBNF: farkup
 nl               = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]]
 2nl              = nl nl
@@ -67,7 +73,7 @@ image-link       = "[[image:" (!("|") .)+  "|" (!("]]").)+ "]]"
                     => [[ second >string f image boa ]]
 
 simple-link      = "[[" (!("|]" | "]]") .)+ "]]"
-    => [[ second >string dup link boa ]]
+    => [[ second >string dup simple-link-title link boa ]]
 
 labelled-link    = "[[" (!("|") .)+ "|" (!("]]").)+ "]]"
     => [[ [ second >string ] [ fourth >string ] bi link boa ]]
@@ -119,31 +125,26 @@ stand-alone
         { [ dup empty? ] [ drop invalid-url ] }
         { [ dup [ 127 > ] contains? ] [ drop invalid-url ] }
         { [ dup first "/\\" member? ] [ drop invalid-url ] }
-        { [ CHAR: : over member? ] [
+        { [ CHAR: : over member? ] [ dup absolute-url? [ drop invalid-url ] unless ] }
-            dup { "http://" "https://" "ftp://" } [ head? ] with contains?
-            [ drop invalid-url ] unless
-        ] }
         [ relative-link-prefix get prepend ]
     } cond ;
 
 : escape-link ( href text -- href-esc text-esc )
     >r check-url escape-quoted-string r> escape-string ;
 
-: write-link ( text href -- )
+: write-link ( href text -- )
     escape-link
-    "<a" write
+    [ <a =href link-no-follow? get [ "true" =nofollow ] when a> ]
-    " href=\"" write write "\"" write
+    [ write </a> ]
-    link-no-follow? get [ " nofollow=\"true\"" write ] when
+    bi* ;
-    ">" write write "</a>" write ;
 
 : write-image-link ( href text -- )
     disable-images? get [
-        2drop "<strong>Images are not allowed</strong>" write
+        2drop
+        <strong> "Images are not allowed" write </strong>
     ] [
         escape-link
-        >r "<img src=\"" write write "\"" write r>
+        [ <img =src ] [ [ =alt ] unless-empty img/> ] bi*
-        [ " alt=\"" write write "\"" write ] unless-empty
-        "/>" write
     ] if ;
 
 : render-code ( string mode -- string' )
@@ -154,32 +155,35 @@ stand-alone
         </pre>
     ] with-string-writer write ;
 
-GENERIC: write-farkup ( obj -- )
+GENERIC: (write-farkup) ( farkup -- )
 : <foo.> ( string -- ) <foo> write ;
 : </foo.> ( string -- ) </foo> write ;
 : in-tag. ( obj quot string -- ) [ <foo.> call ] keep </foo.> ; inline
-M: heading1 write-farkup ( obj -- ) [ obj>> write-farkup ] "h1" in-tag. ;
+M: heading1 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h1" in-tag. ;
-M: heading2 write-farkup ( obj -- ) [ obj>> write-farkup ] "h2" in-tag. ;
+M: heading2 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h2" in-tag. ;
-M: heading3 write-farkup ( obj -- ) [ obj>> write-farkup ] "h3" in-tag. ;
+M: heading3 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h3" in-tag. ;
-M: heading4 write-farkup ( obj -- ) [ obj>> write-farkup ] "h4" in-tag. ;
+M: heading4 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h4" in-tag. ;
-M: strong write-farkup ( obj -- ) [ obj>> write-farkup ] "strong" in-tag. ;
+M: strong (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "strong" in-tag. ;
-M: emphasis write-farkup ( obj -- ) [ obj>> write-farkup ] "em" in-tag. ;
+M: emphasis (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "em" in-tag. ;
-M: superscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sup" in-tag. ;
+M: superscript (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "sup" in-tag. ;
-M: subscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sub" in-tag. ;
+M: subscript (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "sub" in-tag. ;
-M: inline-code write-farkup ( obj -- ) [ obj>> write-farkup ] "code" in-tag. ;
+M: inline-code (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "code" in-tag. ;
-M: list-item write-farkup ( obj -- ) [ obj>> write-farkup ] "li" in-tag. ;
+M: list-item (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "li" in-tag. ;
-M: list write-farkup ( obj -- ) [ obj>> write-farkup ] "ul" in-tag. ;
+M: list (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "ul" in-tag. ;
-M: paragraph write-farkup ( obj -- ) [ obj>> write-farkup ] "p" in-tag. ;
+M: paragraph (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "p" in-tag. ;
-M: link write-farkup ( obj -- ) [ text>> ] [ href>> ] bi write-link ;
+M: link (write-farkup) ( obj -- ) [ href>> ] [ text>> ] bi write-link ;
-M: image write-farkup ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ;
+M: image (write-farkup) ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ;
-M: code write-farkup ( obj -- ) [ string>> ] [ mode>> ] bi render-code ;
+M: code (write-farkup) ( obj -- ) [ string>> ] [ mode>> ] bi render-code ;
-M: table-row write-farkup ( obj -- )
+M: table-row (write-farkup) ( obj -- )
-    obj>> [ [ [ write-farkup ] "td" in-tag. ] each ] "tr" in-tag. ;
+    obj>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ;
-M: table write-farkup ( obj -- ) [ obj>> write-farkup ] "table" in-tag. ;
+M: table (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "table" in-tag. ;
-M: fixnum write-farkup ( obj -- ) write1 ;
+M: fixnum (write-farkup) ( obj -- ) write1 ;
-M: string write-farkup ( obj -- ) write ;
+M: string (write-farkup) ( obj -- ) write ;
-M: vector write-farkup ( obj -- ) [ write-farkup ] each ;
+M: vector (write-farkup) ( obj -- ) [ (write-farkup) ] each ;
-M: f write-farkup ( obj -- ) drop ;
+M: f (write-farkup) ( obj -- ) drop ;
+
+: write-farkup ( string -- )
+    farkup (write-farkup) ;
 
 : convert-farkup ( string -- string' )
-    farkup [ write-farkup ] with-string-writer ;
+    farkup [ (write-farkup) ] with-string-writer ;

basis/furnace/auth/auth.factor

@@ -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 ;
-    ] 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,126 @@
+! 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-with-scope ;
+
+: 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
+    ] compile-with-scope ;
+
+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/components/components.factor

@@ -156,7 +156,7 @@ M: farkup render*
     [
         [ no-follow>> [ string>boolean link-no-follow? set ] when* ]
         [ disable-images>> [ string>boolean disable-images? set ] when* ] bi
-        drop string-lines "\n" join convert-farkup write
+        drop string-lines "\n" join write-farkup
     ] with-scope ;
 
 ! Inspector component

basis/html/elements/elements.factor

@@ -142,6 +142,7 @@ SYMBOL: html
     "ol" "li" "form" "a" "p" "html" "head" "body" "title"
     "b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
     "script" "div" "span" "select" "option" "style" "input"
+    "strong"
 ] [ define-closed-html-word ] each
 
 ! Define some open HTML tags
@@ -160,6 +161,8 @@ SYMBOL: html
     "src" "language" "colspan" "onchange" "rel"
     "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
     "media" "title" "multiple" "checked"
+    "summary" "cellspacing" "align" "scope" "abbr"
+    "nofollow" "alt"
 ] [ define-attribute-word ] each
 
 >>

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,21 @@ CHLOE-TUPLE: choice
 CHLOE-TUPLE: checkbox
 CHLOE-TUPLE: code
 
-: process-chloe-tag ( tag -- )
+: read-template ( chloe -- xml )
-    dup main>> dup tags get at
+    path>> ".xml" append utf8 <file-reader> read-xml ;
-    [ call ] [ "Unknown chloe tag: " prepend throw ] ?if ;
 
-: process-tag ( tag -- )
+MEMO: template-quot ( chloe -- quot )
-    {
+    read-template compile-template ;
-        [ 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 )
+MEMO: nested-template-quot ( chloe -- quot )
-    dup [ tag? ] [ xml? ] bi or [
+    read-template compile-nested-template ;
-        clone [
-            [ "@" ?head [ value present ] when ] assoc-map
-        ] change-attrs
-    ] when ;
 
-: process-template ( xml -- )
+: reset-templates ( -- )
-    expand-attrs
+    { template-quot nested-template-quot } [ reset-memoized ] each ;
-    {
-        { [ 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 ;
+    nested-template? get
+    [ nested-template-quot ] [ template-quot ] if
+    assert-depth ;
 
 INSTANCE: chloe template

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

@@ -0,0 +1,131 @@
+! 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 present 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 present write ] [code-with] ;
+
+: compile-attr ( value -- )
+    reset-buffer "@" ?head [ , [ value present ] % ] [ , ] if ;
+
+: 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 ;
+
+: compile-quot ( quot -- )
+    reset-buffer
+    [
+        SBUF" " string-buffer set
+        call
+        reset-buffer
+    ] [ ] make , ; inline
+
+: process-children ( tag quot -- )
+    [ [ compile-children ] compile-quot ] [ % ] bi* ; inline
+
+: compile-children>string ( tag -- )
+     [ with-string-writer ] process-children ;
+
+: compile-with-scope ( quot -- )
+    compile-quot [ with-scope ] [code] ; inline
+
+: 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/locals/locals-tests.factor

@@ -316,3 +316,17 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
 ! [ f ] [ 3 wlet-&&-test ] unit-test
 ! [ f ] [ 8 wlet-&&-test ] unit-test
 ! [ t ] [ 12 wlet-&&-test ] unit-test
+
+[ { 10       } ] [ 10       [| a     | { a     } ] call ] unit-test
+[ { 10 20    } ] [ 10 20    [| a b   | { a b   } ] call ] unit-test
+[ { 10 20 30 } ] [ 10 20 30 [| a b c | { a b c } ] call ] unit-test
+
+[ { 10 20 30 } ] [ [let | a [ 10 ] b [ 20 ] c [ 30 ] | { a b c } ] ] unit-test
+
+[ V{ 10 20 30 } ] [ 10 20 30 [| a b c | V{ a b c } ] call ] unit-test
+
+[ H{ { 10 "a" } { 20 "b" } { 30 "c" } } ]
+[ 10 20 30 [| a b c | H{ { a "a" } { b "b" } { c "c" } } ] call ] unit-test
+
+[ T{ slice f 0 3 "abc" } ]
+[ 0 3 "abc" [| from to seq | T{ slice f from to seq } ] call ] unit-test

basis/logging/logging.factor

@@ -46,6 +46,7 @@ SYMBOL: log-service
     dup array? [ dup length 1 = [ first ] when ] when
     dup string? [
         [
+            boa-tuples? on
             string-limit? off
             1 line-limit set
             3 nesting-limit set

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-tests.factor

@@ -0,0 +1,5 @@
+IN: xml.writer.tests
+USING: xml.data xml.writer tools.test ;
+
+[ "foo" ] [ T{ name { main "foo" } } name>string ] unit-test
+[ "ns:foo" ] [ T{ name { space "ns" } { main "foo" } } name>string ] 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 [ ":" rot 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/initial-content/Farkup.txt

@@ -34,7 +34,7 @@ CAN HAS STDIO?
 VISIBLE "HAI WORLD!"
 KTHXBYE}]
 
-There is syntax highlighting various languages, too:
+There is syntax highlighting for various languages, too:
 
 [factor{PEG: parse-request-line ( string -- triple )
     #! Triple is { method url version }

extra/webapps/wiki/initial-content/Front Page.txt

@@ -1,5 +1,3 @@
 Congratulations, you are now running your very own Wiki.
 
-You can now click *Edit* below and begin editing the content of the [[Front Page]]. This Wiki uses [[Farkup]] to mark up text.
+You can now click *Edit* below and begin editing the content of the [[Front Page]]. More information at [[Wiki Help]].
-
-Two special article names are recognized by the Wiki: [[Sidebar]] and [[Footer]]. They do not exist by default, but if you create them, they will be visible on every page.

extra/webapps/wiki/initial-content/Wiki Help.txt

@@ -0,0 +1,5 @@
+This Wiki uses [[Farkup]] to mark up text.
+
+Two special article names are recognized by the Wiki: [[Sidebar]] and [[Footer]]. They do not exist by default, but if you create them, they will be visible on every page.
+
+The Wiki supports hierarchical article organization. You can separate components in article names with slashes, and Wiki links only display the last component. An example: [[Factor/Features]].

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 ;
 
@@ -89,6 +93,9 @@ M: revision feed-entry-url id>> revision-url ;
     <article> select-tuple
     dup [ revision>> <revision> select-tuple ] when ;
 
+: init-relative-link-prefix ( -- )
+    URL" $wiki/view/" adjust-url present relative-link-prefix set ;
+
 : <view-article-action> ( -- action )
     <action>
 
@@ -96,6 +103,7 @@ M: revision feed-entry-url id>> revision-url ;
 
         [
             validate-title
+            init-relative-link-prefix
         ] >>init
 
         [
@@ -118,7 +126,7 @@ M: revision feed-entry-url id>> revision-url ;
             validate-integer-id
             "id" value <revision>
             select-tuple from-object
-            URL" $wiki/view/" adjust-url present relative-link-prefix set
+            init-relative-link-prefix
         ] >>init
 
         { wiki "view" } >>template
@@ -140,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>
@@ -370,11 +380,13 @@ M: revision feed-entry-url id>> revision-url ;
 : init-wiki ( -- )
     "resource:extra/webapps/wiki/initial-content" directory* keys
     [
-        [ ascii file-contents ] [ file-name "." split1 drop ] bi
+        dup file-name ".txt" ?tail [
+            swap ascii file-contents
             f <revision>
-            swap >>title
                 swap >>content
+                swap >>title
                 "slava" >>author
                 now >>date
             add-revision
+        ] [ 2drop ] if
     ] each ;

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