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

README.txt

@@ -6,7 +6,6 @@ implementation. It is not an introduction to the language itself.
 
 * Contents
 
-- Platform support
 - Compiling the Factor VM
 - Libraries needed for compilation
 - Bootstrapping the Factor image
@@ -19,80 +18,50 @@ implementation. It is not an introduction to the language itself.
 - Source organization
 - Community
 
-* Platform support
-
-Factor supports the following platforms:
-
-  Linux/x86
-  Linux/AMD64
-  Linux/PowerPC
-  Linux/ARM
-  Mac OS X/x86
-  Mac OS X/PowerPC
-  FreeBSD/x86
-  FreeBSD/AMD64
-  OpenBSD/x86
-  OpenBSD/AMD64
-  Solaris/x86
-  Solaris/AMD64
-  MS Windows/x86 (XP and above)
-  MS Windows CE/ARM
-
-Please donate time or hardware if you wish to see Factor running on
-other platforms. In particular, we are interested in:
-
-  Windows/AMD64
-  Mac OS X/AMD64
-  Solaris/UltraSPARC
-  Linux/MIPS
-
 * Compiling the Factor VM
 
 The Factor runtime is written in GNU C99, and is built with GNU make and
 gcc.
 
-Factor requires gcc 3.4 or later. On x86, it /will not/ build using gcc
+Factor supports various platforms. For an up-to-date list, see
-3.3 or earlier. If you are using gcc 4.3, you might get an unusable
+<http://factorcode.org/getfactor.fhtml>.
-Factor binary unless you add 'SITE_CFLAGS=-fno-forward-propagate' to the
-command-line arguments for make.
 
-Run 'make' (or 'gmake' on *BSD) with no parameters to see a list of
+Factor requires gcc 3.4 or later.
-targets and build options. Then run 'make' with the appropriate target
+
-for your platform.
+On x86, Factor /will not/ build using gcc 3.3 or earlier.
+
+If you are using gcc 4.3, you might get an unusable Factor binary unless
+you add 'SITE_CFLAGS=-fno-forward-propagate' to the command-line
+arguments for make.
+
+Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM.
 
 Compilation will yield an executable named 'factor' on Unix,
-'factor-nt.exe' on Windows XP/Vista, and 'factor-ce.exe' on Windows CE.
+'factor.exe' on Windows XP/Vista, and 'factor-ce.exe' on Windows CE.
 
 * Libraries needed for compilation
 
-For X11 support, you need recent development libraries for libc, Freetype,
+For X11 support, you need recent development libraries for libc,
-X11, OpenGL and GLUT. On a Debian-derived Linux distribution (like Ubuntu),
+Freetype, X11, OpenGL and GLUT. On a Debian-derived Linux distribution
-you can use the line
+(like Ubuntu), you can use the line
 
-sudo apt-get install libc6-dev libfreetype6-dev libx11-dev glutg3-dev
+    sudo apt-get install libc6-dev libfreetype6-dev libx11-dev glutg3-dev
 
-to grab everything (if you're on a non-debian-derived distro please tell us
+to grab everything (if you're on a non-debian-derived distro please tell
-what the equivalent command is on there and it can be added :)
+us what the equivalent command is on there and it can be added).
 
 * Bootstrapping the Factor image
 
-The boot images are no longer included with the Factor distribution
-due to size concerns. Instead, download a boot image from:
-
-  http://factorcode.org/images/
-
 Once you have compiled the Factor runtime, you must bootstrap the Factor
 system using the image that corresponds to your CPU architecture.
 
-Once you download the right image, bootstrap the system with the
+Boot images can be obtained from <http://factorcode.org/images/latest/>.
+
+Once you download the right image, bootstrap Factor with the
 following command line:
 
 ./factor -i=boot.<cpu>.image
 
-Or this command for Mac OS X systems:
-
-./Factor.app/Contents/MacOS/factor -i=boot.<cpu>.image
-
 Bootstrap can take a while, depending on your system. When the process
 completes, a 'factor.image' file will be generated. Note that this image
 is both CPU and OS-specific, so in general cannot be shared between
@@ -122,9 +91,8 @@ The latter keeps the terminal listener running.
 
 * Running Factor on Mac OS X - Cocoa UI
 
-On Mac OS X 10.4 and later, a Cocoa UI is available in addition to the
+On Mac OS X, a Cocoa UI is available in addition to the terminal
-terminal listener. If you are using Mac OS X 10.3, you can only run the
+listener.
-X11 UI, as documented in the next section.
 
 The 'factor' executable runs the terminal listener:
 
@@ -136,17 +104,16 @@ contains factor.image and the library sources.
 
 * Running Factor on Mac OS X - X11 UI
 
-The X11 UI is available on Mac OS X, however its use is not recommended
+The X11 UI is also available on Mac OS X, however its use is not
-since it does not integrate with the host OS. However, if you are
+recommended since it does not integrate with the host OS.
-running Mac OS X 10.3, it is your only choice.
 
 When compiling Factor, pass the X11=1 parameter:
 
-  make macosx-ppc X11=1
+  make X11=1
 
 Then bootstrap with the following switches:
 
-  ./factor -i=boot.ppc.image -ui-backend=x11
+  ./factor -i=boot.<cpu>.image -ui-backend=x11
 
 Now if $DISPLAY is set, running ./factor will start the UI.
 
@@ -155,40 +122,36 @@ Now if $DISPLAY is set, running ./factor will start the UI.
 If you did not download the binary package, you can bootstrap Factor in
 the command prompt:
 
-  factor-nt.exe -i=boot.x86.32.image
+  factor.exe -i=boot.<cpu>.image
 
 Once bootstrapped, double-clicking factor.exe starts the Factor UI.
 
 To run the listener in the command prompt:
 
-  factor-nt.exe -run=listener
+  factor.exe -run=listener
 
 * The Factor FAQ
 
-The Factor FAQ lives online at http://factorcode.org/faq.fhtml
+The Factor FAQ is available at <http://factorcode.org/faq.fhtml>.
 
 * Command line usage
 
-The Factor VM supports a number of command line switches. To read
+Factor supports a number of command line switches. To read command line
-command line usage documentation, either enter the following in the UI
+usage documentation, enter the following in the UI listener:
-listener:
 
   "command-line" about
 
 * Source organization
 
-The following two directories are managed by the module system; consult
+The Factor source tree is organized as follows:
-the documentation for details:
 
+  build-support/ - scripts used for compiling Factor
   core/ - Factor core library and compiler
   extra/ - more libraries
-
-The following directories contain additional files:
-
-  misc/ - editor modes, icons, etc
-  vm/ - sources for the Factor runtime, written in C
   fonts/ - TrueType fonts used by UI
+  misc/ - editor modes, icons, etc
   unmaintained/ - unmaintained contributions, please help!
+  vm/ - sources for the Factor VM, written in C
 
 * Community
 

core/alien/c-types/c-types.factor

@@ -18,12 +18,12 @@ boxer prep unboxer
 getter setter
 reg-class size align stack-align? ;
 
-: construct-c-type ( class -- type )
+: new-c-type ( class -- type )
     new
         int-regs >>reg-class ;
 
 : <c-type> ( -- type )
-    \ c-type construct-c-type ;
+    \ c-type new-c-type ;
 
 SYMBOL: c-types
 
@@ -189,7 +189,7 @@ DEFER: >c-ushort-array
 TUPLE: long-long-type < c-type ;
 
 : <long-long-type> ( -- type )
-    long-long-type construct-c-type ;
+    long-long-type new-c-type ;
 
 M: long-long-type unbox-parameter ( n type -- )
     c-type-unboxer %unbox-long-long ;

core/assocs/assocs-docs.factor

@@ -76,7 +76,7 @@ ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
 { $subsection remove-all }
 { $subsection substitute }
 { $subsection substitute-here }
-{ $see-also key? } ;
+{ $see-also key? assoc-contains? assoc-all? "sets" } ;
 
 ARTICLE: "assocs-mutation" "Storing keys and values in assocs"
 "Utility operations built up from the " { $link "assocs-protocol" } ":"
@@ -97,6 +97,7 @@ $nl
 { $subsection assoc-map }
 { $subsection assoc-push-if }
 { $subsection assoc-subset }
+{ $subsection assoc-contains? }
 { $subsection assoc-all? }
 "Three additional combinators:"
 { $subsection cache }
@@ -206,9 +207,13 @@ HELP: assoc-subset
 { $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "subassoc" "a new assoc" } }
 { $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields true." } ;
 
+HELP: assoc-contains?
+{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } }
+{ $description "Tests if the assoc contains an entry satisfying a predicate by applying the quotation to each entry in turn. Iteration stops if an entry is found for which the quotation outputs a true value." } ;
+
 HELP: assoc-all?
 { $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } }
-{ $description "Applies a predicate quotation to entry in the assoc. Outputs true if the assoc yields true for each entry (which includes the case where the assoc is empty)." } ;
+{ $description "Tests if all entries in the assoc satisfy a predicate by applying the quotation to each entry in turn. a predicate quotation to entry in the assoc. Iteration stops if an entry is found for which the quotation outputs " { $link f } ". If the assoc is empty, always outputs " { $link t } "." } ;
 
 HELP: subassoc?
 { $values { "assoc1" assoc } { "assoc2" assoc } { "?" "a new assoc" } }

core/bootstrap/primitives.factor

@@ -390,7 +390,7 @@ define-builtin
 
 ! Create special tombstone values
 "tombstone" "hashtables.private" create
-"tuple" "kernel" lookup
+tuple
 { } define-tuple-class
 
 "((empty))" "hashtables.private" create
@@ -403,7 +403,7 @@ define-builtin
 
 ! Some tuple classes
 "hashtable" "hashtables" create
-"tuple" "kernel" lookup
+tuple
 {
     {
         { "array-capacity" "sequences.private" }
@@ -424,7 +424,7 @@ define-builtin
 } define-tuple-class
 
 "sbuf" "sbufs" create
-"tuple" "kernel" lookup
+tuple
 {
     {
         { "string" "strings" }
@@ -440,7 +440,7 @@ define-builtin
 } define-tuple-class
 
 "vector" "vectors" create
-"tuple" "kernel" lookup
+tuple
 {
     {
         { "array" "arrays" }
@@ -456,7 +456,7 @@ define-builtin
 } define-tuple-class
 
 "byte-vector" "byte-vectors" create
-"tuple" "kernel" lookup
+tuple
 {
     {
         { "byte-array" "byte-arrays" }
@@ -472,7 +472,7 @@ define-builtin
 } define-tuple-class
 
 "bit-vector" "bit-vectors" create
-"tuple" "kernel" lookup
+tuple
 {
     {
         { "bit-array" "bit-arrays" }
@@ -488,7 +488,7 @@ define-builtin
 } define-tuple-class
 
 "float-vector" "float-vectors" create
-"tuple" "kernel" lookup
+tuple
 {
     {
         { "float-array" "float-arrays" }
@@ -504,7 +504,7 @@ define-builtin
 } define-tuple-class
 
 "curry" "kernel" create
-"tuple" "kernel" lookup
+tuple
 {
     {
         { "object" "kernel" }
@@ -525,7 +525,7 @@ define-builtin
 [ tuple-layout [ <tuple-boa> ] curry ] tri define
 
 "compose" "kernel" create
-"tuple" "kernel" lookup
+tuple
 {
     {
         { "object" "kernel" }

core/classes/tuple/tuple-docs.factor

@@ -32,23 +32,23 @@ $nl
     ""
     ": add-occupant ( person vehicle -- ) occupants>> push ;"
     ""
-    ": construct-vehicle ( class -- vehicle )"
+    ": new-vehicle ( class -- vehicle )"
     "    new"
     "        V{ } clone >>occupants ;"
     ""
     "TUPLE: car < vehicle engine ;"
     ": <car> ( max-speed engine -- car )"
-    "    car construct-vehicle"
+    "    car new-vehicle"
     "        swap >>engine"
     "        swap >>max-speed ;"
     ""
     "TUPLE: aeroplane < vehicle max-altitude ;"
     ": <aeroplane> ( max-speed max-altitude -- aeroplane )"
-    "    aeroplane construct-vehicle"
+    "    aeroplane new-vehicle"
     "        swap >>max-altitude"
     "        swap >>max-speed ;"
 }
-"The naming convention for parametrized constructors is " { $snippet "construct-" { $emphasis "class" } } "." ;
+"The naming convention for parametrized constructors is " { $snippet "new-" { $emphasis "class" } } "." ;
 
 ARTICLE: "tuple-constructors" "Tuple constructors"
 "Tuples are created by calling one of two constructor primitives:"
@@ -64,13 +64,16 @@ $nl
 { $code
     "TUPLE: color red green blue alpha ;"
     ""
+    "! The following two are equivalent"
     "C: <rgba> rgba"
-    ": <rgba> color boa ; ! identical to above"
+    ": <rgba> color boa ;"
     ""
+    "! We can define constructors which call other constructors"
     ": <rgb> f <rgba> ;"
     ""
-    ": <color> new ;"
+    "! The following two are equivalent"
-    ": <color> f f f f <rgba> ; ! identical to above"
+    ": <color> color new ;"
+    ": <color> f f f f <rgba> ;"
 }
 { $subsection "parametrized-constructors" } ;
 

core/classes/tuple/tuple-tests.factor

@@ -538,3 +538,6 @@ TUPLE: another-forget-accessors-test ;
         ] with-string-writer empty?
     ] with-variable
 ] unit-test
+
+! Missing error check
+[ "IN: tuples.test USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail

core/classes/tuple/tuple.factor

@@ -58,6 +58,8 @@ PRIVATE>
 : all-slot-names ( class -- slots )
     superclasses [ slot-names ] map concat \ class prefix ;
 
+ERROR: bad-superclass class ;
+
 <PRIVATE
 
 : tuple= ( tuple1 tuple2 -- ? )
@@ -185,16 +187,23 @@ M: tuple-class update-class
 : tuple-class-unchanged? ( class superclass slots -- ? )
     rot tuck [ superclass = ] [ slot-names = ] 2bi* and ;
 
+: valid-superclass? ( class -- ? )
+    [ tuple-class? ] [ tuple eq? ] bi or ;
+
+: check-superclass ( superclass -- )
+    dup valid-superclass? [ bad-superclass ] unless drop ;
+
 PRIVATE>
 
 GENERIC# define-tuple-class 2 ( class superclass slots -- )
 
 M: word define-tuple-class
+    over check-superclass
     define-new-tuple-class ;
 
 M: tuple-class define-tuple-class
     3dup tuple-class-unchanged?
-    [ 3dup redefine-tuple-class ] unless
+    [ over check-superclass 3dup redefine-tuple-class ] unless
     3drop ;
 
 : define-error-class ( class superclass slots -- )

core/debugger/debugger.factor

@@ -215,7 +215,10 @@ M: check-method summary
     drop "Invalid parameters for create-method" ;
 
 M: no-tuple-class summary
-    drop "Invalid class for define-constructor" ;
+    drop "BOA constructors can only be defined for tuple classes" ;
+
+M: bad-superclass summary
+    drop "Tuple classes can only inherit from other tuple classes" ;
 
 M: no-cond summary
     drop "Fall-through in cond" ;

core/dlists/dlists-tests.factor

@@ -1,5 +1,5 @@
 USING: dlists dlists.private kernel tools.test random assocs
-hashtables sequences namespaces sorting debugger io prettyprint
+sets sequences namespaces sorting debugger io prettyprint
 math ;
 IN: dlists.tests
 

core/generator/registers/registers.factor

@@ -237,7 +237,7 @@ M: phantom-stack clone
 
 GENERIC: finalize-height ( stack -- )
 
-: construct-phantom-stack ( class -- stack )
+: new-phantom-stack ( class -- stack )
     >r 0 V{ } clone r> boa ; inline
 
 : (loc)
@@ -257,7 +257,7 @@ GENERIC: <loc> ( n stack -- loc )
 TUPLE: phantom-datastack < phantom-stack ;
 
 : <phantom-datastack> ( -- stack )
-    phantom-datastack construct-phantom-stack ;
+    phantom-datastack new-phantom-stack ;
 
 M: phantom-datastack <loc> (loc) <ds-loc> ;
 
@@ -267,7 +267,7 @@ M: phantom-datastack finalize-height
 TUPLE: phantom-retainstack < phantom-stack ;
 
 : <phantom-retainstack> ( -- stack )
-    phantom-retainstack construct-phantom-stack ;
+    phantom-retainstack new-phantom-stack ;
 
 M: phantom-retainstack <loc> (loc) <rs-loc> ;
 

core/parser/parser.factor

@@ -17,9 +17,14 @@ TUPLE: lexer text line line-text line-length column ;
     0 >>column
     drop ;
 
+: new-lexer ( text class -- lexer )
+    new
+        0 >>line
+        swap >>text
+    dup next-line ; inline
+
 : <lexer> ( text -- lexer )
-    0 { set-lexer-text set-lexer-line } lexer construct
+    lexer new-lexer ;
-    dup next-line ;
 
 : location ( -- loc )
     file get lexer get lexer-line 2dup and

core/prettyprint/prettyprint-docs.factor

@@ -60,8 +60,8 @@ $nl
 { $subsection short-section }
 { $subsection long-section }
 "Utilities to use when implementing sections:"
-{ $subsection construct-section }
+{ $subsection new-section }
-{ $subsection construct-block }
+{ $subsection new-block }
 { $subsection add-section } ;
 
 ARTICLE: "prettyprint-sections" "Prettyprinter sections"

core/prettyprint/sections/sections-docs.factor

@@ -78,7 +78,7 @@ HELP: section
     { { $snippet "overhang" } " - number of columns which must be left blank before the wrap margin for the prettyprinter to consider emitting this section as a " { $link short-section } ". Avoids lone hanging closing brackets" }
 } } ;
 
-HELP: construct-section
+HELP: new-section
 { $values { "length" integer } { "class" "a subclass of " { $link section } } { "section" section } }
 { $description "Creates a new section with the given length starting from " { $link position } ", advancing " { $link position } "." } ;
 

core/prettyprint/sections/sections.factor

@@ -71,7 +71,7 @@ start end
 start-group? end-group?
 style overhang ;
 
-: construct-section ( length class -- section )
+: new-section ( length class -- section )
     new
         position get >>start
         swap position [ + ] change
@@ -127,7 +127,7 @@ M: object short-section? section-fits? ;
 TUPLE: line-break < section type ;
 
 : <line-break> ( type -- section )
-    0 \ line-break construct-section
+    0 \ line-break new-section
         swap >>type ;
 
 M: line-break short-section drop ;
@@ -137,13 +137,13 @@ M: line-break long-section drop ;
 ! Block sections
 TUPLE: block < section sections ;
 
-: construct-block ( style class -- block )
+: new-block ( style class -- block )
-    0 swap construct-section
+    0 swap new-section
         V{ } clone >>sections
         swap >>style ; inline
 
 : <block> ( style -- block )
-    block construct-block ;
+    block new-block ;
 
 : pprinter-block ( -- block ) pprinter-stack get peek ;
 
@@ -200,7 +200,7 @@ M: block short-section ( block -- )
 TUPLE: text < section string ;
 
 : <text> ( string style -- text )
-    over length 1+ \ text construct-section
+    over length 1+ \ text new-section
         swap >>style
         swap >>string ;
 
@@ -216,7 +216,7 @@ M: text long-section short-section ;
 TUPLE: inset < block narrow? ;
 
 : <inset> ( narrow? -- block )
-    H{ } inset construct-block
+    H{ } inset new-block
         2 >>overhang
         swap >>narrow? ;
 
@@ -237,7 +237,7 @@ M: inset newline-after? drop t ;
 TUPLE: flow < block ;
 
 : <flow> ( -- block )
-    H{ } flow construct-block ;
+    H{ } flow new-block ;
 
 M: flow short-section? ( section -- ? )
     #! If we can make room for this entire block by inserting
@@ -253,7 +253,7 @@ M: flow short-section? ( section -- ? )
 TUPLE: colon < block ;
 
 : <colon> ( -- block )
-    H{ } colon construct-block ;
+    H{ } colon new-block ;
 
 M: colon long-section short-section ;
 

core/sequences/sequences-docs.factor

@@ -528,12 +528,7 @@ HELP: contains?
 
 HELP: all?
 { $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "?" "a boolean" } }
-{ $description "Tests if all elements in the sequence satisfy the predicate by checking each element in turn. Given an empty sequence, vacuously outputs " { $link t } "." }
+{ $description "Tests if all elements in the sequence satisfy the predicate by checking each element in turn. Given an empty sequence, vacuously outputs " { $link t } "." } ;
-{ $notes
-    "The implementation makes use of a well-known logical identity:" 
-    $nl
-    { $snippet "P[x] for all x <==> not ((not P[x]) for some x)" }
-} ;
 
 HELP: push-if
 { $values { "elt" object } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "accum" "a resizable mutable sequence" } }

core/sets/authors.txt

@@ -0,0 +1,2 @@
+Slava Pestov
+Doug Coleman

core/sets/sets-docs.factor

@@ -1,7 +1,9 @@
 USING: kernel help.markup help.syntax sequences ;
 IN: sets
 
-ARTICLE: "sets" "Set theoretic operations"
+ARTICLE: "sets" "Set-theoretic operations on sequences"
+"Set-theoretic operations on sequences are defined on the " { $vocab-link "sets" } " vocabulary. These operations use hashtables internally to achieve linear running time."
+$nl
 "Remove duplicates:"
 { $subsection prune }
 "Test for duplicates:"
@@ -9,7 +11,8 @@ ARTICLE: "sets" "Set theoretic operations"
 "Set operations on sequences:"
 { $subsection diff }
 { $subsection intersect }
-{ $subsection union } ;
+{ $subsection union }
+{ $see-also member? memq? contains? all? "assocs-sets" } ;
 
 HELP: unique
 { $values { "seq" "a sequence" } { "assoc" "an assoc" } }
@@ -22,14 +25,14 @@ HELP: prune
 { $values { "seq" "a sequence" } { "newseq" "a sequence" } }
 { $description "Outputs a new sequence with each distinct element of " { $snippet "seq" } " appearing only once. Elements are compared for equality using " { $link = } " and elements are ordered according to their position in " { $snippet "seq" } "." }
 { $examples
-    { $example "USING: sequences prettyprint ;" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" }
+    { $example "USING: sets prettyprint ;" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" }
 } ;
 
 HELP: all-unique?
 { $values { "seq" sequence } { "?" "a boolean" } }
 { $description "Tests whether a sequence contains any repeated elements." }
 { $example
-    "USING: hashtables prettyprint ;"
+    "USING: sets prettyprint ;"
     "{ 0 1 1 2 3 5 } all-unique? ."
     "f"
 } ;
@@ -38,21 +41,21 @@ HELP: diff
 { $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
 { $description "Outputs a sequence consisting of elements present in " { $snippet "seq2" } " but not " { $snippet "seq1" } ", comparing elements for equality." 
 } { $examples
-    { $example "USING: sequences prettyprint ;" "{ 1 2 3 } { 2 3 4 } diff ." "{ 4 }" }
+    { $example "USING: sets prettyprint ;" "{ 1 2 3 } { 2 3 4 } diff ." "{ 4 }" }
 } ;
 
 HELP: intersect
 { $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
 { $description "Outputs a sequence consisting of elements present in both " { $snippet "seq1" } " and " { $snippet "seq2" } "." }
 { $examples
-    { $example "USING: sequences prettyprint ;" "{ 1 2 3 } { 2 3 4 } intersect ." "{ 2 3 }" }
+    { $example "USING: sets prettyprint ;" "{ 1 2 3 } { 2 3 4 } intersect ." "{ 2 3 }" }
 } ;
 
 HELP: union
 { $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
 { $description "Outputs a sequence consisting of elements present in " { $snippet "seq1" } " and " { $snippet "seq2" } " which does not contain duplicate values." }
 { $examples
-    { $example "USING: sequences prettyprint ;" "{ 1 2 3 } { 2 3 4 } union ." "{ 1 2 3 4 }" }
+    { $example "USING: sets prettyprint ;" "{ 1 2 3 } { 2 3 4 } union ." "V{ 1 2 3 4 }" }
 } ;
 
 { diff intersect union } related-words

core/sets/summary.txt

@@ -0,0 +1 @@
+Set-theoretic operations on sequences

core/sets/tags.txt

@@ -0,0 +1 @@
+collections

core/strings/strings-tests.factor

@@ -96,7 +96,7 @@ unit-test
 [ ] [
     [
         4 [
-            100 [ drop "obdurak" ] map
+            100 [ drop "obdurak" clone ] map
             gc
             dup [
                 1234 0 rot set-string-nth

core/threads/threads.factor

@@ -56,13 +56,16 @@ mailbox variables sleep-entry ;
 
 PRIVATE>
 
-: <thread> ( quot name -- thread )
+: new-thread ( quot name class -- thread )
-    \ thread new
+    new
         swap >>name
         swap >>quot
         \ thread counter >>id
         <box> >>continuation
-        [ ] >>exit-handler ;
+        [ ] >>exit-handler ; inline
+
+: <thread> ( quot name -- thread )
+    \ thread new-thread ;
 
 : run-queue 42 getenv ;
 

extra/arrays/lib/summary.txt

@@ -0,0 +1 @@
+Non-core array words

extra/builder/cleanup/cleanup.factor

@@ -8,6 +8,8 @@ IN: builder.cleanup
 
 SYMBOL: builder-debug
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 : compress-image ( -- ) { "bzip2" my-boot-image-name } to-strings try-process ;
 
 : delete-child-factor ( -- )

extra/builder/common/common.factor

@@ -7,6 +7,10 @@ IN: builder.common
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+SYMBOL: upload-to-factorcode
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 SYMBOL: builds-dir
 
 : builds ( -- path )
@@ -21,15 +25,6 @@ VAR: stamp
 : builds/factor ( -- path ) builds "factor" append-path ;
 : build-dir     ( -- path ) builds stamp>   append-path ;
 
-: create-build-dir ( -- )
-  datestamp >stamp
-  build-dir make-directory ;
-  
-: enter-build-dir  ( -- ) build-dir set-current-directory ;
-
-: clone-builds-factor ( -- )
-  { "git" "clone" builds/factor } to-strings try-process ;
-
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : prepare-build-machine ( -- )
@@ -57,8 +52,3 @@ SYMBOL: status
   { status-vm status-boot status-test status-build status-release status }
     [ off ]
   each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: upload-to-factorcode
-

extra/builder/email/email.factor

@@ -8,6 +8,8 @@ IN: builder.email
 SYMBOL: builder-from
 SYMBOL: builder-recipients
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 : subject-status ( -- str ) status get [ "report" ] [ "error" ] if ;
 
 : subject ( -- str ) { "builder@" host-name* ": " subject-status } to-string ;

extra/concurrency/combinators/combinators-tests.factor

@@ -1,6 +1,6 @@
 IN: concurrency.combinators.tests
 USING: concurrency.combinators tools.test random kernel math 
-concurrency.mailboxes threads sequences ;
+concurrency.mailboxes threads sequences accessors ;
 
 [ [ drop ] parallel-each ] must-infer
 [ [ ] parallel-map ] must-infer
@@ -11,7 +11,7 @@ concurrency.mailboxes threads sequences ;
 [ { 1 4 9 } ] [ { 1 2 3 } [ 1000 random sleep sq ] parallel-map ] unit-test
 
 [ { 1 2 3 } [ dup 2 mod 0 = [ "Even" throw ] when ] parallel-map ]
-[ delegate "Even" = ] must-fail-with
+[ error>> "Even" = ] must-fail-with
 
 [ V{ 0 3 6 9 } ]
 [ 10 [ 3 mod zero? ] parallel-subset ] unit-test

extra/concurrency/mailboxes/mailboxes.factor

@@ -81,23 +81,19 @@ M: mailbox dispose
 : wait-for-close ( mailbox -- )
     f wait-for-close-timeout ;
 
-TUPLE: linked-error thread ;
+TUPLE: linked-error error thread ;
 
-: <linked-error> ( error thread -- linked )
+C: <linked-error> linked-error
-    { set-delegate set-linked-error-thread }
-    linked-error construct ;
 
 : ?linked dup linked-error? [ rethrow ] when ;
 
-TUPLE: linked-thread supervisor ;
+TUPLE: linked-thread < thread supervisor ;
 
 M: linked-thread error-in-thread
-    [ <linked-error> ] keep
+    [ <linked-error> ] [ supervisor>> ] bi mailbox-put ;
-    linked-thread-supervisor mailbox-put ;
 
 : <linked-thread> ( quot name mailbox -- thread' )
-    >r <thread> linked-thread construct-delegate r>
+    >r linked-thread new-thread r> >>supervisor ;
-    over set-linked-thread-supervisor ;
 
 : spawn-linked-to ( quot name mailbox -- thread )
     <linked-thread> [ (spawn) ] keep ;

extra/concurrency/messaging/messaging-tests.factor

@@ -4,7 +4,7 @@
 USING: kernel threads vectors arrays sequences
 namespaces tools.test continuations dlists strings math words
 match quotations concurrency.messaging concurrency.mailboxes
-concurrency.count-downs ;
+concurrency.count-downs accessors ;
 IN: concurrency.messaging.tests
 
 [ ] [ my-mailbox mailbox-data dlist-delete-all ] unit-test
@@ -30,7 +30,7 @@ IN: concurrency.messaging.tests
         "crash" throw
     ] "Linked test" spawn-linked drop
     receive
-] [ delegate "crash" = ] must-fail-with
+] [ error>> "crash" = ] must-fail-with
 
 MATCH-VARS: ?from ?to ?value ;
 SYMBOL: increment

extra/db/mysql/mysql.factor

@@ -9,7 +9,7 @@ TUPLE: mysql-statement ;
 TUPLE: mysql-result-set ;
 
 M: mysql-db db-open ( mysql-db -- )
-    drop ;
+    ;
 
 M: mysql-db dispose ( mysql-db -- )
     mysql-db-handle mysql_close ;

extra/editors/vim/generate-syntax/generate-syntax.factor

@@ -1,9 +1,10 @@
 ! Generate a new factor.vim file for syntax highlighting
-USING: http.server.templating.fhtml io.files ;
+USING: http.server.templating http.server.templating.fhtml
+io.files ;
 IN: editors.vim.generate-syntax
 
 : generate-vim-syntax ( -- )
-    "misc/factor.vim.fgen" resource-path
+    "misc/factor.vim.fgen" resource-path <fhtml>
     "misc/factor.vim" resource-path
     template-convert ;
 

extra/farkup/farkup-tests.factor

@@ -54,7 +54,7 @@ IN: farkup.tests
 [ "<p>=</p><h2>foo</h2>" ] [ "===foo==" convert-farkup ] unit-test
 [ "<h1>foo</h1><p>=</p>" ] [ "=foo==" convert-farkup ] unit-test
 
-[ "<span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span><br/>" ]
+[ "<div style='white-space: pre; font-family: monospace; '><span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span><br/></div>" ]
 [ "[c{int main()}]" convert-farkup ] unit-test
 
 [ "<p><img src=\"lol.jpg\"/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test

extra/farkup/farkup.factor

@@ -1,11 +1,13 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays io kernel memoize namespaces peg sequences strings
+USING: arrays io io.styles kernel memoize namespaces peg
-html.elements xml.entities xmode.code2html splitting
+sequences strings html.elements xml.entities xmode.code2html
-io.streams.string html peg.parsers html.elements sequences.deep
+splitting io.streams.string html peg.parsers html.elements
-unicode.categories ;
+sequences.deep unicode.categories ;
 IN: farkup
 
+<PRIVATE
+
 : delimiters ( -- string )
     "*_^~%[-=|\\\n" ; inline
 
@@ -53,7 +55,13 @@ MEMO: eq ( -- parser )
 
 : render-code ( string mode -- string' )
     >r string-lines r>
-    [ [ htmlize-lines ] with-html-stream ] with-string-writer ;
+    [
+        [
+            H{ { wrap-margin f } } [
+                htmlize-lines
+            ] with-nesting
+        ] with-html-stream
+    ] with-string-writer ;
 
 : escape-link ( href text -- href-esc text-esc )
     >r escape-quoted-string r> escape-string ;
@@ -144,6 +152,8 @@ MEMO: paragraph ( -- parser )
         [ "<p>" swap "</p>" 3array ] unless
     ] action ;
 
+PRIVATE>
+
 PEG: parse-farkup ( -- parser )
     [
         list , table , h1 , h2 , h3 , h4 , code , paragraph , 2nl , nl ,

extra/help/handbook/handbook.factor

@@ -3,7 +3,7 @@ namespaces words sequences classes assocs vocabs kernel arrays
 prettyprint.backend kernel.private io generic math system
 strings sbufs vectors byte-arrays bit-arrays float-arrays
 quotations io.streams.byte-array io.encodings.string
-classes.builtin ;
+classes.builtin parser ;
 IN: help.handbook
 
 ARTICLE: "conventions" "Conventions"
@@ -25,6 +25,7 @@ $nl
     { { $snippet { $emphasis "foo" } "?" } "outputs a boolean" { { $link empty? } } }
     { { $snippet "?" { $emphasis "foo" } } { "conditionally performs " { $snippet { $emphasis "foo" } } } { { $links ?nth } } }
     { { $snippet "<" { $emphasis "foo" } ">" } { "creates a new " { $snippet "foo" } } { { $link <array> } } }
+    { { $snippet "new-" { $emphasis "foo" } } { "creates a new " { $snippet "foo" } ", taking some kind of parameter from the stack which determines the type of the object to be created" } { { $link new-sequence } ", " { $link new-lexer } ", " { $link new } } }
     { { $snippet { $emphasis "foo" } "*" } { "alternative form of " { $snippet "foo" } ", or a generic word called by " { $snippet "foo" } } { { $links at* pprint* } } }
     { { $snippet "(" { $emphasis "foo" } ")" } { "implementation detail word used by " { $snippet "foo" } } { { $link (clone) } } }
     { { $snippet "set-" { $emphasis "foo" } } { "sets " { $snippet "foo" } " to a new value" } { $links set-length } }

extra/html/html-tests.factor

@@ -3,7 +3,9 @@ namespaces tools.test xml.writer sbufs sequences html.private ;
 IN: html.tests
 
 : make-html-string
-    [ with-html-stream ] with-string-writer ;
+    [ with-html-stream ] with-string-writer ; inline
+
+[ [ ] make-html-string ] must-infer
 
 [ ] [
     512 <sbuf> <html-stream> drop

extra/html/html.factor

@@ -194,7 +194,7 @@ M: html-stream stream-nl ( stream -- )
 
 ! Utilities
 : with-html-stream ( quot -- )
-    stdio get <html-stream> swap with-stream* ;
+    stdio get <html-stream> swap with-stream* ; inline
 
 : xhtml-preamble
     "<?xml version=\"1.0\"?>" write-html

extra/http/http-tests.factor

@@ -1,5 +1,6 @@
 USING: http tools.test multiline tuple-syntax
-io.streams.string kernel arrays splitting sequences     ;
+io.streams.string kernel arrays splitting sequences
+assocs io.sockets ;
 IN: http.tests
 
 [ "hello%20world" ] [ "hello world" url-encode ] unit-test
@@ -139,7 +140,9 @@ io.encodings.ascii ;
             <action>
                 [ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>display
             "quit" add-responder
+            <dispatcher>
                 "extra/http/test" resource-path <static> >>default
+            "nested" add-responder
         main-responder set
 
         [ 1237 httpd ] "HTTPD test" spawn drop
@@ -148,7 +151,17 @@ io.encodings.ascii ;
 
 [ t ] [
     "extra/http/test/foo.html" resource-path ascii file-contents
-    "http://localhost:1237/foo.html" http-get =
+    "http://localhost:1237/nested/foo.html" http-get =
+] unit-test
+
+! Try with a slightly malformed request
+[ t ] [
+    "localhost" 1237 <inet> ascii <client> [
+        "GET nested HTTP/1.0\r\n" write flush
+        "\r\n" write flush
+        readln drop
+        read-header USE: prettyprint
+    ] with-stream dup . "location" swap at "/" head?
 ] unit-test
 
 [ "Goodbye" ] [

extra/http/http.factor

@@ -394,14 +394,17 @@ body ;
     [ unparse-cookies "set-cookie" pick set-at ] when*
     write-header ;
 
-: write-response-body ( response -- response )
+: body>quot ( body -- quot )
-    dup body>> {
+    {
-        { [ dup not ] [ drop ] }
+        { [ dup not ] [ drop [ ] ] }
-        { [ dup string? ] [ write ] }
+        { [ dup string? ] [ [ write ] curry ] }
-        { [ dup callable? ] [ call ] }
+        { [ dup callable? ] [ ] }
-        [ stdio get stream-copy ]
+        [ [ stdio get stream-copy ] curry ]
     } cond ;
 
+: write-response-body ( response -- response )
+    dup body>> body>quot call ;
+
 M: response write-response ( respose -- )
     write-response-version
     write-response-code

extra/http/server/auth/login/boilerplate.xml

@@ -0,0 +1,9 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<h1><t:write-title /></h1>
+
+	<t:call-next-template />
+
+</t:chloe>

extra/http/server/auth/login/edit-profile.fhtml

@@ -1,77 +0,0 @@
-<% USING: http.server.components http.server.auth.login
-http.server namespaces kernel combinators ; %>
-<html>
-<body>
-<h1>Edit profile</h1>
-
-<form method="POST" action="edit-profile">
-<% hidden-form-field %>
-
-<table>
-
-<tr>
-<td>User name:</td>
-<td><% "username" component render-view %></td>
-</tr>
-
-<tr>
-<td>Real name:</td>
-<td><% "realname" component render-edit %></td>
-</tr>
-
-<tr>
-<td></td>
-<td>Specifying a real name is optional.</td>
-</tr>
-
-<tr>
-<td>Current password:</td>
-<td><% "password" component render-edit %></td>
-</tr>
-
-<tr>
-<td></td>
-<td>If you don't want to change your current password, leave this field blank.</td>
-</tr>
-
-<tr>
-<td>New password:</td>
-<td><% "new-password" component render-edit %></td>
-</tr>
-
-<tr>
-<td>Verify:</td>
-<td><% "verify-password" component render-edit %></td>
-</tr>
-
-<tr>
-<td></td>
-<td>If you are changing your password, enter it twice to ensure it is correct.</td>
-</tr>
-
-<tr>
-<td>E-mail:</td>
-<td><% "email" component render-edit %></td>
-</tr>
-
-<tr>
-<td></td>
-<td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
-</tr>
-
-</table>
-
-<p><input type="submit" value="Update" />
-
-<% {
-    { [ login-failed? get ] [ "invalid password" render-error ] }
-    { [ password-mismatch? get ] [ "passwords do not match" render-error ] }
-    { [ t ] [ ] }
-} cond %>
-
-</p>
-
-</form>
-
-</body>
-</html>

extra/http/server/auth/login/edit-profile.xml

@@ -0,0 +1,77 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:title>Edit Profile</t:title>
+
+	<t:form action="edit-profile">
+
+	<table>
+	
+	<tr>
+		<th class="field-label">User name:</th>
+		<td><t:view component="username" /></td>
+	</tr>
+	
+	<tr>
+		<th class="field-label">Real name:</th>
+		<td><t:edit component="realname" /></td>
+	</tr>
+	
+	<tr>
+		<td></td>
+		<td>Specifying a real name is optional.</td>
+	</tr>
+	
+	<tr>
+		<th class="field-label">Current password:</th>
+		<td><t:edit component="password" /></td>
+	</tr>
+	
+	<tr>
+		<td></td>
+		<td>If you don't want to change your current password, leave this field blank.</td>
+	</tr>
+	
+	<tr>
+		<th class="field-label">New password:</th>
+		<td><t:edit component="new-password" /></td>
+	</tr>
+	
+	<tr>
+		<th class="field-label">Verify:</th>
+		<td><t:edit component="verify-password" /></td>
+	</tr>
+	
+	<tr>
+		<td></td>
+		<td>If you are changing your password, enter it twice to ensure it is correct.</td>
+	</tr>
+	
+	<tr>
+		<th class="field-label">E-mail:</th>
+		<td><t:edit component="email" /></td>
+	</tr>
+	
+	<tr>
+		<td></td>
+		<td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
+	</tr>
+	
+	</table>
+
+	<p>
+		<input type="submit" value="Update" />
+
+		<t:if var="http.server.auth.login:login-failed?">
+			<t:error>invalid password</t:error>
+		</t:if>
+		
+		<t:if var="http.server.auth.login:password-mismatch?">
+			<t:error>passwords do not match</t:error>
+		</t:if>
+	</p>
+
+	</t:form>
+	
+</t:chloe>

extra/http/server/auth/login/login.factor

@@ -1,20 +1,31 @@
 ! Copyright (c) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors quotations assocs kernel splitting
-base64 html.elements io combinators http.server
+base64 io combinators sequences io.files namespaces hashtables
-http.server.auth.providers http.server.auth.providers.null
-http.server.actions http.server.components http.server.sessions
-http.server.templating.fhtml http.server.validators
-http.server.auth http sequences io.files namespaces hashtables
 fry io.sockets arrays threads locals qualified continuations
-destructors ;
+destructors
+
+html.elements
+http
+http.server
+http.server.auth
+http.server.auth.providers
+http.server.auth.providers.null
+http.server.actions
+http.server.components
+http.server.forms
+http.server.sessions
+http.server.boilerplate
+http.server.templating
+http.server.templating.chloe
+http.server.validators ;
 IN: http.server.auth.login
 QUALIFIED: smtp
 
 SYMBOL: post-login-url
 SYMBOL: login-failed?
 
-TUPLE: login users ;
+TUPLE: login < dispatcher users ;
 
 : users login get users>> ;
 
@@ -31,11 +42,15 @@ M: user-saver dispose
 : save-user-after ( user -- )
     <user-saver> add-always-destructor ;
 
+: login-template ( name -- template )
+    "resource:extra/http/server/auth/login/" swap ".xml"
+    3append <chloe> ;
+
 ! ! ! Login
 
 : <login-form>
     "login" <form>
-        "resource:extra/http/server/auth/login/login.fhtml" >>edit-template
+        "login" login-template >>edit-template
         "username" <username>
             t >>required
             add-field
@@ -77,7 +92,7 @@ M: user-saver dispose
 
 : <register-form> ( -- form )
     "register" <form>
-        "resource:extra/http/server/auth/login/register.fhtml" >>edit-template
+        "register" login-template >>edit-template
         "username" <username>
             t >>required
             add-field
@@ -130,7 +145,7 @@ SYMBOL: user-exists?
 
                 successful-login
 
-                login get responder>> init-user-profile
+                login get default>> responder>> init-user-profile
             ] >>submit
     ] ;
 
@@ -138,7 +153,7 @@ SYMBOL: user-exists?
 
 : <edit-profile-form> ( -- form )
     "edit-profile" <form>
-        "resource:extra/http/server/auth/login/edit-profile.fhtml" >>edit-template
+        "edit-profile" login-template >>edit-template
         "username" <username> add-field
         "realname" <string> add-field
         "password" <password> add-field
@@ -178,7 +193,7 @@ SYMBOL: previous-page
                     "password" value uid users check-login
                     [ login-failed? on validation-failed ] unless
 
-                    "new-password" value set-password
+                    "new-password" value >>password
                 ] unless
 
                 "realname" value >>realname
@@ -233,7 +248,7 @@ SYMBOL: lost-password-from
 
 : <recover-form-1> ( -- form )
     "register" <form>
-        "resource:extra/http/server/auth/login/recover-1.fhtml" >>edit-template
+        "recover-1" login-template >>edit-template
         "username" <username>
             t >>required
             add-field
@@ -262,14 +277,15 @@ SYMBOL: lost-password-from
                     send-password-email
                 ] when*
 
-                "resource:extra/http/server/auth/login/recover-2.fhtml" serve-template
+                "recover-2" login-template serve-template
             ] >>submit
     ] ;
 
 : <recover-form-3>
     "new-password" <form>
-        "resource:extra/http/server/auth/login/recover-3.fhtml" >>edit-template
+        "recover-3" login-template >>edit-template
-        "username" <username> <hidden>
+        "username" <username>
+            hidden >>renderer
             t >>required
             add-field
         "new-password" <password>
@@ -278,7 +294,8 @@ SYMBOL: lost-password-from
         "verify-password" <password>
             t >>required
             add-field
-        "ticket" <string> <hidden>
+        "ticket" <string>
+            hidden >>renderer
             t >>required
             add-field ;
 
@@ -315,8 +332,7 @@ SYMBOL: lost-password-from
                     "new-password" value >>password
                     users update-user
 
-                    "resource:extra/http/server/auth/login/recover-4.fhtml"
+                    "recover-4" login-template serve-template
-                    serve-template
                 ] [
                     <400>
                 ] if*
@@ -342,38 +358,46 @@ C: <protected> protected
     "login" f <permanent-redirect> ;
 
 M: protected call-responder ( path responder -- response )
-    logged-in-user sget [
+    logged-in-user sget dup [
-        dup save-user-after
+        save-user-after
         request get request-url previous-page sset
         responder>> call-responder
     ] [
-        2drop
+        3drop
         request get method>> { "GET" "HEAD" } member?
         [ show-login-page ] [ <400> ] if
     ] if ;
 
 M: login call-responder ( path responder -- response )
     dup login set
-    delegate call-responder ;
+    call-next-method ;
+
+: <login-boilerplate> ( responder -- responder' )
+    <boilerplate>
+        "boilerplate" login-template >>template ;
 
 : <login> ( responder -- auth )
-    login <webapp>
+    login new-dispatcher
         swap <protected> >>default
-        <login-action> "login" add-responder
+        <login-action> <login-boilerplate> "login" add-responder
-        <logout-action> "logout" add-responder
+        <logout-action> <login-boilerplate> "logout" add-responder
         no-users >>users ;
 
 ! ! ! Configuration
 
 : allow-edit-profile ( login -- login )
-    <edit-profile-action> <protected> "edit-profile" add-responder ;
+    <edit-profile-action> <protected> <login-boilerplate>
+        "edit-profile" add-responder ;
 
 : allow-registration ( login -- login )
-    <register-action> "register" add-responder ;
+    <register-action> <login-boilerplate>
+        "register" add-responder ;
 
 : allow-password-recovery ( login -- login )
-    <recover-action-1> "recover-password" add-responder
+    <recover-action-1> <login-boilerplate>
-    <recover-action-3> "new-password" add-responder ;
+        "recover-password" add-responder
+    <recover-action-3> <login-boilerplate>
+        "new-password" add-responder ;
 
 : allow-edit-profile? ( -- ? )
     login get responders>> "edit-profile" swap key? ;

extra/http/server/auth/login/login.fhtml

@@ -1,46 +0,0 @@
-<% USING: http.server.auth.login http.server.components http.server
-kernel namespaces ; %>
-<html>
-<body>
-<h1>Login required</h1>
-
-<form method="POST" action="login">
-
-<% hidden-form-field %>
-
-<table>
-
-<tr>
-<td>User name:</td>
-<td><% "username" component render-edit %></td>
-</tr>
-
-<tr>
-<td>Password:</td>
-<td><% "password" component render-edit %></td>
-</tr>
-
-</table>
-
-<p><input type="submit" value="Log in" />
-<%
-login-failed? get
-[ "Invalid username or password" render-error ] when
-%>
-</p>
-
-</form>
-
-<p>
-<% allow-registration? [ %>
-    <a href="<% "register" f write-link %>">Register</a>
-<% ] when %>
-<% allow-password-recovery? [ %>
-    <a href="<% "recover-password" f write-link %>">
-    	Recover Password
-    </a>
-<% ] when %>
-</p>
-
-</body>
-</html>

extra/http/server/auth/login/login.xml

@@ -0,0 +1,44 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:title>Login</t:title>
+
+	<t:form action="login">
+
+		<table>
+
+			<tr>
+				<th class="field-label">User name:</th>
+				<td><t:edit component="username" /></td>
+			</tr>
+
+			<tr>
+				<th class="field-label">Password:</th>
+				<td><t:edit component="password" /></td>
+			</tr>
+
+		</table>
+
+		<p>
+
+			<input type="submit" value="Log in" />
+
+			<t:if var="http.server.auth.login:login-failed?">
+				<t:error>invalid username or password</t:error>
+			</t:if>
+		</p>
+
+	</t:form>
+
+	<p>
+		<t:if code="http.server.auth.login:login-failed?">
+			<t:a href="register">Register</t:a>
+		</t:if>
+		|
+		<t:if code="http.server.auth.login:allow-password-recovery?">
+			<t:a href="recover-password">Recover Password</t:a>
+		</t:if>
+	</p>
+
+</t:chloe>

extra/http/server/auth/login/recover-1.fhtml

@@ -1,41 +0,0 @@
-<% USING: http.server.components http.server ; %>
-<html>
-<body>
-<h1>Recover lost password: step 1 of 4</h1>
-
-<p>Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.</p>
-
-<form method="POST" action="recover-password">
-
-<% hidden-form-field %>
-
-<table>
-
-<tr>
-<td>User name:</td>
-<td><% "username" component render-edit %></td>
-</tr>
-
-<tr>
-<td>E-mail:</td>
-<td><% "email" component render-edit %></td>
-</tr>
-
-<tr>
-<td>Captcha:</td>
-<td><% "captcha" component render-edit %></td>
-</tr>
-
-<tr>
-<td></td>
-<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.</td>
-</tr>
-
-</table>
-
-<input type="submit" value="Recover password" />
-
-</form>
-
-</body>
-</html>

extra/http/server/auth/login/recover-1.xml

@@ -0,0 +1,39 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:title>Recover lost password: step 1 of 4</t:title>
+
+	<p>Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.</p>
+
+	<t:form action="recover-password">
+
+		<table>
+
+		<tr>
+		<th class="field-label">User name:</th>
+		<td><t:edit component="username" /></td>
+		</tr>
+
+		<tr>
+		<th class="field-label">E-mail:</th>
+		<td><t:edit component="email" /></td>
+		</tr>
+
+		<tr>
+		<th class="field-label">Captcha:</th>
+		<td><t:edit component="captcha" /></td>
+		</tr>
+
+		<tr>
+		<td></td>
+		<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.</td>
+		</tr>
+
+		</table>
+
+		<input type="submit" value="Recover password" />
+
+	</t:form>
+
+</t:chloe>

extra/http/server/auth/login/recover-2.fhtml

@@ -1,9 +0,0 @@
-<% USING: http.server.components ; %>
-<html>
-<body>
-<h1>Recover lost password: step 2 of 4</h1>
-
-<p>If you entered the correct username and e-mail address, you should receive an e-mail shortly. Click the link in the e-mail for further instructions.</p>
-
-</body>
-</html>

extra/http/server/auth/login/recover-2.xml

@@ -0,0 +1,9 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:title>Recover lost password: step 2 of 4</t:title>
+
+	<p>If you entered the correct username and e-mail address, you should receive an e-mail shortly. Click the link in the e-mail for further instructions.</p>
+
+</t:chloe>

extra/http/server/auth/login/recover-3.fhtml

@@ -1,46 +0,0 @@
-<% USING: http.server.components http.server.auth.login http.server
-namespaces kernel combinators ; %>
-<html>
-<body>
-<h1>Recover lost password: step 3 of 4</h1>
-
-<p>Choose a new password for your account.</p>
-
-<form method="POST" action="new-password">
-
-<% hidden-form-field %>
-
-<table>
-
-<% "username" component render-edit %>
-<% "ticket" component render-edit %>
-
-<tr>
-<td>Password:</td>
-<td><% "new-password" component render-edit %></td>
-</tr>
-
-<tr>
-<td>Verify password:</td>
-<td><% "verify-password" component render-edit %></td>
-</tr>
-
-<tr>
-<td></td>
-<td>Enter your password twice to ensure it is correct.</td>
-</tr>
-
-</table>
-
-<p><input type="submit" value="Set password" />
-
-<% password-mismatch? get [
-    "passwords do not match" render-error
-] when %>
-
-</p>
-
-</form>
-
-</body>
-</html>

extra/http/server/auth/login/recover-3.xml

@@ -0,0 +1,43 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:title>Recover lost password: step 3 of 4</t:title>
+
+	<p>Choose a new password for your account.</p>
+
+	<t:form action="new-password">
+
+		<table>
+
+			<t:edit component="username" />
+			<t:edit component="ticket" />
+
+			<tr>
+			<th class="field-label">Password:</th>
+			<td><t:edit component="new-password" /></td>
+			</tr>
+
+			<tr>
+			<th class="field-label">Verify password:</th>
+			<td><t:edit component="verify-password" /></td>
+			</tr>
+
+			<tr>
+			<td></td>
+			<td>Enter your password twice to ensure it is correct.</td>
+			</tr>
+
+		</table>
+
+		<p>
+			<input type="submit" value="Set password" />
+
+			<t:if var="http.server.auth.login:password-mismatch?">
+				<t:error>passwords do not match</t:error>
+			</t:if>
+		</p>
+
+	</t:form>
+
+</t:chloe>

extra/http/server/auth/login/recover-4.fhtml

@@ -1,10 +0,0 @@
-<% USING: http.server ; %>
-<html>
-<body>
-<h1>Recover lost password: step 4 of 4</h1>
-
-<p>Your password has been reset.
-You may now <a href="<% "login" f write-link %>">log in</a>.</p>
-
-</body>
-</html>

extra/http/server/auth/login/recover-4.xml

@@ -0,0 +1,9 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:title>Recover lost password: step 4 of 4</t:title>
+
+	<p>Your password has been reset. You may now <t:a href="login">log in</t:a>.</p>
+
+</t:chloe>

extra/http/server/auth/login/register.fhtml

@@ -1,77 +0,0 @@
-<% USING: http.server.components http.server.auth.login
-http.server namespaces kernel combinators ; %>
-<html>
-<body>
-<h1>New user registration</h1>
-
-<form method="POST" action="register">
-<% hidden-form-field %>
-
-<table>
-
-<tr>
-<td>User name:</td>
-<td><% "username" component render-edit %></td>
-</tr>
-
-<tr>
-<td>Real name:</td>
-<td><% "realname" component render-edit %></td>
-</tr>
-
-<tr>
-<td></td>
-<td>Specifying a real name is optional.</td>
-</tr>
-
-<tr>
-<td>Password:</td>
-<td><% "new-password" component render-edit %></td>
-</tr>
-
-<tr>
-<td>Verify:</td>
-<td><% "verify-password" component render-edit %></td>
-</tr>
-
-<tr>
-<td></td>
-<td>Enter your password twice to ensure it is correct.</td>
-</tr>
-
-<tr>
-<td>E-mail:</td>
-<td><% "email" component render-edit %></td>
-</tr>
-
-<tr>
-<td></td>
-<td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
-</tr>
-
-<tr>
-<td>Captcha:</td>
-<td><% "captcha" component render-edit %></td>
-</tr>
-
-<tr>
-<td></td>
-<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
-</tr>
-
-</table>
-
-<p><input type="submit" value="Register" />
-
-<% {
-    { [ password-mismatch? get ] [ "passwords do not match" render-error ] }
-    { [ user-exists? get ] [ "username taken" render-error ] }
-    { [ t ] [ ] }
-} cond %>
-
-</p>
-
-</form>
-
-</body>
-</html>

extra/http/server/auth/login/register.xml

@@ -0,0 +1,79 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:title>New User Registration</t:title>
+
+	<t:form action="register">
+
+		<table>
+
+		<tr>
+		<th class="field-label">User name:</th>
+		<td><t:edit component="username" /></td>
+		</tr>
+
+		<tr>
+		<th class="field-label">Real name:</th>
+		<td><t:edit component="realname" /></td>
+		</tr>
+
+		<tr>
+		<td></td>
+		<td>Specifying a real name is optional.</td>
+		</tr>
+
+		<tr>
+		<th class="field-label">Password:</th>
+		<td><t:edit component="new-password" /></td>
+		</tr>
+
+		<tr>
+		<th class="field-label">Verify:</th>
+		<td><t:edit component="verify-password" /></td>
+		</tr>
+
+		<tr>
+		<td></td>
+		<td>Enter your password twice to ensure it is correct.</td>
+		</tr>
+
+		<tr>
+		<th class="field-label">E-mail:</th>
+		<td><t:edit component="email" /></td>
+		</tr>
+
+		<tr>
+		<td></td>
+		<td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
+		</tr>
+
+		<tr>
+		<th class="field-label">Captcha:</th>
+		<td><t:edit component="captcha" /></td>
+		</tr>
+
+		<tr>
+		<td></td>
+		<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
+		</tr>
+
+		</table>
+
+		<p>
+
+			<input type="submit" value="Register" />
+
+			<t:if var="http.server.auth.login:user-exists?">
+				<t:error>username taken</t:error>
+			</t:if>
+
+			<t:if var="http.server.auth.login:password-mismatch?">
+				<t:error>passwords do not match</t:error>
+			</t:if>
+
+		</p>
+
+	</t:form>
+
+</t:chloe>

extra/http/server/auth/providers/assoc/assoc-tests.factor

@@ -26,7 +26,7 @@ namespaces accessors kernel ;
 
 [ t ] [ "user" get >boolean ] unit-test
 
-[ ] [ "user" get "fdasf" set-password drop ] unit-test
+[ ] [ "user" get "fdasf" >>password drop ] unit-test
 
 [ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test
 

extra/http/server/auth/providers/db/db-tests.factor

@@ -31,7 +31,7 @@ users-in-db "provider" set
 
     [ t ] [ "user" get >boolean ] unit-test
 
-    [ ] [ "user" get "fdasf" set-password drop ] unit-test
+    [ ] [ "user" get "fdasf" >>password drop ] unit-test
 
     [ ] [ "user" get "provider" get update-user ] unit-test
 

extra/http/server/auth/providers/providers.factor

@@ -17,8 +17,6 @@ GENERIC: new-user ( user provider -- user/f )
 : check-login ( password username provider -- user/f )
     get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ;
 
-: set-password ( user password -- user ) >>password ;
-
 ! Password recovery support
 
 :: issue-ticket ( email username provider -- user/f )

extra/http/server/boilerplate/boilerplate.factor

@@ -0,0 +1,49 @@
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel namespaces boxes sequences strings
+io io.streams.string
+http.server
+http.server.templating ;
+IN: http.server.boilerplate
+
+TUPLE: boilerplate responder template ;
+
+: <boilerplate> f boilerplate boa ;
+
+SYMBOL: title
+
+: set-title ( string -- )
+    title get >box ;
+
+: write-title ( -- )
+    title get value>> write ;
+
+SYMBOL: style
+
+: add-style ( string -- )
+    "\n" style get push-all
+         style get push-all ;
+
+: write-style ( -- )
+    style get >string write ;
+
+SYMBOL: next-template
+
+: call-next-template ( -- )
+    next-template get write ;
+
+M: f call-template drop call-next-template ;
+
+: with-boilerplate ( body template -- )
+    [
+        title get [ <box> title set ] unless
+        style get [ SBUF" " clone style set ] unless
+
+        swap with-string-writer next-template set
+
+        call-template
+    ] with-scope ; inline
+
+M: boilerplate call-responder
+    [ responder>> call-responder clone ] [ template>> ] bi
+    [ [ with-boilerplate ] 2curry ] curry change-body ;

extra/http/server/components/components-tests.factor

@@ -1,7 +1,11 @@
 IN: http.server.components.tests
-USING: http.server.components http.server.validators
+USING: http.server.components http.server.forms
-namespaces tools.test kernel accessors
+http.server.validators namespaces tools.test kernel accessors
-tuple-syntax mirrors http.server.actions ;
+tuple-syntax mirrors http.server.actions
+http.server.templating.fhtml
+io.streams.string io.streams.null ;
+
+\ render-edit must-infer
 
 validation-failed? off
 
@@ -46,8 +50,8 @@ TUPLE: test-tuple text number more-text ;
 
 : <test-form> ( -- form )
     "test" <form>
-        "resource:extra/http/server/components/test/form.fhtml" >>view-template
+        "resource:extra/http/server/components/test/form.fhtml" <fhtml> >>view-template
-        "resource:extra/http/server/components/test/form.fhtml" >>edit-template
+        "resource:extra/http/server/components/test/form.fhtml" <fhtml> >>edit-template
         "text" <string>
             t >>required
             add-field
@@ -99,11 +103,31 @@ TUPLE: test-tuple text number more-text ;
         "123" "n" get validate value>>
     ] unit-test
     
-    [ ] [ "n" get t >>integer drop ] unit-test
+    [ ] [ "i" <integer> "i" set ] unit-test
 
     [ 3 ] [
-        "3" "n" get validate
+        "3" "i" get validate
     ] unit-test
+    
+    [ t ] [
+        "3.9" "i" get validate validation-error?
+    ] unit-test
+
+    H{ } clone values set
+
+    [ ] [ 3 "i" set-value ] unit-test
+
+    [ "3" ] [ [ "i" get render-view ] with-string-writer ] unit-test
+
+    [ ] [ [ "i" get render-edit ] with-null-stream ] unit-test
+
+    [ ] [ "t" <text> "t" set ] unit-test
+
+    [ ] [ "hello world" "t" set-value ] unit-test
+
+    [ ] [ [ "t" get render-edit ] with-null-stream ] unit-test
 ] with-scope
 
 [ t ] [ "wake up sheeple" dup "n" <text> validate = ] unit-test
+
+[ ] [ "password" <password> "p" set ] unit-test

extra/http/server/components/components.factor

@@ -2,23 +2,47 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: html.elements http.server.validators accessors namespaces
 kernel io math.parser assocs classes words classes.tuple arrays
-sequences io.files http.server.templating.fhtml
+sequences splitting mirrors hashtables fry combinators
-http.server.actions splitting mirrors hashtables fry
 continuations math ;
 IN: http.server.components
 
+! Renderer protocol
+GENERIC: render-view* ( value renderer -- )
+GENERIC: render-edit* ( value id renderer -- )
+
+TUPLE: field type ;
+
+C: <field> field
+
+M: field render-view* drop write ;
+
+M: field render-edit*
+    <input type>> =type [ =id ] [ =name ] bi =value input/> ;
+
+: render-error ( message -- )
+    <span "error" =class span> write </span> ;
+
+TUPLE: hidden < field ;
+
+: hidden ( -- renderer ) T{ hidden f "hidden" } ; inline
+
+M: hidden render-view* 2drop ;
+
+! Component protocol
 SYMBOL: components
 
-TUPLE: component id required default ;
+TUPLE: component id required default renderer ;
 
 : component ( name -- component )
     dup components get at
     [ ] [ "No such component: " prepend throw ] ?if ;
 
+GENERIC: init ( component -- component )
+
+M: component init ;
+
 GENERIC: validate* ( value component -- result )
-GENERIC: render-view* ( value component -- )
+GENERIC: component-string ( value component -- string )
-GENERIC: render-edit* ( value component -- )
-GENERIC: render-error* ( reason value component -- )
 
 SYMBOL: values
 
@@ -26,6 +50,41 @@ SYMBOL: values
 
 : set-value values get set-at ;
 
+: blank-values H{ } clone values set ;
+
+: from-tuple <mirror> values set ;
+
+: values-tuple values get mirror-object ;
+
+: render-view ( component -- )
+    [ id>> value ] [ component-string ] [ renderer>> ] tri
+    render-view* ;
+
+<PRIVATE
+
+: render-edit-string ( string component -- )
+    [ id>> ] [ renderer>> ] bi render-edit* ;
+
+: render-edit-error ( component -- )
+    [ id>> value ] keep
+    [ [ value>> ] dip render-edit-string ]
+    [ drop reason>> render-error ] 2bi ;
+
+: value-or-default ( component -- value )
+    [ id>> value ] [ default>> ] bi or ;
+
+: render-edit-value ( component -- )
+    [ value-or-default ]
+    [ component-string ]
+    [ render-edit-string ]
+    tri ;
+
+PRIVATE>
+
+: render-edit ( component -- )
+    dup id>> value validation-error?
+    [ render-edit-error ] [ render-edit-value ] if ;
+
 : validate ( value component -- result )
     '[
         ,
@@ -36,206 +95,143 @@ SYMBOL: values
         ] [ validate* ] if
     ] with-validator ;
 
-: render-view ( component -- )
+: new-component ( id class renderer -- component )
-    [ id>> value ] [ render-view* ] bi ;
+    swap new
-
+        swap >>renderer
-: render-error ( error -- )
+        swap >>id
-    <span "error" =class span> write </span> ;
+        init ; inline
-
-: render-edit ( component -- )
-    dup id>> value dup validation-error? [
-        [ reason>> ] [ value>> ] bi rot render-error*
-    ] [
-        swap [ default>> or ] keep render-edit*
-    ] if ;
-
-: <component> ( id class -- component )
-    \ component new
-    swap construct-delegate
-    swap >>id ; inline
-
-! Forms
-TUPLE: form view-template edit-template components ;
-
-: <form> ( id -- form )
-    form <component>
-        V{ } clone >>components ;
-
-: add-field ( form component -- form )
-    dup id>> pick components>> set-at ;
-
-: with-form ( form quot -- )
-    >r components>> components r> with-variable ; inline
-
-: set-defaults ( form -- )
-    [
-        components get [
-            swap values get [
-                swap default>> or
-            ] change-at
-        ] assoc-each
-    ] with-form ;
-
-: view-form ( form -- )
-    dup view-template>> '[ , run-template ] with-form ;
-
-: edit-form ( form -- )
-    dup edit-template>> '[ , run-template ] with-form ;
-
-: validate-param ( id component -- )
-    [ [ params get at ] [ validate ] bi* ]
-    [ drop set-value ] 2bi ;
-
-: (validate-form) ( form -- error? )
-    [
-        validation-failed? off
-        components get [ validate-param ] assoc-each
-        validation-failed? get
-    ] with-form ;
-
-: validate-form ( form -- )
-    (validate-form) [ validation-failed ] when ;
-
-: blank-values H{ } clone values set ;
-
-: from-tuple <mirror> values set ;
-
-: values-tuple values get mirror-object ;
-
-! ! !
-! Canned components: for simple applications and prototyping
-! ! !
-
-: render-input ( value component type -- )
-    <input
-    =type
-    id>> [ =id ] [ =name ] bi
-    =value
-    input/> ;
-
-! Hidden fields
-TUPLE: hidden ;
-
-: <hidden> ( component -- component )
-    hidden construct-delegate ;
-
-M: hidden render-view*
-    2drop ;
-
-M: hidden render-edit*
-    >r dup number? [ number>string ] when r>
-    "hidden" render-input ;
 
 ! String input fields
-TUPLE: string min-length max-length ;
+TUPLE: string < component one-line min-length max-length ;
 
-: <string> ( id -- component ) string <component> ;
+: new-string ( id class -- component )
+    "text" <field> new-component
+        t >>one-line ; inline
+
+: <string> ( id -- component )
+    string new-string ;
 
 M: string validate*
-    [ v-one-line ] [
+    [   one-line>> [ v-one-line   ] when  ]
     [ min-length>> [ v-min-length ] when* ]
     [ max-length>> [ v-max-length ] when* ]
-        bi
+    tri ;
-    ] bi* ;
 
-M: string render-view*
+M: string component-string
-    drop write ;
+    drop ;
-
-M: string render-edit*
-    "text" render-input ;
-
-M: string render-error*
-    "text" render-input render-error ;
 
 ! Username fields
-TUPLE: username ;
+TUPLE: username < string ;
 
-: <username> ( id -- component )
+M: username init
-    <string> username construct-delegate
     2 >>min-length
     20 >>max-length ;
 
+: <username> ( id -- component )
+    username new-string ;
+
 M: username validate*
-    delegate validate* v-one-word ;
+    call-next-method v-one-word ;
 
 ! E-mail fields
-TUPLE: email ;
+TUPLE: email < string ;
 
 : <email> ( id -- component )
-    <string> email construct-delegate
+    email new-string
         5 >>min-length
         60 >>max-length ;
 
 M: email validate*
-    delegate validate* dup empty? [ v-email ] unless ;
+    call-next-method dup empty? [ v-email ] unless ;
+
+! Don't send passwords back to the user
+TUPLE: password-renderer < field ;
+
+: password-renderer T{ password-renderer f "password" } ;
+
+: blank-password >r >r drop "" r> r> ;
+
+M: password-renderer render-edit*
+    blank-password call-next-method ;
 
 ! Password fields
-TUPLE: password ;
+TUPLE: password < string ;
 
-: <password> ( id -- component )
+M: password init
-    <string> password construct-delegate
     6 >>min-length
     60 >>max-length ;
 
+: <password> ( id -- component )
+    password new-string
+        password-renderer >>renderer ;
+
 M: password validate*
-    delegate validate* v-one-word ;
+    call-next-method v-one-word ;
-
-M: password render-edit*
-    >r drop f r> "password" render-input ;
-
-M: password render-error*
-    render-edit* render-error ;
 
 ! Number fields
-TUPLE: number min-value max-value integer ;
+TUPLE: number < string min-value max-value ;
 
-: <number> ( id -- component ) number <component> ;
+: <number> ( id -- component )
+    number new-string ;
 
 M: number validate*
     [ v-number ] [
-        [ integer>> [ v-integer ] when ]
         [ min-value>> [ v-min-value ] when* ]
         [ max-value>> [ v-max-value ] when* ]
-        tri
+        bi
     ] bi* ;
 
-M: number render-view*
+M: number component-string
-    drop number>string write ;
+    drop dup [ number>string ] when ;
 
-M: number render-edit*
+! Integer fields
-    >r number>string r> "text" render-input ;
+TUPLE: integer < number ;
 
-M: number render-error*
+: <integer> ( id -- component )
-    "text" render-input render-error ;
+    integer new-string ;
+
+M: integer validate*
+    call-next-method v-integer ;
+
+! Simple captchas
+TUPLE: captcha < string ;
+
+: <captcha> ( id -- component )
+    captcha new-string ;
+
+M: captcha validate*
+    drop v-captcha ;
 
 ! Text areas
-TUPLE: text ;
+TUPLE: textarea-renderer rows cols ;
 
-: <text> ( id -- component ) text <component> ;
+: new-textarea-renderer ( class -- renderer )
+    new
+        60 >>cols
+        20 >>rows ;
 
-M: text validate* drop ;
+: <textarea-renderer> ( -- renderer )
+    textarea-renderer new-textarea-renderer ;
 
-M: text render-view*
+M: textarea-renderer render-view*
     drop write ;
 
-: render-textarea
+M: textarea-renderer render-edit*
     <textarea
-        id>> [ =id ] [ =name ] bi
+        [ rows>> [ number>string =rows ] when* ]
+        [ cols>> [ number>string =cols ] when* ] bi
+        [ =id   ]
+        [ =name ] bi
     textarea>
         write
     </textarea> ;
 
-M: text render-edit*
+TUPLE: text < string ;
-    render-textarea ;
 
-M: text render-error*
+: new-text ( id class -- component )
-    render-textarea render-error ;
+    new-string
+        f >>one-line
+        <textarea-renderer> >>renderer ;
 
-! Simple captchas
+: <text> ( id -- component )
-TUPLE: captcha ;
+    text new-text ;
-
-: <captcha> ( id -- component )
-    <string> captcha construct-delegate ;
-
-M: captcha validate*
-    drop v-captcha ;

extra/http/server/components/farkup/farkup.factor

@@ -1,13 +1,17 @@
 ! Copyright (C) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: splitting http.server.components kernel io sequences
+USING: splitting kernel io sequences farkup accessors
-farkup ;
+http.server.components ;
 IN: http.server.components.farkup
 
-TUPLE: farkup ;
+TUPLE: farkup-renderer < textarea-renderer ;
+
+: <farkup-renderer>
+    farkup-renderer new-textarea-renderer ;
+
+M: farkup-renderer render-view*
+    drop string-lines "\n" join convert-farkup write ;
 
 : <farkup> ( id -- component )
-    <text> farkup construct-delegate ;
+    <text>
-
+        <farkup-renderer> >>renderer ;
-M: farkup render-view*
-    drop string-lines "\n" join convert-farkup write ;

extra/http/server/crud/crud.factor

@@ -1,9 +1,13 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces db.tuples math.parser
+accessors fry locals hashtables
+http.server
+http.server.actions
+http.server.components
+http.server.forms
+http.server.validators ;
 IN: http.server.crud
-USING: kernel namespaces db.tuples math.parser http.server
-http.server.actions http.server.components
-http.server.validators accessors fry locals hashtables ;
 
 :: <view-action> ( form ctor -- action )
     <action>
@@ -19,29 +23,18 @@ http.server.validators accessors fry locals hashtables ;
 : <id-redirect> ( id next -- response )
     swap number>string "id" associate <permanent-redirect> ;
 
-:: <create-action> ( form ctor next -- action )
-    <action>
-        [ f ctor call from-tuple form set-defaults ] >>init
-
-        [
-            "text/html" <content>
-            [ form edit-form ] >>body
-        ] >>display
-
-        [
-            f ctor call from-tuple
-
-            form validate-form
-
-            values-tuple insert-tuple
-
-            "id" value next <id-redirect>
-        ] >>submit ;
-
 :: <edit-action> ( form ctor next -- action )
     <action>
-        { { "id" [ v-number ] } } >>get-params
+        { { "id" [ [ v-number ] v-optional ] } } >>get-params
-        [ "id" get ctor call select-tuple from-tuple ] >>init
+
+        [
+            "id" get ctor call
+
+            "id" get
+            [ select-tuple from-tuple ]
+            [ from-tuple form set-defaults ]
+            if
+        ] >>init
 
         [
             "text/html" <content>
@@ -53,7 +46,8 @@ http.server.validators accessors fry locals hashtables ;
 
             form validate-form
 
-            values-tuple update-tuple
+            values-tuple
+            "id" value [ update-tuple ] [ insert-tuple ] if
 
             "id" value next <id-redirect>
         ] >>submit ;
@@ -67,3 +61,16 @@ http.server.validators accessors fry locals hashtables ;
 
             next f <permanent-redirect>
         ] >>submit ;
+
+:: <list-action> ( form ctor -- action )
+    <action>
+        [
+            "text/html" <content>
+            [
+                blank-values
+
+                f ctor call select-tuples "list" set-value
+
+                form view-form
+            ] >>body
+        ] >>display ;

extra/http/server/db/db.factor

@@ -9,8 +9,8 @@ TUPLE: db-persistence responder db params ;
 C: <db-persistence> db-persistence
 
 : connect-db ( db-persistence -- )
-    [ db>> ] [ params>> ] bi make-db
+    [ db>> ] [ params>> ] bi make-db db-open
-    [ db set ] [ db-open ] [ add-always-destructor ] tri ;
+    [ db set ] [ add-always-destructor ] bi ;
 
 M: db-persistence call-responder
     [ connect-db ] [ responder>> call-responder ] bi ;

extra/http/server/forms/forms.factor

@@ -0,0 +1,70 @@
+USING: kernel accessors assocs namespaces io.files sequences fry
+http.server.actions
+http.server.components
+http.server.validators
+http.server.templating ;
+IN: http.server.forms
+
+TUPLE: form < component
+view-template edit-template summary-template
+components ;
+
+M: form init V{ } clone >>components ;
+
+: <form> ( id -- form )
+    form f new-component ;
+
+: add-field ( form component -- form )
+    dup id>> pick components>> set-at ;
+
+: with-form ( form quot -- )
+    >r components>> components r> with-variable ; inline
+
+: set-defaults ( form -- )
+    [
+        components get [
+            swap values get [
+                swap default>> or
+            ] change-at
+        ] assoc-each
+    ] with-form ;
+
+: view-form ( form -- )
+    dup view-template>> '[ , call-template ] with-form ;
+
+: edit-form ( form -- )
+    dup edit-template>> '[ , call-template ] with-form ;
+
+: summary-form ( form -- )
+    dup summary-template>> '[ , call-template ] with-form ;
+
+: validate-param ( id component -- )
+    [ [ params get at ] [ validate ] bi* ]
+    [ drop set-value ] 2bi ;
+
+: (validate-form) ( form -- error? )
+    [
+        validation-failed? off
+        components get [ validate-param ] assoc-each
+        validation-failed? get
+    ] with-form ;
+
+: validate-form ( form -- )
+    (validate-form) [ validation-failed ] when ;
+
+! List components
+TUPLE: list-renderer form ;
+
+C: <list-renderer> list-renderer
+
+M: list-renderer render-view*
+    form>> [
+        [ >r from-tuple r> summary-form ] with-scope
+    ] curry each ;
+
+TUPLE: list < component ;
+
+: <list> ( id form -- list )
+    list swap <list-renderer> new-component ;
+
+M: list component-string drop ;

extra/http/server/server.factor

@@ -105,8 +105,13 @@ SYMBOL: form-hook
 
 TUPLE: dispatcher default responders ;
 
+: new-dispatcher ( class -- dispatcher )
+    new
+        404-responder get >>default
+        H{ } clone >>responders ; inline
+
 : <dispatcher> ( -- dispatcher )
-    404-responder get H{ } clone dispatcher boa ;
+    dispatcher new-dispatcher ;
 
 : split-path ( path -- rest first )
     [ CHAR: / = ] left-trim "/" split1 swap ;
@@ -125,9 +130,6 @@ M: dispatcher call-responder ( path dispatcher -- response )
         2drop redirect-with-/
     ] if ;
 
-: <webapp> ( class -- dispatcher )
-    <dispatcher> swap construct-delegate ; inline
-
 TUPLE: vhost-dispatcher default responders ;
 
 : <vhost-dispatcher> ( -- dispatcher )

extra/http/server/sessions/sessions.factor

@@ -17,9 +17,10 @@ M: object init-session* drop ;
 
 TUPLE: session-manager responder sessions ;
 
-: <session-manager> ( responder class -- responder' )
+: new-session-manager ( responder class -- responder' )
-    >r <sessions-in-memory> session-manager boa
+    new
-    r> construct-delegate ; inline
+        <sessions-in-memory> >>sessions
+        swap >>responder ; inline
 
 SYMBOLS: session session-id session-changed? ;
 
@@ -64,18 +65,18 @@ M: session-saver dispose
     [ [ session-id set ] [ session set ] bi* ] 2bi
     [ session-manager set ] [ responder>> call-responder ] bi ;
 
-TUPLE: null-sessions ;
+TUPLE: null-sessions < session-manager ;
 
 : <null-sessions>
-    null-sessions <session-manager> ;
+    null-sessions new-session-manager ;
 
 M: null-sessions call-responder ( path responder -- response )
     H{ } clone f call-responder/session ;
 
-TUPLE: url-sessions ;
+TUPLE: url-sessions < session-manager ;
 
 : <url-sessions> ( responder -- responder' )
-    url-sessions <session-manager> ;
+    url-sessions new-session-manager ;
 
 : session-id-key "factorsessid" ;
 
@@ -107,10 +108,10 @@ M: url-sessions call-responder ( path responder -- response )
         2drop nip new-url-session
     ] if ;
 
-TUPLE: cookie-sessions ;
+TUPLE: cookie-sessions < session-manager ;
 
 : <cookie-sessions> ( responder -- responder' )
-    cookie-sessions <session-manager> ;
+    cookie-sessions new-session-manager ;
 
 : current-cookie-session ( responder -- id namespace/f )
     request get session-id-key get-cookie dup

extra/http/server/templating/chloe/chloe-tests.factor

@@ -0,0 +1,97 @@
+USING: http.server.templating http.server.templating.chloe
+http.server.components http.server.boilerplate tools.test
+io.streams.string kernel sequences ascii boxes namespaces xml
+splitting ;
+IN: http.server.templating.chloe.tests
+
+[ "foo" ]
+[ "<a href=\"foo\">blah</a>" string>xml "href" required-attr ]
+unit-test
+
+[ "<a name=\"foo\">blah</a>" string>xml "href" required-attr ]
+[ "href attribute is required" = ]
+must-fail-with
+
+[ f ] [ f parse-query-attr ] unit-test
+
+[ f ] [ "" parse-query-attr ] unit-test
+
+[ H{ { "a" "b" } } ] [
+    blank-values
+    "b" "a" set-value
+    "a" parse-query-attr
+] unit-test
+
+[ H{ { "a" "b" } { "c" "d" } } ] [
+    blank-values
+    "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 ] subset
+    "?>" split1 nip ; inline
+
+: test-template ( name -- template )
+    "resource:extra/http/server/templating/chloe/test/"
+    swap
+    ".xml" 3append <chloe> ;
+
+[ "Hello world" ] [
+    [
+        "test1" test-template call-template
+    ] run-template
+] unit-test
+
+[ "Blah blah" "Hello world" ] [
+    [
+        <box> title set
+        [
+            "test2" test-template call-template
+        ] run-template
+        title get box>
+    ] with-scope
+] unit-test
+
+[ "<html><head><title>Hello world</title></head><body>Blah blah</body></html>" ] [
+    [
+        [
+            "test2" test-template call-template
+        ] "test3" test-template with-boilerplate
+    ] run-template
+] unit-test
+
+: test4-aux? t ;
+
+[ "True" ] [
+    [
+        "test4" test-template call-template
+    ] run-template
+] unit-test
+
+: test5-aux? f ;
+
+[ "" ] [
+    [
+        "test5" test-template call-template
+    ] run-template
+] unit-test
+
+SYMBOL: test6-aux?
+
+[ "True" ] [
+    [
+        test6-aux? on
+        "test6" test-template call-template
+    ] run-template
+] unit-test
+
+SYMBOL: test7-aux?
+
+[ "" ] [
+    [
+        test7-aux? off
+        "test7" test-template call-template
+    ] run-template
+] unit-test

extra/http/server/templating/chloe/chloe.factor

@@ -0,0 +1,168 @@
+USING: accessors kernel sequences combinators kernel namespaces
+classes.tuple assocs splitting words arrays
+io.files io.encodings.utf8 html.elements unicode.case
+tuple-syntax xml xml.data xml.writer xml.utilities
+http.server
+http.server.auth
+http.server.components
+http.server.sessions
+http.server.templating
+http.server.boilerplate ;
+IN: http.server.templating.chloe
+
+! Chloe is Ed's favorite web designer
+
+TUPLE: chloe path ;
+
+C: <chloe> chloe
+
+DEFER: process-template
+
+: chloe-ns TUPLE{ name url: "http://factorcode.org/chloe/1.0" } ;
+
+: chloe-tag? ( tag -- ? )
+    {
+        { [ dup tag? not ] [ f ] }
+        { [ dup chloe-ns names-match? not ] [ f ] }
+        [ t ]
+    } cond nip ;
+
+SYMBOL: tags
+
+: required-attr ( tag name -- value )
+    dup rot at*
+    [ nip ] [ drop " attribute is required" append throw ] if ;
+
+: optional-attr ( tag name -- value )
+    swap at ;
+
+: write-title-tag ( tag -- )
+    drop
+    "head" tags get member? "title" tags get member? not and
+    [ <title> write-title </title> ] [ write-title ] if ;
+
+: style-tag ( tag -- )
+    dup "include" optional-attr dup [
+        swap children>string empty? [
+            "style tag cannot have both an include attribute and a body" throw
+        ] unless
+        utf8 file-contents
+    ] [
+        drop children>string
+    ] if add-style ;
+
+: write-style-tag ( tag -- )
+    drop <style> write-style </style> ;
+
+: component-attr ( tag -- name )
+    "component" required-attr ;
+
+: view-tag ( tag -- )
+    component-attr component render-view ;
+
+: edit-tag ( tag -- )
+    component-attr component render-edit ;
+
+: parse-query-attr ( string -- assoc )
+    dup empty?
+    [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
+
+: a-start-tag ( tag -- )
+    <a
+    [ "href" required-attr ]
+    [ "query" optional-attr parse-query-attr ]
+    bi link>string =href
+    a> ;
+
+: process-tag-children ( tag -- )
+    [ process-template ] each ;
+
+: a-tag ( tag -- )
+    [ a-start-tag ]
+    [ process-tag-children ]
+    [ drop </a> ]
+    tri ;
+
+: form-start-tag ( tag -- )
+    <form
+    "POST" =method
+    tag-attrs print-attrs
+    form>
+    hidden-form-field ;
+
+: form-tag ( tag -- )
+    [ form-start-tag ]
+    [ process-tag-children ]
+    [ drop </form> ]
+    tri ;
+
+: attr>word ( value -- word/f )
+    dup ":" split1 swap lookup
+    [ ] [ "No such word: " swap append throw ] ?if ;
+
+: attr>var ( value -- word/f )
+    attr>word dup symbol? [
+        "Must be a symbol: " swap append throw
+    ] unless ;
+
+: if-satisfied? ( tag -- ? )
+    {
+        [ "code" optional-attr [ attr>word execute ] [ t ] if* ]
+        [  "var" optional-attr [ attr>var      get ] [ t ] if* ]
+        [ "svar" optional-attr [ attr>var     sget ] [ t ] if* ]
+        [ "uvar" optional-attr [ attr>var     uget ] [ t ] if* ]
+    } cleave 4array [ ] all? ;
+
+: if-tag ( tag -- )
+    dup if-satisfied? [ process-tag-children ] [ drop ] if ;
+
+: error-tag ( tag -- )
+    children>string render-error ;
+
+: process-chloe-tag ( tag -- )
+    dup name-tag {
+        { "chloe" [ [ process-template ] each ] }
+        { "title" [ children>string set-title ] }
+        { "write-title" [ write-title-tag ] }
+        { "style" [ style-tag ] }
+        { "write-style" [ write-style-tag ] }
+        { "view" [ view-tag ] }
+        { "edit" [ edit-tag ] }
+        { "a" [ a-tag ] }
+        { "form" [ form-tag ] }
+        { "error" [ error-tag ] }
+        { "if" [ if-tag ] }
+        { "call-next-template" [ drop call-next-template ] }
+        [ "Unknown chloe tag: " swap append throw ]
+    } case ;
+
+: process-tag ( tag -- )
+    {
+        [ name-tag >lower tags get push ]
+        [ write-start-tag ]
+        [ process-tag-children ]
+        [ write-end-tag ]
+        [ drop tags get pop* ]
+    } cleave ;
+
+: process-template ( xml -- )
+    {
+        { [ dup [ chloe-tag? ] is? ] [ process-chloe-tag ] }
+        { [ dup [ tag? ] is? ] [ process-tag ] }
+        { [ t ] [ write-item ] }
+    } cond ;
+
+: process-chloe ( xml -- )
+    [
+        V{ } clone tags set
+
+        {
+            [ xml-prolog write-prolog ]
+            [ xml-before write-chunk  ]
+            [ process-template        ]
+            [ xml-after write-chunk   ]
+        } cleave
+    ] with-scope ;
+
+M: chloe call-template
+    path>> utf8 <file-reader> read-xml process-chloe ;

extra/http/server/templating/chloe/test/test1.xml

@@ -0,0 +1,5 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+	Hello world
+</t:chloe>

extra/http/server/templating/chloe/test/test2.xml

@@ -0,0 +1,6 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+	<t:title>Hello world</t:title>
+	Blah blah
+</t:chloe>

extra/http/server/templating/chloe/test/test3-aux.xml

@@ -0,0 +1,5 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+	<t:title>Hello world</t:title>
+</t:chloe>

extra/http/server/templating/chloe/test/test3.xml

@@ -0,0 +1,12 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+	<html>
+		<head>
+			<t:write-title />
+		</head>
+		<body>
+			<t:call-next-template />
+		</body>
+	</html>
+</t:chloe>

extra/http/server/templating/chloe/test/test4.xml

@@ -0,0 +1,9 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:if code="http.server.templating.chloe.tests:test4-aux?">
+		True
+	</t:if>
+
+</t:chloe>

extra/http/server/templating/chloe/test/test5.xml

@@ -0,0 +1,9 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:if code="http.server.templating.chloe.tests:test5-aux?">
+		True
+	</t:if>
+
+</t:chloe>

extra/http/server/templating/chloe/test/test6.xml

@@ -0,0 +1,9 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:if var="http.server.templating.chloe.tests:test6-aux?">
+		True
+	</t:if>
+
+</t:chloe>

extra/http/server/templating/chloe/test/test7.xml

@@ -0,0 +1,9 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:if var="http.server.templating.chloe.tests:test7-aux?">
+		True
+	</t:if>
+
+</t:chloe>

extra/http/server/templating/fhtml/fhtml-tests.factor

@@ -1,13 +1,13 @@
 USING: io io.files io.streams.string io.encodings.utf8
-http.server.templating.fhtml kernel tools.test sequences
+http.server.templating http.server.templating.fhtml kernel
-parser ;
+tools.test sequences parser ;
 IN: http.server.templating.fhtml.tests
 
 : test-template ( path -- ? )
     "resource:extra/http/server/templating/fhtml/test/"
     prepend
     [
-        ".fhtml" append [ run-template ] with-string-writer
+        ".fhtml" append <fhtml> [ call-template ] with-string-writer
     ] keep
     ".html" append utf8 file-contents = ;
 

extra/http/server/templating/fhtml/fhtml.factor

@@ -1,25 +1,22 @@
 ! Copyright (C) 2005 Alex Chapman
-! Copyright (C) 2006, 2007 Slava Pestov
+! Copyright (C) 2006, 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: continuations sequences kernel parser namespaces io
+USING: continuations sequences kernel namespaces debugger
-io.files io.streams.string html html.elements source-files
+combinators math quotations generic strings splitting
-debugger combinators math quotations generic strings splitting
+accessors assocs fry
-accessors http.server.static http.server assocs
+parser io io.files io.streams.string io.encodings.utf8 source-files
-io.encodings.utf8 fry ;
+html html.elements
-
+http.server.static http.server http.server.templating ;
 IN: http.server.templating.fhtml
 
 : templating-vocab ( -- vocab-name ) "http.server.templating.fhtml" ;
 
-! See apps/http-server/test/ or libs/furnace/ for template usage
-! examples
-
 ! We use a custom lexer so that %> ends a token even if not
 ! followed by whitespace
-TUPLE: template-lexer ;
+TUPLE: template-lexer < lexer ;
 
 : <template-lexer> ( lines -- lexer )
-    <lexer> template-lexer construct-delegate ;
+    template-lexer new-lexer ;
 
 M: template-lexer skip-word
     [
@@ -33,18 +30,18 @@ M: template-lexer skip-word
 DEFER: <% delimiter
 
 : check-<% ( lexer -- col )
-    "<%" over lexer-line-text rot lexer-column start* ;
+    "<%" over line-text>> rot column>> start* ;
 
 : found-<% ( accum lexer col -- accum )
     [
-        over lexer-line-text
+        over line-text>>
-        >r >r lexer-column r> r> subseq parsed
+        >r >r column>> r> r> subseq parsed
         \ write-html parsed
-    ] 2keep 2 + swap set-lexer-column ;
+    ] 2keep 2 + >>column drop ;
 
 : still-looking ( accum lexer -- accum )
     [
-        dup lexer-line-text swap lexer-column tail
+        [ line-text>> ] [ column>> ] bi tail
         parsed \ print-html parsed
     ] keep next-line ;
 
@@ -75,9 +72,13 @@ DEFER: <% delimiter
 : html-error. ( error -- )
     <pre> error. </pre> ;
 
-: run-template ( filename -- )
+TUPLE: fhtml path ;
+
+C: <fhtml> fhtml
+
+M: fhtml call-template ( filename -- )
     '[
-        , [
+        , path>> [
             "quiet" on
             parser-notes off
             templating-vocab use+
@@ -88,16 +89,8 @@ DEFER: <% delimiter
         ] with-file-vocabs
     ] assert-depth ;
 
-: template-convert ( infile outfile -- )
-    utf8 [ run-template ] with-file-writer ;
-
-! responder integration
-: serve-template ( name -- response )
-    "text/html" <content>
-    swap '[ , run-template ] >>body ;
-
 ! file responder integration
 : enable-fhtml ( responder -- responder )
-    [ serve-template ]
+    [ <fhtml> serve-template ]
     "application/x-factor-server-page"
     pick special>> set-at ;

extra/http/server/templating/templating.factor

@@ -0,0 +1,13 @@
+USING: accessors kernel fry io.encodings.utf8 io.files
+http.server ;
+IN: http.server.templating
+
+GENERIC: call-template ( template -- )
+
+: template-convert ( template output -- )
+    utf8 [ call-template ] with-file-writer ;
+
+! responder integration
+: serve-template ( template -- response )
+    "text/html" <content>
+    swap '[ , call-template ] >>body ;

extra/http/server/validators/validators.factor

@@ -11,8 +11,7 @@ TUPLE: validation-error value reason ;
 C: <validation-error> validation-error
 
 : with-validator ( value quot -- result )
-    [ validation-failed? on <validation-error> ] recover ;
+    [ validation-failed? on <validation-error> ] recover ; inline
-    inline
 
 : v-default ( str def -- str )
     over empty? spin ? ;
@@ -20,6 +19,9 @@ C: <validation-error> validation-error
 : v-required ( str -- str )
     dup empty? [ "required" throw ] when ;
 
+: v-optional ( str quot -- str )
+    over empty? [ 2drop f ] [ call ] if ; inline
+
 : v-min-length ( str n -- str )
     over length over < [
         [ "must be at least " % # " characters" % ] "" make

extra/io/monitors/monitors.factor

@@ -27,7 +27,7 @@ M: monitor timeout timeout>> ;
 
 M: monitor set-timeout (>>timeout) ;
 
-: construct-monitor ( path mailbox class -- monitor )
+: new-monitor ( path mailbox class -- monitor )
     new
         swap >>queue
         swap >>path ; inline

extra/io/monitors/recursive/recursive-tests.factor

@@ -21,7 +21,7 @@ M: dummy-monitor dispose
 M: mock-io-backend (monitor)
     nip
     over exists? [
-        dummy-monitor construct-monitor
+        dummy-monitor new-monitor
         dummy-monitor-created get [ 1+ ] change-i drop
     ] [
         "Does not exist" throw

extra/io/monitors/recursive/recursive.factor

@@ -98,7 +98,7 @@ M: recursive-monitor dispose
 
 : <recursive-monitor> ( path mailbox -- monitor )
     >r (normalize-path) r>
-    recursive-monitor construct-monitor
+    recursive-monitor new-monitor
         H{ } clone >>children
         <promise> >>ready
     dup start-pump-thread

extra/io/unix/backend/backend.factor

@@ -32,7 +32,7 @@ M: input-task io-task-container drop reads>> ;
 
 M: output-task io-task-container drop writes>> ;
 
-: construct-mx ( class -- obj )
+: new-mx ( class -- obj )
     new
         H{ } clone >>reads
         H{ } clone >>writes ; inline

extra/io/unix/epoll/epoll.factor

@@ -13,7 +13,7 @@ TUPLE: epoll-mx < mx events ;
     256 ; inline
 
 : <epoll-mx> ( -- mx )
-    epoll-mx construct-mx
+    epoll-mx new-mx
     max-events epoll_create dup io-error over set-mx-fd
     max-events "epoll-event" <c-array> over set-epoll-mx-events ;
 

extra/io/unix/kqueue/kqueue.factor

@@ -16,7 +16,7 @@ TUPLE: kqueue-mx < mx events monitors ;
     256 ; inline
 
 : <kqueue-mx> ( -- mx )
-    kqueue-mx construct-mx
+    kqueue-mx new-mx
         H{ } clone >>monitors
         kqueue dup io-error >>fd
         max-events "kevent" <c-array> >>events ;
@@ -142,7 +142,7 @@ TUPLE: vnode-monitor < monitor fd ;
 
 : <vnode-monitor> ( path mailbox -- monitor )
     >r [ O_RDONLY 0 open dup io-error ] keep r>
-    vnode-monitor construct-monitor swap >>fd
+    vnode-monitor new-monitor swap >>fd
     [ dup kqueue-mx get register-monitor ] [ ] [ fd>> close ] cleanup ;
 
 M: vnode-monitor dispose

extra/io/unix/linux/monitors/monitors.factor

@@ -10,7 +10,7 @@ IN: io.unix.linux.monitors
 TUPLE: linux-monitor < monitor wd ;
 
 : <linux-monitor> ( wd path mailbox -- monitor )
-    linux-monitor construct-monitor
+    linux-monitor new-monitor
         swap >>wd ;
 
 SYMBOL: watches

extra/io/unix/macosx/macosx.factor

@@ -13,7 +13,7 @@ TUPLE: macosx-monitor < monitor handle ;
     ] curry each ;
 
 M:: macosx (monitor) ( path recursive? mailbox -- monitor )
-    path mailbox macosx-monitor construct-monitor
+    path mailbox macosx-monitor new-monitor
     dup [ enqueue-notifications ] curry
     path 1array 0 0 <event-stream> >>handle ;
 

extra/io/unix/select/select.factor

@@ -14,7 +14,7 @@ TUPLE: select-mx < mx read-fdset write-fdset ;
     little-endian? [ BIN: 11000 bitxor ] unless ; inline
 
 : <select-mx> ( -- mx )
-    select-mx construct-mx
+    select-mx new-mx
         FD_SETSIZE 8 * <bit-array> >>read-fdset
         FD_SETSIZE 8 * <bit-array> >>write-fdset ;
 

extra/io/windows/nt/monitors/monitors.factor

@@ -98,7 +98,7 @@ TUPLE: win32-monitor < monitor port ;
 
 M:: winnt (monitor) ( path recursive? mailbox -- monitor )
     [
-        path mailbox win32-monitor construct-monitor
+        path mailbox win32-monitor new-monitor
             path open-directory \ win32-monitor-port <buffered-port>
                 recursive? >>recursive
             >>port

extra/peg/ebnf/ebnf-tests.factor

@@ -295,3 +295,5 @@ main = Primary
 { V{ V{ V{ "x" "[" "i" "]" } "[" "j" "]" } "." "y" } } [
   "x[i][j].y" primary parse-result-ast
 ] unit-test
+
+'ebnf' compile must-infer

extra/peg/peg.factor

@@ -100,21 +100,21 @@ C: <head> peg-head
 : setup-growth ( h p -- )
   pos set dup involved-set>> clone >>eval-set drop ;
 
-:: (grow-lr) ( h p r m -- )
+: (grow-lr) ( h p r m -- )
-  h p setup-growth
+  >r >r [ setup-growth ] 2keep r> r>
-  r eval-rule
+  >r dup eval-rule r> swap
-  dup m stop-growth? [
+  dup pick stop-growth? [
-    drop
+    4drop drop
   ] [
-    m update-m
+    over update-m
-     h p r m (grow-lr)
+    (grow-lr)
   ] if ; inline
  
-:: grow-lr ( h p r m -- ast )
+: grow-lr ( h p r m -- ast )
-  h p heads get set-at
+  >r >r [ heads get set-at ] 2keep r> r>
-  h p r m (grow-lr) 
+  pick over >r >r (grow-lr) r> r>
-  p heads get delete-at
+  swap heads get delete-at
-  m pos>> pos set m ans>>
+  dup pos>> pos set ans>>
   ; inline
 
 :: (setup-lr) ( r l s -- )
@@ -240,8 +240,21 @@ GENERIC: (compile) ( parser -- quot )
     gensym tuck >>compiled 2dup parser-body 0 1 <effect> define-declared dupd "peg" set-word-prop
   ] if* ;
 
+SYMBOL: delayed
+
+: fixup-delayed ( -- )
+  #! Work through all delayed parsers and recompile their
+  #! words to have the correct bodies.
+  delayed get [
+    call compiled-parser 1quotation 0 1 <effect> define-declared
+  ] assoc-each ;
+
 : compile ( parser -- word )
-  [ compiled-parser ] with-compilation-unit ;
+  [
+    H{ } clone delayed [ 
+      compiled-parser fixup-delayed 
+    ] with-variable
+  ] with-compilation-unit ;
 
 : compiled-parse ( state word -- result )
   swap [ execute ] with-packrat ; inline 
@@ -451,7 +464,7 @@ M: delay-parser (compile) ( parser -- quot )
   #! For efficiency we memoize the quotation.
   #! This way it is run only once and the 
   #! parser constructed once at run time.
-  quot>> '[ @ compile ] { } { "word" } <effect> memoize-quot '[ @ execute ] ; 
+  quot>> gensym [ delayed get set-at ] keep 1quotation ; 
 
 TUPLE: box-parser quot ;
 

extra/project-euler/164/164.factor

@@ -0,0 +1,33 @@
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs kernel math math.ranges sequences ;
+
+IN: project-euler.164
+
+! http://projecteuler.net/index.php?section=problems&id=164
+
+! DESCRIPTION
+! -----------
+
+! How many 20 digit numbers n (without any leading zero) exist such
+! that no three consecutive digits of n have a sum greater than 9?
+
+! SOLUTION
+! --------
+
+<PRIVATE
+
+: next-keys ( key -- keys )
+    [ peek ] [ 10 swap sum - ] bi [ 2array ] with map ;
+
+: next-table ( assoc -- assoc )
+    H{ } clone swap
+    [ swap next-keys [ pick at+ ] with each ] assoc-each ;
+
+: init-table ( -- assoc )
+    9 [1,b] [ 1array 1 ] H{ } map>assoc ;
+
+PRIVATE>
+
+: euler164 ( -- n )
+    init-table 19 [ next-table ] times values sum ;

extra/sequences/lib/summary.txt

@@ -0,0 +1 @@
+Non-core sequence words

extra/sequences/next/summary.txt

@@ -0,0 +1 @@
+Iteration with access to next element

extra/serialize/serialize.factor

@@ -246,7 +246,7 @@ SYMBOL: deserialized
     (deserialize) <wrapper> ;
 
 :: (deserialize-seq) ( exemplar quot -- seq )
-    deserialize-cell exemplar new
+    deserialize-cell exemplar new-sequence
     [ intern-object ]
     [ dup [ drop quot call ] change-each ] bi ; inline
 

extra/state-parser/state-parser.factor

@@ -97,7 +97,7 @@ SYMBOL: prolog-data
     #! advance spot to after the substring.
     [ [
         dup slip swap dup [ get-char , ] unless
-    ] skip-until ] "" make nip ;
+    ] skip-until ] "" make nip ; inline
 
 : rest ( -- string )
     [ f ] take-until ;

extra/trees/splay/summary.txt

@@ -1 +1 @@
-Splay Trees
+Splay trees

extra/update/update.factor

@@ -0,0 +1,62 @@
+
+USING: kernel system sequences io.files io.launcher bootstrap.image
+       builder.util builder.release.branch ;
+
+IN: update
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: run-command ( cmd -- ) to-strings try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: git-pull-clean ( -- )
+  image parent-directory
+    [
+      { "git" "pull" "git://factorcode.org/git/factor.git" branch-name }
+      run-command
+    ]
+  with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: remote-clean-image ( -- url )
+  "http://factorcode.org/images/clean/" my-boot-image-name append ;
+
+: download-clean-image ( -- ) { "wget" remote-clean-image } run-command ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-clean ( -- ) { gnu-make "clean" } run-command ;
+: make       ( -- ) { gnu-make         } run-command ;
+: boot       ( -- ) { "./factor" { "-i=" my-boot-image-name } } run-command ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: rebuild ( -- )
+  image parent-directory
+    [
+      download-clean-image
+      make-clean
+      make
+      boot
+    ]
+  with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: update ( -- )
+  image parent-directory
+    [
+      git-id
+      git-pull-clean
+      git-id
+      = not
+        [ rebuild ]
+      when
+    ]
+  with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: update

extra/webapps/todo/edit-todo.xml

@@ -0,0 +1,26 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:title>Edit Item</t:title>
+
+	<t:form action="edit">
+		<t:edit component="id" />
+
+		<table>
+			<tr><th class="field-label">Summary:    </th><td><t:edit component="summary"     /></td></tr>
+			<tr><th class="field-label">Priority:   </th><td><t:edit component="priority"    /></td></tr>
+			<tr><th class="field-label big-field-label">Description:</th><td><t:edit component="description" /></td></tr>
+		</table>
+
+		<input type="SUBMIT" value="Done" />
+	</t:form>
+
+	<t:a href="view" query="id">View</t:a>
+	|
+	<t:form action="delete" class="inline">
+		<t:edit component="id" />
+		<button type="submit" class="link-button link">Delete</button>
+	</t:form>
+
+</t:chloe>

extra/webapps/todo/page.xml

@@ -0,0 +1,45 @@
+<?xml version='1.0' ?>
+
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+	"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+
+<html xmlns="http://www.w3.org/1999/xhtml">
+
+	<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+		<head>
+			<t:write-title />
+
+			<t:style>
+				body, button {
+					font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
+					color:#444;
+				}
+
+				a, .link {
+					color: #222;
+					border-bottom:1px dotted #666;
+					text-decoration:none;
+				}
+				
+				a:hover, .link:hover {
+					border-bottom:1px solid #66a;
+				}
+
+				.error { color: #a00; }
+				
+				.field-label {
+					text-align: right;
+				}
+			</t:style>
+
+			<t:write-style />
+		</head>
+
+		<body>
+			<t:call-next-template />
+		</body>
+
+	</t:chloe>
+
+</html>