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

core/assocs/assocs-tests.factor

@@ -104,3 +104,17 @@ unit-test
         2drop
     ] { } make
 ] unit-test
+
+[
+    H{
+        { "bangers" "mash" }
+        { "fries" "onion rings" }
+    }
+] [
+    { "bangers" "fries" } H{
+        { "fish" "chips" }
+        { "bangers" "mash" }
+        { "fries" "onion rings" }
+        { "nachos" "cheese" }
+    } extract-keys
+] unit-test

core/assocs/assocs.factor

@@ -150,6 +150,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
 : map>assoc ( seq quot exemplar -- assoc )
     >r [ 2array ] compose { } map-as r> assoc-like ; inline
 
+: extract-keys ( seq assoc -- subassoc )
+    [ [ dupd at ] curry ] keep map>assoc ;
+
 M: assoc >alist [ 2array ] { } assoc>map ;
 
 : value-at ( value assoc -- key/f )

core/classes/classes-tests.factor

@@ -160,3 +160,12 @@ TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
 [ t ] [ 3 number instance? ] unit-test
 [ f ] [ 3 null instance? ] unit-test
 [ t ] [ "hi" \ hi-tag instance? ] unit-test
+
+! Regression
+GENERIC: method-forget-test
+TUPLE: method-forget-class ;
+M: method-forget-class method-forget-test ;
+
+[ f ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test
+[ ] [ [ \ method-forget-class forget ] with-compilation-unit ] unit-test
+[ t ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test

core/classes/tuple/tuple-tests.factor

@@ -4,7 +4,7 @@ namespaces quotations sequences.private classes continuations
 generic.standard effects classes.tuple classes.tuple.private
 arrays vectors strings compiler.units accessors classes.algebra
 calendar prettyprint io.streams.string splitting inspector
-columns math.order ;
+columns math.order classes.private ;
 IN: classes.tuple.tests
 
 TUPLE: rect x y w h ;
@@ -543,6 +543,7 @@ TUPLE: another-forget-accessors-test ;
 ! Missing error check
 [ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
 
+! Class forget messyness
 TUPLE: subclass-forget-test ;
 
 TUPLE: subclass-forget-test-1 < subclass-forget-test ;
@@ -551,6 +552,14 @@ TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ;
 
 [ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval ] unit-test
 
+[ H{ { subclass-forget-test-2 subclass-forget-test-2 } } ]
+[ subclass-forget-test-2 class-usages ]
+unit-test
+
+[ H{ { subclass-forget-test-3 subclass-forget-test-3 } } ]
+[ subclass-forget-test-3 class-usages ]
+unit-test
+
 [ f ] [ subclass-forget-test-1 tuple-class? ] unit-test
 [ f ] [ subclass-forget-test-2 tuple-class? ] unit-test
 [ subclass-forget-test-3 new ] must-fail

core/classes/tuple/tuple.factor

@@ -226,12 +226,6 @@ M: tuple-class reset-class
         } reset-props
     ] bi ;
 
-: reset-tuple-class ( class -- )
-    [ [ reset-class ] [ update-map- ] bi ] each-subclass ;
-
-M: tuple-class forget*
-    [ reset-tuple-class ] [ call-next-method ] bi ;
-
 M: tuple-class rank-class drop 0 ;
 
 M: tuple clone

core/combinators/combinators-docs.factor

@@ -10,8 +10,10 @@ ARTICLE: "combinators-quot" "Quotation construction utilities"
 { $subsection alist>quot } ;
 
 ARTICLE: "combinators" "Additional combinators"
-"The " { $vocab-link "combinators" } " vocabulary provides generalizations of certain combinators from the " { $vocab-link "kernel" } " vocabulary."
+"The " { $vocab-link "combinators" } " vocabulary provides a few useful combinators."
 $nl
+"A looping combinator:"
+{ $subsection while }
 "Generalization of " { $link bi } " and " { $link tri } ":"
 { $subsection cleave }
 "Generalization of " { $link bi* } " and " { $link tri* } ":"

core/combinators/combinators.factor

@@ -95,10 +95,10 @@ M: hashtable hashcode*
 
 : (distribute-buckets) ( buckets pair keys -- )
     dup t eq? [
-        drop [ swap push-new ] curry each
+        drop [ swap adjoin ] curry each
     ] [
         [
-            >r 2dup r> hashcode pick length rem rot nth push-new
+            >r 2dup r> hashcode pick length rem rot nth adjoin
         ] each 2drop
     ] if ;
 

core/compiler/units/units.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel continuations assocs namespaces sequences words
-vocabs definitions hashtables init ;
+vocabs definitions hashtables init sets ;
 IN: compiler.units
 
 SYMBOL: old-definitions
@@ -14,7 +14,7 @@ TUPLE: redefine-error def ;
     { { "Continue" t } } throw-restarts drop ;
 
 : add-once ( key assoc -- )
-    2dup key? [ over redefine-error ] when dupd set-at ;
+    2dup key? [ over redefine-error ] when conjoin ;
 
 : (remember-definition) ( definition loc assoc -- )
     >r over set-where r> add-once ;
@@ -83,7 +83,14 @@ SYMBOL: update-tuples-hook
     call-recompile-hook
     call-update-tuples-hook
     dup [ drop compiled-crossref? ] assoc-contains? modify-code-heap
-    updated-definitions notify-definition-observers ;
+     ;
+
+: with-nested-compilation-unit ( quot -- )
+    [
+        H{ } clone changed-definitions set
+        H{ } clone outdated-tuples set
+        [ finish-compilation-unit ] [ ] cleanup
+    ] with-scope ; inline
 
 : with-compilation-unit ( quot -- )
     [
@@ -92,8 +99,11 @@ SYMBOL: update-tuples-hook
         H{ } clone outdated-tuples set
         <definitions> new-definitions set
         <definitions> old-definitions set
-        [ finish-compilation-unit ]
+        [
-        [ ] cleanup
+            finish-compilation-unit
+            updated-definitions
+            notify-definition-observers
+        ] [ ] cleanup
     ] with-scope ; inline
 
 : compile-call ( quot -- )

core/dlists/dlists-docs.factor

@@ -1,4 +1,4 @@
-USING: help.markup help.syntax kernel quotations ;
+USING: help.markup help.syntax kernel quotations dlists.private ;
 IN: dlists
 
 ARTICLE: "dlists" "Doubly-linked lists"
@@ -51,38 +51,52 @@ HELP: dlist-empty?
 HELP: push-front
 { $values { "obj" "an object" } { "dlist" dlist } }
 { $description "Push the object onto the front of the " { $link dlist } "." } 
-{ $notes "This operation is O(1)." }
+{ $notes "This operation is O(1)." } ;
-{ $see-also push-back pop-front pop-front* pop-back pop-back* } ;
+
+HELP: push-front*
+{ $values { "obj" "an object" } { "dlist" dlist } { "dlist-node" dlist-node } }
+{ $description "Push the object onto the front of the " { $link dlist } " and return the newly created " { $snippet "dlist-node" } "." } 
+{ $notes "This operation is O(1)." } ;
 
 HELP: push-back
 { $values { "obj" "an object" } { "dlist" dlist } }
 { $description "Push the object onto the back of the " { $link dlist } "." } 
-{ $notes "This operation is O(1)." }
+{ $notes "This operation is O(1)." } ;
-{ $see-also push-front pop-front pop-front* pop-back pop-back* } ;
+
+HELP: push-back*
+{ $values { "obj" "an object" } { "dlist" dlist } { "dlist-node" dlist-node } }
+{ $description "Push the object onto the back of the " { $link dlist } " and return the newly created " { $snippet "dlist-node" } "." } 
+{ $notes "This operation is O(1)." } ;
+
+HELP: peek-front
+{ $values { "dlist" dlist } { "obj" "an object" } }
+{ $description "Returns the object at the front of the " { $link dlist } "." } ;
 
 HELP: pop-front
 { $values { "dlist" dlist } { "obj" "an object" } }
 { $description "Pop the object off the front of the " { $link dlist } " and return the object." }
-{ $notes "This operation is O(1)." }
+{ $notes "This operation is O(1)." } ;
-{ $see-also push-front push-back pop-front* pop-back pop-back* } ;
 
 HELP: pop-front*
 { $values { "dlist" dlist } }
 { $description "Pop the object off the front of the " { $link dlist } "." }
-{ $notes "This operation is O(1)." }
+{ $notes "This operation is O(1)." } ;
-{ $see-also push-front push-back pop-front pop-back pop-back* } ;
+
+HELP: peek-back
+{ $values { "dlist" dlist } { "obj" "an object" } }
+{ $description "Returns the object at the back of the " { $link dlist } "." } ;
 
 HELP: pop-back
 { $values { "dlist" dlist } { "obj" "an object" } }
 { $description "Pop the object off the back of the " { $link dlist } " and return the object." }
-{ $notes "This operation is O(1)." }
+{ $notes "This operation is O(1)." } ;
-{ $see-also push-front push-back pop-front pop-front* pop-back* } ;
 
 HELP: pop-back*
 { $values { "dlist" dlist } }
 { $description "Pop the object off the back of the " { $link dlist } "." }
-{ $notes "This operation is O(1)." }
+{ $notes "This operation is O(1)." } ;
-{ $see-also push-front push-back pop-front pop-front* pop-back } ;
+
+{ push-front push-front* push-back push-back* peek-front pop-front pop-front* peek-back pop-back pop-back* } related-words
 
 HELP: dlist-find
 { $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }

core/dlists/dlists-tests.factor

@@ -1,6 +1,6 @@
 USING: dlists dlists.private kernel tools.test random assocs
 sets sequences namespaces sorting debugger io prettyprint
-math ;
+math accessors classes ;
 IN: dlists.tests
 
 [ t ] [ <dlist> dlist-empty? ] unit-test
@@ -65,20 +65,17 @@ IN: dlists.tests
 : assert-same-elements
     [ prune natural-sort ] bi@ assert= ;
 
-: dlist-push-all [ push-front ] curry each ;
-
 : dlist-delete-all [ dlist-delete drop ] curry each ;
 
 : dlist>array [ [ , ] dlist-slurp ] { } make ;
 
 [ ] [
     5 [ drop 30 random >fixnum ] map prune
-    6 [ drop 30 random >fixnum ] map prune 2dup nl . . nl
+    6 [ drop 30 random >fixnum ] map prune [
-    [
         <dlist>
-        [ dlist-push-all ] keep
+        [ push-all-front ]
-        [ dlist-delete-all ] keep
+        [ dlist-delete-all ]
-        dlist>array
+        [ dlist>array ] tri
     ] 2keep swap diff assert-same-elements
 ] unit-test
 
@@ -95,3 +92,13 @@ IN: dlists.tests
 
 [ 1 ] [ "d" get dlist-length ] unit-test
 [ 1 ] [ "d" get dlist>array length ] unit-test
+
+[ t ] [ <dlist> 4 over push-back 5 over push-back [ obj>> 4 = ] dlist-find-node drop class dlist-node = ] unit-test
+[ t ] [ <dlist> 4 over push-back 5 over push-back [ obj>> 5 = ] dlist-find-node drop class dlist-node = ] unit-test
+[ t ] [ <dlist> 4 over push-back 5 over push-back* [ = ] curry dlist-find-node drop class dlist-node = ] unit-test
+[ ] [ <dlist> 4 over push-back 5 over push-back [ drop ] dlist-each ] unit-test
+
+[ <dlist> peek-front ] must-fail
+[ <dlist> peek-back ] must-fail
+[ <dlist> pop-front ] [ empty-dlist? ] must-fail-with
+[ <dlist> pop-back ] [ empty-dlist? ] must-fail-with

core/dlists/dlists.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007, 2008 Mackenzie Straight, Doug Coleman,
 ! Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel math sequences accessors ;
+USING: combinators kernel math sequences accessors inspector ;
 IN: dlists
 
 TUPLE: dlist front back length ;
@@ -47,7 +47,7 @@ C: <dlist-node> dlist-node
 
 : (dlist-find-node) ( dlist-node quot -- node/f ? )
     over [
-        [ >r obj>> r> call ] 2keep rot
+        [ call ] 2keep rot
         [ drop t ] [ >r next>> r> (dlist-find-node) ] if
     ] [ 2drop f f ] if ; inline
 
@@ -55,7 +55,7 @@ C: <dlist-node> dlist-node
     >r front>> r> (dlist-find-node) ; inline
 
 : dlist-each-node ( dlist quot -- )
-    [ t ] compose dlist-find-node 2drop ; inline
+    [ f ] compose dlist-find-node 2drop ; inline
 
 PRIVATE>
 
@@ -84,11 +84,17 @@ PRIVATE>
 : push-all-back ( seq dlist -- )
     [ push-back ] curry each ;
 
+ERROR: empty-dlist ;
+
+M: empty-dlist summary ( dlist -- )
+    drop "Emtpy dlist" ;
+
 : peek-front ( dlist -- obj )
-    front>> obj>> ;
+    front>> [ empty-dlist ] unless* obj>> ;
 
 : pop-front ( dlist -- obj )
-    dup front>> [
+    dup front>> [ empty-dlist ] unless*
+    [
         dup next>>
         f rot (>>next)
         f over set-prev-when
@@ -96,13 +102,15 @@ PRIVATE>
     ] 2keep obj>>
     swap [ normalize-back ] keep dec-length ;
 
-: pop-front* ( dlist -- ) pop-front drop ;
+: pop-front* ( dlist -- )
+    pop-front drop ;
 
 : peek-back ( dlist -- obj )
-    back>> obj>> ;
+    back>> [ empty-dlist ] unless* obj>> ;
 
 : pop-back ( dlist -- obj )
-    dup back>> [
+    dup back>> [ empty-dlist ] unless*
+    [
         dup prev>>
         f rot (>>prev)
         f over set-next-when
@@ -110,9 +118,11 @@ PRIVATE>
     ] 2keep obj>>
     swap [ normalize-front ] keep dec-length ;
 
-: pop-back* ( dlist -- ) pop-back drop ;
+: pop-back* ( dlist -- )
+    pop-back drop ;
 
 : dlist-find ( dlist quot -- obj/f ? )
+    [ obj>> ] prepose
     dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
 
 : dlist-contains? ( dlist quot -- ? )
@@ -141,6 +151,7 @@ PRIVATE>
     ] if ; inline
 
 : delete-node-if ( dlist quot -- obj/f )
+    [ obj>> ] prepose
     delete-node-if* drop ; inline
 
 : dlist-delete ( obj dlist -- obj/f )

core/generator/fixup/fixup-docs.factor

@@ -1,12 +1,12 @@
 USING: help.syntax help.markup generator.fixup math kernel
-words strings alien ;
+words strings alien byte-array ;
 
 HELP: frame-required
 { $values { "n" "a non-negative integer" } }
 { $description "Notify the code generator that the currently compiling code block needs a stack frame with room for at least " { $snippet "n" } " parameters." } ;
 
 HELP: (rel-fixup)
-{ $values { "arg" integer } { "class" "a relocation class" } { "type" "a relocation type" } { "offset" integer } { "pair" "a pair of integers" } }
+{ $values { "arg" integer } { "class" "a relocation class" } { "type" "a relocation type" } { "offset" integer } { "byte-array" byte-array } }
 { $description "Creates a relocation instruction for the VM's runtime compiled code linker." } ;
 
 HELP: add-literal

core/generator/fixup/fixup.factor

@@ -1,9 +1,10 @@
 ! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generic assocs hashtables
+USING: arrays byte-arrays generic assocs hashtables io.binary
 kernel kernel.private math namespaces sequences words
-quotations strings alien.strings layouts system combinators
+quotations strings alien.accessors alien.strings layouts system
-math.bitfields words.private cpu.architecture math.order ;
+combinators math.bitfields words.private cpu.architecture
+math.order accessors growable ;
 IN: generator.fixup
 
 : no-stack-frame -1 ; inline
@@ -77,38 +78,35 @@ TUPLE: label-fixup label class ;
 : label-fixup ( label class -- ) \ label-fixup boa , ;
 
 M: label-fixup fixup*
-    dup label-fixup-class rc-absolute?
+    dup class>> rc-absolute?
     [ "Absolute labels not supported" throw ] when
-    dup label-fixup-label swap label-fixup-class
+    dup label>> swap class>> compiled-offset 4 - rot
-    compiled-offset 4 - rot 3array label-table get push ;
+    3array label-table get push ;
 
 TUPLE: rel-fixup arg class type ;
 
 : rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
 
-: (rel-fixup) ( arg class type offset -- pair )
+: push-4 ( value vector -- )
-    pick rc-absolute-cell = cell 4 ? -
+    [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying ] tri
-    >r { 0 8 16 } bitfield r>
+    swap set-alien-unsigned-4 ;
-    2array ;
 
 M: rel-fixup fixup*
-    dup rel-fixup-arg
+    [ [ arg>> ] [ class>> ] [ type>> ] tri { 0 8 16 } bitfield ]
-    over rel-fixup-class
+    [ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
-    rot rel-fixup-type
+    [ relocation-table get push-4 ] bi@ ;
-    compiled-offset (rel-fixup)
-    relocation-table get push-all ;
 
 M: frame-required fixup* drop ;
 
 M: integer fixup* , ;
 
-: push-new* ( obj table -- n )
+: adjoin* ( obj table -- n )
     2dup swap [ eq? ] curry find drop
     [ 2nip ] [ dup length >r push r> ] if* ;
 
 SYMBOL: literal-table
 
-: add-literal ( obj -- n ) literal-table get push-new* ;
+: add-literal ( obj -- n ) literal-table get adjoin* ;
 
 : add-dlsym-literals ( symbol dll -- )
     >r string>symbol r> 2array literal-table get push-all ;
@@ -134,7 +132,7 @@ SYMBOL: literal-table
     0 swap rt-here rel-fixup ;
 
 : init-fixup ( -- )
-    V{ } clone relocation-table set
+    BV{ } clone relocation-table set
     V{ } clone label-table set ;
 
 : resolve-labels ( labels -- labels' )
@@ -150,6 +148,6 @@ SYMBOL: literal-table
         dup stack-frame-size swap [ fixup* ] each drop
 
         literal-table get >array
-        relocation-table get >array
+        relocation-table get >byte-array
         label-table get resolve-labels
     ] { } make ;

core/generic/generic.factor

@@ -147,12 +147,16 @@ M: method-body forget*
     [ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
 
 M: class forget* ( class -- )
-    {
+    [
+        class-usages [
+            drop
             [ forget-methods ]
             [ update-map- ]
             [ reset-class ]
-        [ call-next-method ]
+            tri
-    } cleave ;
+        ] assoc-each
+    ]
+    [ call-next-method ] bi ;
 
 M: assoc update-methods ( assoc -- )
     implementors* [ make-generic ] each ;

core/generic/standard/engines/predicate/predicate.factor

@@ -22,8 +22,7 @@ C: <predicate-dispatch-engine> predicate-dispatch-engine
     } cond ;
 
 : sort-methods ( assoc -- assoc' )
-    [ keys sort-classes ]
+    >alist [ keys sort-classes ] keep extract-keys ;
-    [ [ dupd at ] curry ] bi { } map>assoc ;
 
 M: predicate-dispatch-engine engine>quot
     methods>> clone

core/inference/class/class.factor

@@ -152,16 +152,16 @@ M: pair apply-constraint
 M: pair constraint-satisfied?
     first constraint-satisfied? ;
 
-: extract-keys ( seq assoc -- newassoc )
+: valid-keys ( seq assoc -- newassoc )
-    [ dupd at ] curry H{ } map>assoc [ nip ] assoc-filter f assoc-like ;
+    extract-keys [ nip ] assoc-filter f assoc-like ;
 
 : annotate-node ( node -- )
     #! Annotate the node with the currently-inferred set of
     #! value classes.
     dup node-values {
-        [ value-intervals get extract-keys >>intervals ]
+        [ value-intervals get valid-keys >>intervals ]
-        [ value-classes   get extract-keys >>classes   ]
+        [ value-classes   get valid-keys >>classes   ]
-        [ value-literals  get extract-keys >>literals  ]
+        [ value-literals  get valid-keys >>literals  ]
         [ 2drop ]
     } cleave ;
 
@@ -330,7 +330,7 @@ M: #return infer-classes-around
             [ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri
             classes= not [
                 fixed-point? off
-                [ in-d>> value-classes get extract-keys ] keep
+                [ in-d>> value-classes get valid-keys ] keep
                 set-node-classes
             ] [ drop ] if
         ] [ call-next-method ] if

core/io/binary/binary-docs.factor

@@ -1,8 +1,8 @@
-USING: help.markup help.syntax io math ;
+USING: help.markup help.syntax io math byte-arrays ;
 IN: io.binary
 
 ARTICLE: "stream-binary" "Working with binary data"
-"The core stream words read and write strings. Packed binary integers can be read and written by converting to and from sequences of bytes. Floating point numbers can be read and written by converting them into a their bitwise integer representation (" { $link "floats" } ")."
+"Stream words on binary streams only read and write byte arrays. Packed binary integers can be read and written by converting to and from sequences of bytes. Floating point numbers can be read and written by converting them into a their bitwise integer representation (" { $link "floats" } ")."
 $nl
 "There are two ways to order the bytes making up an integer; " { $emphasis "little endian" } " byte order outputs the least significant byte first, and the most significant byte last, whereas " { $emphasis "big endian" } " is the other way around."
 $nl
@@ -42,11 +42,11 @@ HELP: nth-byte
 { $description "Outputs the " { $snippet "n" } "th least significant byte of the sign-extended 2's complement representation of " { $snippet "x" } "." } ;
 
 HELP: >le
-{ $values { "x" integer } { "n" "a non-negative integer" } { "str" "a string" } }
+{ $values { "x" integer } { "n" "a non-negative integer" } { "byte-array" byte-array } }
 { $description "Converts an integer " { $snippet "x" } " into a string of " { $snippet "n" } " bytes in little endian order. Truncation will occur if the integer is not in the range " { $snippet "[-2^(8n),2^(8n))" } "." } ;
 
 HELP: >be
-{ $values { "x" integer } { "n" "a non-negative integer" } { "str" "a string" } }
+{ $values { "x" integer } { "n" "a non-negative integer" } { "byte-array" byte-array } }
 { $description "Converts an integer " { $snippet "x" } " into a string of " { $snippet "n" } " bytes in big endian order. Truncation will occur if the integer is not in the range " { $snippet "[-2^(8n),2^(8n))" } "." } ;
 
 HELP: mask-byte

core/io/binary/binary.factor

@@ -10,8 +10,8 @@ IN: io.binary
 
 : nth-byte ( x n -- b ) -8 * shift mask-byte ; inline
 
-: >le ( x n -- str ) [ nth-byte ] with B{ } map-as ;
+: >le ( x n -- byte-array ) [ nth-byte ] with B{ } map-as ;
-: >be ( x n -- str ) >le dup reverse-here ;
+: >be ( x n -- byte-array ) >le dup reverse-here ;
 
 : d>w/w ( d -- w1 w2 )
     dup HEX: ffffffff bitand

core/kernel/kernel-docs.factor

@@ -193,10 +193,7 @@ ARTICLE: "implementing-combinators" "Implementing combinators"
     ": keep ( x quot -- x )"
     "    over >r call r> ; inline"
 }
-"Word inlining is documented in " { $link "declarations" } "."
+"Word inlining is documented in " { $link "declarations" } "." ;
-$nl
-"A looping combinator:"
-{ $subsection while } ;
 
 ARTICLE: "booleans" "Booleans"
 "In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value."

core/parser/parser-tests.factor

@@ -460,3 +460,30 @@ must-fail-with
     "change-combination" "parser.tests" lookup
     "methods" word-prop assoc-size
 ] unit-test
+
+[ ] [
+    2 [
+        "IN: parser.tests DEFER: twice-fails FORGET: twice-fails MIXIN: twice-fails"
+        <string-reader> "twice-fails-test" parse-stream drop
+    ] times
+] unit-test
+
+[ [ ] ] [
+    "IN: parser.tests : staging-problem-test-1 1 ; : staging-problem-test-2 staging-problem-test-1 ;"
+    <string-reader> "staging-problem-test" parse-stream
+] unit-test
+
+[ t ] [ "staging-problem-test-1" "parser.tests" lookup >boolean ] unit-test
+
+[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
+
+[ [ ] ] [
+    "IN: parser.tests << : staging-problem-test-1 1 ; >> : staging-problem-test-2 staging-problem-test-1 ;"
+    <string-reader> "staging-problem-test" parse-stream
+] unit-test
+
+[ t ] [ "staging-problem-test-1" "parser.tests" lookup >boolean ] unit-test
+
+[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
+
+[ "DEFER: blah" eval ] [ error>> no-current-vocab? ] must-fail-with

core/parser/parser.factor

@@ -236,7 +236,7 @@ PREDICATE: unexpected-eof < unexpected
 ERROR: no-current-vocab ;
 
 M: no-current-vocab summary ( obj -- )
-    drop "Current vocabulary is f, use IN:" ;
+    drop "Not in a vocabulary; IN: form required" ;
 
 : current-vocab ( -- str )
     in get [ no-current-vocab ] unless* ;
@@ -357,10 +357,9 @@ M: staging-violation summary
     "A parsing word cannot be used in the same file it is defined in." ;
 
 : execute-parsing ( word -- )
-    new-definitions get [
+    [ changed-definitions get key? [ staging-violation ] when ]
-        dupd first key? [ staging-violation ] when
+    [ execute ]
-    ] when*
+    bi ;
-    execute ;
 
 : parse-step ( accum end -- accum ? )
     scan-word {

core/prettyprint/prettyprint-tests.factor

@@ -342,3 +342,5 @@ INTERSECTION: intersection-see-test sequence number ;
 
 [ ] [ \ compose see ] unit-test
 [ ] [ \ curry see ] unit-test
+
+[ "POSTPONE: [" ] [ \ [ unparse ] unit-test

core/sequences/sequences-docs.factor

@@ -191,7 +191,6 @@ $nl
 "Other destructive words:"
 { $subsection move }
 { $subsection exchange }
-{ $subsection push-new }
 { $subsection copy }
 { $subsection replace-slice }
 { $see-also set-nth push pop "sequences-stacks" } ;
@@ -624,22 +623,7 @@ HELP: replace-slice
 { $errors "Throws an error if " { $snippet "new" } " contains elements whose types are not permissible in " { $snippet "seq" } "." }
 { $side-effects "seq" } ;
 
-HELP: push-new
+{ push prefix suffix } related-words
-{ $values { "elt" object } { "seq" "a resizable mutable sequence" } }
-{ $description "Removes all elements equal to " { $snippet "elt" } ", and adds " { $snippet "elt" } " at the end of the sequence." }
-{ $examples
-    { $example
-        "USING: namespaces prettyprint sequences ;"
-        "V{ \"beans\" \"salsa\" \"cheese\" } \"v\" set"
-        "\"nachos\" \"v\" get push-new"
-        "\"salsa\" \"v\" get push-new"
-        "\"v\" get ."
-        "V{ \"beans\" \"cheese\" \"nachos\" \"salsa\" }"
-    }
-}
-{ $side-effects "seq" } ;
-
-{ push push-new prefix suffix } related-words
 
 HELP: suffix
 { $values { "seq" sequence } { "elt" object } { "newseq" sequence } }

core/sequences/sequences-tests.factor

@@ -215,12 +215,6 @@ unit-test
     3 V{ 1 2 3 4 5 6 } clone [ delete-nth ] keep
 ] unit-test
 
-[ V{ 1 2 3 } ]
-[ 3 V{ 1 2 } clone [ push-new ] keep ] unit-test
-
-[ V{ 1 2 3 } ]
-[ 3 V{ 1 3 2 } clone [ push-new ] keep ] unit-test
-
 ! erg's random tester found this one
 [ SBUF" 12341234" ] [
     9 <sbuf> dup "1234" swap push-all dup dup swap push-all

core/sequences/sequences.factor

@@ -499,8 +499,6 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
 
 : delete ( elt seq -- ) 0 0 rot (delete) nip set-length drop ;
 
-: push-new ( elt seq -- ) [ delete ] 2keep push ;
-
 : prefix ( seq elt -- newseq )
     over >r over length 1+ r> [
         [ 0 swap set-nth-unsafe ] keep
@@ -680,7 +678,7 @@ PRIVATE>
 : unclip ( seq -- rest first )
     [ rest ] [ first ] bi ;
 
-: unclip-last ( seq -- butfirst last )
+: unclip-last ( seq -- butlast last )
     [ but-last ] [ peek ] bi ;
 
 : unclip-slice ( seq -- rest first )

core/sets/sets-docs.factor

@@ -16,10 +16,28 @@ $nl
 { $subsection set= }
 "A word used to implement the above:"
 { $subsection unique }
+"Adding elements to sets:"
+{ $subsection adjoin }
+{ $subsection conjoin }
 { $see-also member? memq? contains? all? "assocs-sets" } ;
 
 ABOUT: "sets"
 
+HELP: adjoin
+{ $values { "elt" object } { "seq" "a resizable mutable sequence" } }
+{ $description "Removes all elements equal to " { $snippet "elt" } ", and adds " { $snippet "elt" } " at the end of the sequence." }
+{ $examples
+    { $example
+        "USING: namespaces prettyprint sets ;"
+        "V{ \"beans\" \"salsa\" \"cheese\" } \"v\" set"
+        "\"nachos\" \"v\" get adjoin"
+        "\"salsa\" \"v\" get adjoin"
+        "\"v\" get ."
+        "V{ \"beans\" \"cheese\" \"nachos\" \"salsa\" }"
+    }
+}
+{ $side-effects "seq" } ;
+
 HELP: unique
 { $values { "seq" "a sequence" } { "assoc" "an assoc" } }
 { $description "Outputs a new assoc where the keys and values are equal." }

core/sets/sets-tests.factor

@@ -15,3 +15,9 @@ IN: sets.tests
 
 [ V{ } ] [ { } { } union ] unit-test
 [ V{ 1 2 3 4 } ] [ { 1 2 3 } { 2 3 4 } union ] unit-test
+
+[ V{ 1 2 3 } ]
+[ 3 V{ 1 2 } clone [ adjoin ] keep ] unit-test
+
+[ V{ 1 2 3 } ]
+[ 3 V{ 1 3 2 } clone [ adjoin ] keep ] unit-test

core/sets/sets.factor

@@ -3,10 +3,14 @@
 USING: assocs hashtables kernel sequences vectors ;
 IN: sets
 
+: adjoin ( elt seq -- ) [ delete ] [ push ] 2bi ;
+
+: conjoin ( elt assoc -- ) dupd set-at ;
+
 : (prune) ( elt hash vec -- )
-    3dup drop key?
+    3dup drop key? [ 3drop ] [
-    [ [ drop dupd set-at ] [ nip push ] [ ] 3tri ] unless
+        [ drop conjoin ] [ nip push ] 3bi
-    3drop ; inline
+    ] if ; inline
 
 : prune ( seq -- newseq )
     [ ] [ length <hashtable> ] [ length <vector> ] tri
@@ -16,7 +20,7 @@ IN: sets
     [ dup ] H{ } map>assoc ;
 
 : (all-unique?) ( elt hash -- ? )
-    2dup key? [ 2drop f ] [ dupd set-at t ] if ;
+    2dup key? [ 2drop f ] [ conjoin t ] if ;
 
 : all-unique? ( seq -- ? )
     dup length <hashtable> [ (all-unique?) ] curry all? ;

core/splitting/splitting-docs.factor

@@ -1,6 +1,25 @@
 USING: help.markup help.syntax sequences strings ;
 IN: splitting
 
+ARTICLE: "groups-clumps" "Groups and clumps"
+"A virtual sequence for splitting a sequence into disjoint, fixed-length subsequences:"
+{ $subsection groups }
+{ $subsection <groups> }
+{ $subsection <sliced-groups> }
+"A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:"
+{ $subsection clumps }
+{ $subsection <clumps> }
+{ $subsection <sliced-clumps> }
+"The difference can be summarized as the following:"
+{ $list
+    { "With groups, the subsequences form the original sequence when concatenated:"
+        { $unchecked-example "dup n groups concat sequence= ." "t" }
+    }
+    { "With clumps, collecting the first element of each subsequence but the last one, together with the last subseqence, yields the original sequence:"
+        { $unchecked-example "dup n clumps unclip-last >r [ first ] map r> append sequence= ." "t" }
+    }
+} ;
+
 ARTICLE: "sequences-split" "Splitting sequences"
 "Splitting sequences at occurrences of subsequences:"
 { $subsection ?head }
@@ -9,14 +28,9 @@ ARTICLE: "sequences-split" "Splitting sequences"
 { $subsection ?tail-slice }
 { $subsection split1 }
 { $subsection split }
-"Grouping elements:"
-{ $subsection group }
-"A virtual sequence for grouping elements:"
-{ $subsection groups }
-{ $subsection <groups> }
-{ $subsection <sliced-groups> }
 "Splitting a string into lines:"
-{ $subsection string-lines } ;
+{ $subsection string-lines }
+{ $subsection "groups-clumps" } ;
 
 ABOUT: "sequences-split"
 
@@ -36,19 +50,22 @@ HELP: split
 { $examples { $example "USING: prettyprint splitting ;" "\"hello world-how are you?\" \" -\" split ." "{ \"hello\" \"world\" \"how\" \"are\" \"you?\" }" } } ;
 
 HELP: groups
-{ $class-description "Instances are virtual sequences whose elements are fixed-length subsequences or slices of an underlying sequence. Groups are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
+{ $class-description "Instances are virtual sequences whose elements are disjoint fixed-length subsequences of an underlying sequence. Groups are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
 $nl
 "New groups are created by calling " { $link <groups> } " and " { $link <sliced-groups> } "." }
 { $see-also group } ;
 
 HELP: group
 { $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
-{ $description "Splits the sequence into groups of " { $snippet "n" } " elements and collects the groups into a new array." }
+{ $description "Splits the sequence into disjoint groups of " { $snippet "n" } " elements and collects the groups into a new array." }
-{ $notes "If the sequence length is not a multiple of " { $snippet "n" } ", the final subsequence in the list will be shorter than " { $snippet "n" } " elements." } ;
+{ $notes "If the sequence length is not a multiple of " { $snippet "n" } ", the final subsequence in the list will be shorter than " { $snippet "n" } " elements." }
+{ $examples
+    { $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 group ." "{ { 3 1 } { 3 3 } { 7 } }" }
+} ;
 
 HELP: <groups>
 { $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } }
-{ $description "Outputs a virtual sequence whose elements are subsequences consisting of groups of " { $snippet "n" } " elements from the underlying sequence." }
+{ $description "Outputs a virtual sequence whose elements are disjoint subsequences of " { $snippet "n" } " elements from the underlying sequence." }
 { $examples
     { $example
         "USING: arrays kernel prettyprint sequences splitting ;"
@@ -58,7 +75,7 @@ HELP: <groups>
 
 HELP: <sliced-groups>
 { $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } }
-{ $description "Outputs a virtual sequence whose elements are slices consisting of groups of " { $snippet "n" } " elements from the underlying sequence." }
+{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
 { $examples
     { $example
         "USING: arrays kernel prettyprint sequences splitting ;"
@@ -68,7 +85,46 @@ HELP: <sliced-groups>
     }
 } ;
 
-{ group <groups> <sliced-groups> } related-words
+HELP: clumps
+{ $class-description "Instances are virtual sequences whose elements are overlapping fixed-length subsequences o an underlying sequence. Clumps are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
+$nl
+"New clumps are created by calling " { $link <clumps> } " and " { $link <sliced-clumps> } "." } ;
+
+HELP: clump
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
+{ $description "Splits the sequence into overlapping clumps of " { $snippet "n" } " elements and collects the clumps into a new array." }
+{ $errors "Throws an error if " { $snippet "n" } " is smaller than the length of the sequence." }
+{ $examples
+    { $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 clump ." "{ { 3 1 } { 1 3 } { 3 3 } { 3 7 } }" }
+} ;
+
+HELP: <clumps>
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
+{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
+{ $examples
+    "Running averages:"
+    { $example
+        "USING: splitting sequences math prettyprint kernel ;"
+        "IN: scratchpad"
+        ": share-price"
+        "    { 13/50 51/100 13/50 1/10 4/5 17/20 33/50 3/25 19/100 3/100 } ;"
+        ""
+        "share-price 4 <clumps> [ [ sum ] [ length ] bi / ] map ."
+        "{ 113/400 167/400 201/400 241/400 243/400 91/200 1/4 }"
+    }
+} ;
+
+HELP: <sliced-clumps>
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
+{ $description "Outputs a virtual sequence whose elements are overlapping slices of " { $snippet "n" } " elements from the underlying sequence." } ;
+
+{ clumps groups } related-words
+
+{ clump group } related-words
+
+{ <clumps> <groups> } related-words
+
+{ <sliced-clumps> <sliced-groups> } related-words
 
 HELP: ?head
 { $values { "seq" "a sequence" } { "begin" "a sequence" } { "newseq" "a new sequence" } { "?" "a boolean" } }

core/splitting/splitting.factor

@@ -44,7 +44,7 @@ M: sliced-groups nth group@ <slice> ;
 
 TUPLE: clumps < abstract-groups ;
 
-: <clumps> ( seq n -- groups )
+: <clumps> ( seq n -- clumps )
     clumps construct-groups ; inline
 
 M: clumps length
@@ -58,7 +58,7 @@ M: clumps group@
 
 TUPLE: sliced-clumps < groups ;
 
-: <sliced-clumps> ( seq n -- groups )
+: <sliced-clumps> ( seq n -- clumps )
     sliced-clumps construct-groups ; inline
 
 M: sliced-clumps nth group@ <slice> ;

core/syntax/syntax.factor

@@ -100,8 +100,8 @@ IN: bootstrap.syntax
     ] define-syntax
 
     "DEFER:" [
-        scan in get create
+        scan current-vocab create
-        dup old-definitions get first delete-at
+        dup old-definitions get [ delete-at ] with each
         set-word
     ] define-syntax
 
@@ -189,8 +189,9 @@ IN: bootstrap.syntax
     "MAIN:" [ scan-word in get vocab set-vocab-main ] define-syntax
 
     "<<" [
-        [ \ >> parse-until >quotation ] with-compilation-unit
+        [
-        call
+            \ >> parse-until >quotation
+        ] with-nested-compilation-unit call
     ] define-syntax
 
     "call-next-method" [

core/words/words.factor

@@ -175,7 +175,9 @@ PRIVATE>
 : define-symbol ( word -- )
     dup [ ] curry define-inline ;
 
-: reset-word ( word -- )
+GENERIC: reset-word ( word -- )
+
+M: word reset-word
     {
         "unannotated-def"
         "parsing" "inline" "foldable" "flushable"

extra/assocs/lib/lib.factor

@@ -1,5 +1,5 @@
 USING: arrays assocs kernel vectors sequences namespaces
-random math.parser ;
+random math.parser math fry ;
 IN: assocs.lib
 
 : ref-at ( table key -- value ) swap at ;
@@ -40,3 +40,8 @@ IN: assocs.lib
 
 : set-at-unique ( value assoc -- key )
     dup generate-key [ swap set-at ] keep ;
+
+: histogram ( assoc quot -- assoc' )
+    H{ } clone [
+        swap [ change-at ] 2curry assoc-each
+    ] keep ;

extra/calendar/format/format-tests.factor

@@ -50,3 +50,15 @@ IN: calendar.format.tests
     "Sun May 04 07:00:00 2008 GMT" cookie-string>timestamp
     timestamp>string
 ] unit-test
+
+[
+    T{ timestamp f
+        2008
+        5
+        26
+        0
+        37
+        42.12345
+        T{ duration f 0 0 0 -5 0 0 }
+    }
+] [ "2008-05-26T00:37:42.12345-05:00" rfc3339>timestamp ] unit-test

extra/calendar/format/format.factor

@@ -1,4 +1,4 @@
-USING: math math.order math.parser kernel sequences io
+USING: math math.order math.parser math.functions kernel sequences io
 accessors arrays io.streams.string splitting
 combinators accessors debugger
 calendar calendar.format.macros ;
@@ -151,11 +151,15 @@ M: timestamp year. ( timestamp -- )
 : read-hms ( -- h m s )
     read-00 ":" expect read-00 ":" expect read-00 ;
 
+: read-rfc3339-seconds ( s -- s' ch )
+    "+-Z" read-until >r
+    [ string>number ] [ length 10 swap ^ ] bi / + r> ;
+
 : (rfc3339>timestamp) ( -- timestamp )
     read-ymd
     "Tt" expect
     read-hms
-    read1 { { CHAR: . [ read-000 1000 / + read1 ] } [ ] } case
+    read1 { { CHAR: . [ read-rfc3339-seconds ] } [ ] } case
     read-rfc3339-gmt-offset
     <timestamp> ;
 

extra/circular/circular-tests.factor

@@ -27,3 +27,15 @@ circular strings ;
 ! This no longer fails
 ! [ "test" <circular> 5 swap nth ] must-fail
 ! [ "foo" <circular> CHAR: b 3 rot set-nth ] must-fail
+
+[ { } ] [ 3 <growing-circular> >array ] unit-test
+[ { 1 2 } ] [
+    3 <growing-circular>
+    [ 1 swap push-growing-circular ] keep
+    [ 2 swap push-growing-circular ] keep >array
+] unit-test
+[ { 3 4 5 } ] [
+    3 <growing-circular> dup { 1 2 3 4 5 } [
+        swap push-growing-circular
+    ] with each >array
+] unit-test

extra/circular/circular.factor

@@ -19,10 +19,6 @@ M: circular length seq>> length ;
 
 M: circular virtual@ circular-wrap seq>> ;
 
-M: circular nth virtual@ nth ;
-
-M: circular set-nth virtual@ set-nth ;
-
 M: circular virtual-seq seq>> ;
 
 : change-circular-start ( n circular -- )
@@ -36,3 +32,20 @@ M: circular virtual-seq seq>> ;
     0 <string> <circular> ;
 
 INSTANCE: circular virtual-sequence
+
+TUPLE: growing-circular < circular length ;
+
+M: growing-circular length length>> ;
+
+: full? ( circular -- ? )
+    [ length ] [ seq>> length ] bi = ;
+
+: set-peek ( elt seq -- )
+    [ length 1- ] keep set-nth ;
+
+: push-growing-circular ( elt circular -- )
+    dup full? [ push-circular ]
+    [ [ 1+ ] change-length set-peek ] if ;
+
+: <growing-circular> ( capacity -- growing-circular )
+    { } new-sequence 0 0 growing-circular boa ;

extra/combinators/lib/lib-docs.factor

@@ -23,7 +23,7 @@ HELP: ndip
   { $example "USING: combinators.lib kernel prettyprint ;" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" }
   { $example "USING: combinators.lib kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip .s" "2\n3" }
 }
-{ $see-also dip dipd } ;
+{ $see-also dip 2dip } ;
 
 HELP: nslip
 { $values { "n" number } }

extra/combinators/lib/lib-tests.factor

@@ -5,9 +5,6 @@ IN: combinators.lib.tests
 [ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test
 [ t ] [ [ 10 random ] [ even? ] generate even? ] unit-test
 
-{ 6 2 } [ 1 2 [ 5 + ] dip ] unit-test
-{ 6 2 1 } [ 1 2 1 [ 5 + ] dipd ] unit-test
-
 [ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer
 { 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test
 [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer

extra/combinators/lib/lib.factor

@@ -38,8 +38,6 @@ MACRO: napply ( n -- )
 
 : 3apply ( obj obj obj quot -- ) 3 napply ; inline
 
-: dipd ( x y quot -- y ) 2 ndip ; inline
-
 : 2with ( param1 param2 obj quot -- obj curry )
     with with ; inline
 
@@ -79,8 +77,21 @@ MACRO: <--&& ( quots -- )
     [ [ 2dup ] prepend [ not ] append [ f ] ] t short-circuit
     [ 2nip ] append ;
 
+! or
+
 MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ;
 
+MACRO: 0|| ( quots -- ? ) [ [ t ] ] f short-circuit ;
+
+MACRO: 1|| ( quots -- ? )
+  [ [ dup ] prepend [ t ] ] f short-circuit [ nip ] append ;
+
+MACRO: 2|| ( quots -- ? )
+  [ [ 2dup ] prepend [ t ] ] f short-circuit [ 2nip ] append ;
+
+MACRO: 3|| ( quots -- ? )
+  [ [ 2dup ] prepend [ t ] ] f short-circuit [ 2nip ] append ;
+
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! ifte
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

extra/db/db.factor

@@ -127,7 +127,7 @@ M: nonthrowable execute-statement* ( statement type -- )
 : query-map ( statement quot -- seq )
     accumulator >r query-each r> { } like ; inline
 
-: with-db ( db seq quot -- )
+: with-db ( seq class quot -- )
     >r make-db db-open db r>
     [ db get swap [ drop ] prepose with-disposal ] curry with-variable ;
     inline

extra/db/pools/pools.factor

@@ -6,16 +6,16 @@ IN: db.pools
 
 TUPLE: db-pool < pool db params ;
 
-: <db-pool> ( db params -- pool )
+: <db-pool> ( params db -- pool )
     db-pool <pool>
-        swap >>params
+        swap >>db
-        swap >>db ;
+        swap >>params ;
 
 : with-db-pool ( db params quot -- )
     >r <db-pool> r> with-pool ; inline
 
 M: db-pool make-connection ( pool -- )
-    [ db>> ] [ params>> ] bi make-db db-open ;
+    [ params>> ] [ db>> ] bi make-db db-open ;
 
 : with-pooled-db ( pool quot -- )
     [ db swap with-variable ] curry with-pooled-connection ; inline

extra/db/tuples/tuples-tests.factor

@@ -414,6 +414,25 @@ TUPLE: does-not-persist ;
     [ class \ not-persistent = ] must-fail-with
 ] test-postgresql
 
+
+TUPLE: suparclass a ;
+
+suparclass f {
+    { "id" "ID" +db-assigned-id+ }
+    { "a" "A" INTEGER }
+} define-persistent
+
+TUPLE: subbclass < suparclass b ;
+
+subbclass "SUBCLASS" {
+    { "b" "B" TEXT }
+} define-persistent
+
+: test-db-inheritance ( -- )
+    [ ] [ subbclass ensure-table ] unit-test ;
+
+[ test-db-inheritance ] test-sqlite
+
 ! Don't comment these out. These words must infer
 \ bind-tuple must-infer
 \ insert-tuple must-infer

extra/db/tuples/tuples.factor

@@ -19,7 +19,7 @@ ERROR: not-persistent ;
     "db-table" word-prop [ not-persistent ] unless* ;
 
 : db-columns ( class -- obj )
-    "db-columns" word-prop ;
+    superclasses [ "db-columns" word-prop ] map concat ;
 
 : db-relations ( class -- obj )
     "db-relations" word-prop ;

extra/dns/cache/cache.factor

@@ -47,15 +47,9 @@ TUPLE: entry time data ;
 
 SYMBOL: NX
 
-: cache-nx ( query ttl -- )
+: cache-nx ( query ttl -- ) ttl->time NX entry boa table-add ;
-  ttl->time NX entry boa
-  table-add ;
 
-: nx? ( obj -- ? )
+: nx? ( obj -- ? ) dup entry? [ data>> NX = ] [ drop f ] if ;
-  dup entry?
-    [ data>> NX = ]
-    [ drop f ]
-  if ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -72,32 +66,29 @@ SYMBOL: NX
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: entry-expired? ( entry -- ? ) time>> time->ttl 0 <= ;
+: expired? ( entry -- ? ) time>> time->ttl 0 <= ;
 
-: cache-get ( query -- result )
+: cache-get* ( query -- rrs/NX/f )
   dup table-get               ! query result
     {
-      {
+      { [ dup f = ]      [ 2drop f ]          } ! not in the cache
-        [ dup f = ] ! not in the cache
+      { [ dup expired? ] [ drop table-rem f ] } ! here but expired
-        [ 2drop f ]
+      { [ dup nx?  ]     [ 2drop NX ]         } ! negative result cached
-      }
+      { [ t ]            [ query+entry->rrs ] } ! good to go
-      {
-        [ dup entry-expired? ] ! here but expired
-        [ drop table-rem f   ]
-      }
-      {
-        [ dup nx?  ] ! negative result has been cached
-        [ 2drop NX ]
-      }
-      {
-        [ t ]
-        [ query+entry->rrs ]
-      }
     }
   cond ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+ERROR: name-error name ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cache-get ( query -- rrs/f )
+  dup cache-get* dup NX = [ drop name>> name-error ] [ nip ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 : rr->entry ( rr -- entry )
   [ ttl>> ttl->time ] [ rdata>> {1} >vector ] bi entry boa ;
 
@@ -114,22 +105,10 @@ SYMBOL: NX
 : cache-add ( query rr -- )
   over table-get          ! query rr entry
     {
-      {
+      { [ dup f = ]      [ drop rr->entry table-add ] }
-        [ dup f = ] ! not in the cache
+      { [ dup nx? ]      [ drop over table-rem rr->entry table-add ] }
-        [ drop rr->entry table-add ]
+      { [ dup expired? ] [ drop rr->entry table-add ] }
-      }
+      { [ t ]            [ rot drop add-rr-to-entry ] }
-      {
-        [ dup nx? ]
-        [ drop over table-rem rr->entry table-add ]
-      }
-      {
-        [ dup entry-expired? ]
-        [ drop rr->entry table-add ]
-      }
-      {
-        [ t ]
-        [ rot drop add-rr-to-entry ]
-      }
     }
   cond ;
 
@@ -140,3 +119,31 @@ SYMBOL: NX
 : cache-add-rr ( rr -- ) [ rr->query ] [ ] bi cache-add ;
 
 : cache-add-rrs ( rrs -- ) [ cache-add-rr ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! cache-name-error
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: message-soa ( message -- rr/soa )
+  authority-section>> [ type>> SOA = ] filter 1st ;
+
+: cache-name-error ( message -- message )
+  dup
+    [ message-query ] [ message-soa ttl>> ] bi
+  cache-nx ;
+
+: cache-message-records ( message -- message )
+  dup
+    {
+      [ answer-section>>     cache-add-rrs ]
+      [ authority-section>>  cache-add-rrs ]
+      [ additional-section>> cache-add-rrs ]
+    }
+  cleave ;
+
+: cache-message ( message -- message )
+  dup rcode>> NAME-ERROR = [ cache-name-error ] when
+  cache-message-records ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+

extra/dns/dns.factor

@@ -38,7 +38,7 @@ TUPLE: message
 ! TYPE
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT ;
+SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT AAAA ;
 
 : type-table ( -- table )
   {
@@ -58,6 +58,7 @@ SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT ;
     { MINFO 14 }
     { MX    15 }
     { TXT   16 }
+    { AAAA  28 }
   } ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -126,6 +127,8 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
 
 : ip->ba ( ip -- ba ) "." split [ string>number ] map >byte-array ;
 
+: ipv6->ba ( ip -- ba ) ":" split [ 16 base> ] map [ 2 >be ] map concat ;
+
 : label->ba ( label -- ba ) [ >byte-array ] [ length ] bi prefix ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -330,6 +333,13 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
 
 : get-ip ( ba i -- ip ) dup 4 + subseq >array [ number>string ] map "." join ;
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-ipv6 ( ba i -- ip )
+  dup 16 + subseq 2 group [ be> 16 >base ] map ":" join ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 : get-rdata ( ba i type -- rdata )
     {
       { CNAME [ get-name ] }
@@ -338,6 +348,7 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
       { MX    [ get-mx   ] }
       { SOA   [ get-soa  ] }
       { A     [ get-ip   ] }
+      { AAAA  [ get-ipv6 ] }
     }
   case ;
 
@@ -459,4 +470,9 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
 
 : ask ( message -- message ) dns-server ask-server ;
 
-: <query-message> ( query -- message ) <message> swap {1} >>question-section ;
+: query->message ( query -- message ) <message> swap {1} >>question-section ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: message-query ( message -- query ) question-section>> 1st ;
+

extra/dns/recursive/recursive.factor

@@ -0,0 +1,185 @@
+
+USING: kernel continuations
+       combinators
+       sequences
+       math
+       random
+       unicode.case
+       accessors symbols
+       combinators.lib combinators.cleave
+       newfx
+       dns dns.cache ;
+
+IN: dns.recursive
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: root-dns-servers ( -- servers )
+  {
+    "192.5.5.241"
+    "192.112.36.4"
+    "128.63.2.53"
+    "192.36.148.17"
+    "192.58.128.30"
+    "193.0.14.129"
+    "199.7.83.42"
+    "202.12.27.33"
+    "198.41.0.4"
+  } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: {name-type-class} ( obj -- seq )
+  [ name>> >lower ] [ type>> ] [ class>> ] tri {3} ;
+
+: rr=query? ( rr query -- ? ) [ {name-type-class} ] bi@ = ;
+
+: rr-filter ( rrs query -- rrs ) [ rr=query? ] curry filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: answer-hits ( message -- rrs )
+  [ answer-section>> ] [ message-query ] bi rr-filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: name-hits ( message -- rrs )
+  [ answer-section>> ] [ message-query clone A >>type ] bi rr-filter ;
+
+: cname-hits ( message -- rrs )
+  [ answer-section>> ] [ message-query clone CNAME >>type ] bi rr-filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: authority-hits ( message -- rrs )
+  authority-section>> [ type>> NS = ] filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOLS: ANSWERED NO-NAME-SERVERS UNCLASSIFIED ;
+
+: classify-message ( message -- symbol )
+    {
+      { [ dup rcode>> NAME-ERROR     = ] [ drop NAME-ERROR      ] }
+      { [ dup rcode>> SERVER-FAILURE = ] [ drop SERVER-FAILURE  ] }
+      { [ dup answer-hits empty? not   ] [ drop ANSWERED        ] }
+      { [ dup cname-hits  empty? not   ] [ drop CNAME           ] }
+      { [ dup authority-hits empty?    ] [ drop NO-NAME-SERVERS ] }
+      { [ t                            ] [ drop UNCLASSIFIED    ] }
+    }
+  cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: name->ip
+
+! : name->ip/f ( name -- ip/f ) [ name->ip ] [ drop f ] recover ;
+
+! : extract-ns-ips ( message -- ips )
+!   authority-hits [ rdata>> name->ip/f ] map [ ] filter ;
+
+: extract-ns-ips ( message -- ips )
+  authority-hits [ rdata>> name->ip ] map [ ] filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: (recursive-query) ( query servers -- message )
+  dup random                                 ! query servers server
+  pick query->message 0 >>rd                 ! query servers server message
+  over ask-server                            ! query servers server message
+  cache-message                              ! query servers server message
+  dup classify-message                       ! query servers server message sym
+    {
+      { NAME-ERROR      [ -roll 3drop ] }
+      { ANSWERED        [ -roll 3drop ] }
+      { CNAME           [ -roll 3drop ] }
+      { NO-NAME-SERVERS [ -roll 3drop ] }
+      {
+        SERVER-FAILURE
+        [
+          -roll                              ! message query servers server
+          remove                             ! message query servers
+          dup empty?
+            [ 2drop ]
+            [ rot drop (recursive-query) ]
+          if
+        ]
+      }
+      [                                      ! query servers server message sym
+        drop nip nip                         ! query message
+        extract-ns-ips                       ! query ips
+        (recursive-query)
+      ]
+    }
+  case ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cdr-name ( name -- name ) dup CHAR: . index 1+ tail ;
+
+: cache-get-ns ( name -- seq/f ) NS IN query boa cache-get ;
+
+: name->servers ( name -- servers )
+    {
+      { [ dup "" = ]         [ drop root-dns-servers ] }
+      { [ dup cache-get-ns ] [ cache-get-ns [ rdata>> name->ip ] map ] }
+      { [ t ]                [ cdr-name name->servers ] }
+    }
+  cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: recursive-query ( query -- message )
+  dup name>> name->servers (recursive-query) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: canonical/cache ( name -- name )
+  dup CNAME IN query boa cache-get dup [ nip 1st rdata>> ] [ drop ] if ;
+
+: name->ip/cache ( name -- ip/f )
+  canonical/cache
+  A IN query boa cache-get dup [ random rdata>> ] [ ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:  name-hits? ( message -- message ? ) dup  name-hits empty? not ;
+: cname-hits? ( message -- message ? ) dup cname-hits empty? not ;
+
+! : name->ip/server ( name -- ip-or-f )
+!   A IN query boa root-dns-servers recursive-query ! message
+!     {
+!       { [ name-hits? ]  [ name-hits  random rdata>>          ] }
+!       { [ cname-hits? ] [ cname-hits random rdata>> name->ip ] }
+!       { [ t           ] [ drop f ] }
+!     }
+!   cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: name->ip/server ( name -- ip-or-f )
+  A IN query boa recursive-query ! message
+    {
+      { [ name-hits? ]  [ name-hits  random rdata>>          ] }
+      { [ cname-hits? ] [ cname-hits random rdata>> name->ip ] }
+      { [ t           ] [ drop f ] }
+    }
+  cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! : name->ip ( name -- ip )
+!   { [ name->ip/cache ] [ name->ip/server ] [ name-error ] } 1|| ;
+
+: name->ip ( name -- ip )
+  dup name->ip/cache dup
+    [ nip ]
+    [
+      drop dup name->ip/server dup
+        [ nip ]
+        [ drop name-error ]
+      if
+    ]
+  if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

extra/dns/resolver/resolver.factor

@@ -6,6 +6,8 @@ IN: dns.resolver
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+! Need to cache records even in the case of name error
+
 : cache-message ( message -- message )
   dup dup rcode>> NAME-ERROR =
     [
@@ -60,7 +62,7 @@ IN: dns.resolver
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : canonical/server ( name -- name )
-  dup CNAME IN query boa <query-message> ask* answer-section>>
+  dup CNAME IN query boa query->message ask* answer-section>>
   [ type>> CNAME = ] filter dup empty? not
     [ nip 1st rdata>> ]
     [ drop ]
@@ -68,7 +70,7 @@ IN: dns.resolver
 
 : name->ip/server ( name -- ip )
   canonical/server
-  dup A IN query boa <query-message> ask* answer-section>>
+  dup A IN query boa query->message ask* answer-section>>
   [ type>> A = ] filter dup empty? not
     [ nip random rdata>> ]
     [ 2drop f ]

extra/farkup/farkup-tests.factor

@@ -16,10 +16,18 @@ IN: farkup.tests
 [ "<p>**</p>" ] [ "\\**" convert-farkup ] unit-test
 
 [ "" ] [ "\n\n" convert-farkup ] unit-test
+[ "" ] [ "\r\n\r\n" convert-farkup ] unit-test
+[ "" ] [ "\r\r\r\r" convert-farkup ] unit-test
+[ "\n" ] [ "\r\r\r" convert-farkup ] unit-test
 [ "\n" ] [ "\n\n\n" convert-farkup ] unit-test
 [ "<p>foo</p><p>bar</p>" ] [ "foo\n\nbar" convert-farkup ] unit-test
+[ "<p>foo</p><p>bar</p>" ] [ "foo\r\n\r\nbar" convert-farkup ] unit-test
+[ "<p>foo</p><p>bar</p>" ] [ "foo\r\rbar" convert-farkup ] unit-test
+[ "<p>foo</p><p>bar</p>" ] [ "foo\r\r\nbar" convert-farkup ] unit-test
 
 [ "\n<p>bar\n</p>" ] [ "\nbar\n" convert-farkup ] unit-test
+[ "\n<p>bar\n</p>" ] [ "\rbar\r" convert-farkup ] unit-test
+[ "\n<p>bar\n</p>" ] [ "\r\nbar\r\n" convert-farkup ] unit-test
 
 [ "<p>foo</p>\n<p>bar</p>" ] [ "foo\n\n\nbar" convert-farkup ] unit-test
 
@@ -28,17 +36,17 @@ IN: farkup.tests
 [ "<p>|a</p>" ]
 [ "|a" convert-farkup ] unit-test
 
-[ "<p>|a|</p>" ]
+[ "<table><tr><td>a</td></tr></table>" ]
 [ "|a|" convert-farkup ] unit-test
 
 [ "<table><tr><td>a</td><td>b</td></tr></table>" ]
-[ "a|b" convert-farkup ] unit-test
+[ "|a|b|" convert-farkup ] unit-test
 
-[ "<table><tr><td>a</td><td>b</td></tr></table>\n<table><tr><td>c</td><td>d</td></tr></table>" ]
+[ "<table><tr><td>a</td><td>b</td></tr><tr><td>c</td><td>d</td></tr></table>" ]
-[ "a|b\nc|d" convert-farkup ] unit-test
+[ "|a|b|\n|c|d|" convert-farkup ] unit-test
 
-[ "<table><tr><td>a</td><td>b</td></tr></table>\n<table><tr><td>c</td><td>d</td></tr></table>\n" ]
+[ "<table><tr><td>a</td><td>b</td></tr><tr><td>c</td><td>d</td></tr></table>" ]
-[ "a|b\nc|d\n" convert-farkup ] unit-test
+[ "|a|b|\n|c|d|\n" convert-farkup ] unit-test
 
 [ "<p><strong>foo</strong>\n</p><h1>aheading</h1>\n<p>adfasd</p>" ]
 [ "*foo*\n=aheading=\nadfasd" convert-farkup ] unit-test
@@ -54,12 +62,23 @@ IN: farkup.tests
 [ "<p>=</p><h2>foo</h2>" ] [ "===foo==" convert-farkup ] unit-test
 [ "<h1>foo</h1><p>=</p>" ] [ "=foo==" convert-farkup ] unit-test
 
-[ "<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>" ]
+[ "<pre><span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span>\n</pre>" ]
 [ "[c{int main()}]" convert-farkup ] unit-test
 
 [ "<p><img src=\"lol.jpg\"/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
 [ "<p><img src=\"lol.jpg\" alt=\"teh lol\"/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
-[ "<p><a href=\"lol.com\"></a></p>" ] [ "[[lol.com]]" convert-farkup ] unit-test
+[ "<p><a href=\"lol.com\">lol.com</a></p>" ] [ "[[lol.com]]" convert-farkup ] unit-test
 [ "<p><a href=\"lol.com\">haha</a></p>" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test
 
 [ ] [ "[{}]" convert-farkup drop ] unit-test
+
+[
+    "<p>Feature comparison:\n<table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table></p>"
+] [ "Feature comparison:\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
+
+[
+    "<p>Feature comparison:\n\n<table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table></p>"
+] [ "Feature comparison:\n\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
+
+[ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test
+[ "<ul><li>a-b</li></ul>" ] [ "-a-b" convert-farkup ] unit-test

extra/farkup/farkup.factor

@@ -2,21 +2,24 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays io io.styles kernel memoize namespaces peg
 sequences strings html.elements xml.entities xmode.code2html
-splitting io.streams.string html peg.parsers html.elements
+splitting io.streams.string peg.parsers
 sequences.deep unicode.categories ;
 IN: farkup
 
+SYMBOL: relative-link-prefix
+SYMBOL: link-no-follow?
+
 <PRIVATE
 
 : delimiters ( -- string )
-    "*_^~%[-=|\\\n" ; inline
+    "*_^~%[-=|\\\r\n" ; inline
 
 MEMO: text ( -- parser )
     [ delimiters member? not ] satisfy repeat1
     [ >string escape-string ] action ;
 
 MEMO: delimiter ( -- parser )
-    [ dup delimiters member? swap "\n=" member? not and ] satisfy
+    [ dup delimiters member? swap "\r\n=" member? not and ] satisfy
     [ 1string ] action ;
 
 : surround-with-foo ( string tag -- seq )
@@ -37,8 +40,11 @@ MEMO: emphasis ( -- parser ) "_" "em" delimited ;
 MEMO: superscript ( -- parser ) "^" "sup" delimited ;
 MEMO: subscript ( -- parser ) "~" "sub" delimited ;
 MEMO: inline-code ( -- parser ) "%" "code" delimited ;
-MEMO: nl ( -- parser ) "\n" token ;
+MEMO: nl ( -- parser )
-MEMO: 2nl ( -- parser ) "\n\n" token hide ;
+    "\r\n" token [ drop "\n" ] action
+    "\r" token [ drop "\n" ] action
+    "\n" token 3choice ;
+MEMO: 2nl ( -- parser ) nl hide nl hide 2seq ;
 MEMO: h1 ( -- parser ) "=" "h1" delimited ;
 MEMO: h2 ( -- parser ) "==" "h2" delimited ;
 MEMO: h3 ( -- parser ) "===" "h3" delimited ;
@@ -56,25 +62,30 @@ MEMO: eq ( -- parser )
 : render-code ( string mode -- string' )
     >r string-lines r>
     [
-        [
+        <pre>
-            H{ { wrap-margin f } } [
             htmlize-lines
-            ] with-nesting
+        </pre>
-        ] with-html-stream
     ] with-string-writer ;
 
 : check-url ( href -- href' )
     CHAR: : over member? [
         dup { "http://" "https://" "ftp://" } [ head? ] with contains?
         [ drop "/" ] unless
-    ] when ;
+    ] [
+        relative-link-prefix get prepend
+    ] if ;
 
 : escape-link ( href text -- href-esc text-esc )
     >r check-url escape-quoted-string r> escape-string ;
 
 : make-link ( href text -- seq )
     escape-link
-    [ "<a href=\"" , >r , r> "\">" , [ , ] when* "</a>" , ] { } make ;
+    [
+        "<a" ,
+        " href=\"" , >r , r>
+        link-no-follow? get [ " nofollow=\"true\"" , ] when
+        "\">" , , "</a>" ,
+    ] { } make ;
 
 : make-image-link ( href alt -- seq )
     escape-link
@@ -99,7 +110,7 @@ MEMO: simple-link ( -- parser )
         "[[" token hide ,
         [ "|]" member? not ] satisfy repeat1 ,
         "]]" token hide ,
-    ] seq* [ first f make-link ] action ;
+    ] seq* [ first dup make-link ] action ;
 
 MEMO: labelled-link ( -- parser )
     [
@@ -110,28 +121,32 @@ MEMO: labelled-link ( -- parser )
         "]]" token hide ,
     ] seq* [ first2 make-link ] action ;
 
-MEMO: link ( -- parser ) [ image-link , simple-link , labelled-link , ] choice* ;
+MEMO: link ( -- parser )
+    [ image-link , simple-link , labelled-link , ] choice* ;
 
 DEFER: line
 MEMO: list-item ( -- parser )
     [
-        "-" token hide , line ,
+        "-" token hide , ! text ,
+        [ "\r\n" member? not ] satisfy repeat1 [ >string escape-string ] action ,
     ] seq* [ "li" surround-with-foo ] action ;
 
 MEMO: list ( -- parser )
-    list-item "\n" token hide list-of
+    list-item nl hide list-of
     [ "ul" surround-with-foo ] action ;
 
 MEMO: table-column ( -- parser )
     text [ "td" surround-with-foo ] action ;
 
 MEMO: table-row ( -- parser )
-    [
+    "|" token hide
-        table-column "|" token hide list-of-many ,
+    table-column "|" token hide list-of
-    ] seq* [ "tr" surround-with-foo ] action ;
+    "|" token hide nl hide optional 4seq
+    [ "tr" surround-with-foo ] action ;
 
 MEMO: table ( -- parser )
-    table-row repeat1 [ "table" surround-with-foo ] action ;
+    table-row repeat1
+    [ "table" surround-with-foo ] action ;
 
 MEMO: code ( -- parser )
     [
@@ -144,6 +159,8 @@ MEMO: code ( -- parser )
 
 MEMO: line ( -- parser )
     [
+        nl table 2seq ,
+        nl list 2seq ,
         text , strong , emphasis , link ,
         superscript , subscript , inline-code ,
         escaped-char , delimiter , eq ,
@@ -151,8 +168,8 @@ MEMO: line ( -- parser )
 
 MEMO: paragraph ( -- parser )
     line
-    "\n" token over 2seq repeat0
+    nl over 2seq repeat0
-    "\n" token "\n" token ensure-not 2seq optional 3seq
+    nl nl ensure-not 2seq optional 3seq
     [
         dup [ dup string? not swap [ blank? ] all? or ] deep-all?
         [ "<p>" swap "</p>" 3array ] unless
@@ -163,7 +180,7 @@ PRIVATE>
 PEG: parse-farkup ( -- parser )
     [
         list , table , h1 , h2 , h3 , h4 , code , paragraph , 2nl , nl ,
-    ] choice* repeat0 "\n" token optional 2seq ;
+    ] choice* repeat0 nl optional 2seq ;
 
 : write-farkup ( parse-result  -- )
     [ dup string? [ write ] [ drop ] if ] deep-each ;

extra/fry/fry-tests.factor

@@ -52,3 +52,13 @@ sequences ;
 [ { 1 { 2 { 3 } } } ] [
     1 2 3 '[ , [ , [ , 1array ] call 2array ] call 2array ] call
 ] unit-test
+
+{ 1 1 } [ '[ [ [ , ] ] ] ] must-infer-as
+
+[ { { { 3 } } } ] [
+    3 '[ [ [ , 1array ] call 1array ] call 1array ] call
+] unit-test
+
+[ { { { 3 } } } ] [
+    3 '[ [ [ , 1array ] call 1array ] call 1array ] call
+] unit-test

extra/fry/fry.factor

@@ -46,15 +46,22 @@ DEFER: (shallow-fry)
         shallow-fry
     ] if* ;
 
+: fry-specifier? ( obj -- ? ) { , namespaces:, @ } member? ;
+
+: count-inputs ( quot -- n )
+    [
+        {
+            { [ dup callable? ] [ count-inputs ] }
+            { [ dup fry-specifier? ] [ drop 1 ] }
+            [ drop 0 ]
+        } cond
+    ] map sum ;
+
 : fry ( quot -- quot' )
     [
         [
             dup callable? [
-                [
+                [ count-inputs \ , <repetition> % ] [ fry % ] bi
-                    [ { , namespaces:, @ } member? ] filter length
-                    \ , <repetition> %
-                ]
-                [ fry % ] bi
             ] [ namespaces:, ] if
         ] each
     ] [ ] make deep-fry ;

extra/html/components/components-tests.factor

@@ -0,0 +1,180 @@
+IN: html.components.tests
+USING: tools.test kernel io.streams.string
+io.streams.null accessors inspector html.streams
+html.components namespaces ;
+
+[ ] [ blank-values ] unit-test
+
+[ ] [ 3 "hi" set-value ] unit-test
+
+[ 3 ] [ "hi" value ] unit-test
+
+TUPLE: color red green blue ;
+
+[ ] [ 1 2 3 color boa from-tuple ] unit-test
+
+[ 1 ] [ "red" value ] unit-test
+
+[ ] [ "jimmy" "red" set-value ] unit-test
+
+[ "123.5" ] [ 123.5 object>string ] unit-test
+
+[ "jimmy" ] [
+    [
+        "red" label render
+    ] with-string-writer
+] unit-test
+
+[ ] [ "<jimmy>" "red" set-value ] unit-test
+
+[ "&lt;jimmy&gt;" ] [
+    [
+        "red" label render
+    ] with-string-writer
+] unit-test
+
+[ "<input type='hidden' name='red' value='<jimmy>'/>" ] [
+    [
+        "red" hidden render
+    ] with-string-writer
+] unit-test
+
+[ ] [ "'jimmy'" "red" set-value ] unit-test
+
+[ "<input type='text' size='5' name='red' value='&apos;jimmy&apos;'/>" ] [
+    [
+        "red" <field> 5 >>size render
+    ] with-string-writer
+] unit-test
+
+[ "<input type='password' size='5' name='red' value=''/>" ] [
+    [
+        "red" <password> 5 >>size render
+    ] with-string-writer
+] unit-test
+
+[ ] [
+    [
+        "green" <textarea> render
+    ] with-null-writer
+] unit-test
+
+[ ] [
+    [
+        "green" <textarea> 25 >>rows 30 >>cols render
+    ] with-null-writer
+] unit-test
+
+[ ] [ blank-values ] unit-test
+
+[ ] [ "new york" "city1" set-value ] unit-test
+
+[ ] [ { "new york" "los angeles" "chicago" } "cities" set-value ] unit-test
+
+[ ] [
+    [
+        "city1"
+        <choice>
+            "cities" >>choices
+        render
+    ] with-null-writer
+] unit-test
+
+[ ] [ { "los angeles" "new york" } "city2" set-value ] unit-test
+
+[ ] [
+    [
+        "city2"
+        <choice>
+            "cities" >>choices
+            t >>multiple
+        render
+    ] with-null-writer
+] unit-test
+
+[ ] [
+    [
+        "city2"
+        <choice>
+            "cities" >>choices
+            t >>multiple
+            5 >>size
+        render
+    ] with-null-writer
+] unit-test
+
+[ ] [ blank-values ] unit-test
+
+[ ] [ t "delivery" set-value ] unit-test
+
+[ "<input type='checkbox' name='delivery' selected='true'>Delivery</input>" ] [
+    [
+        "delivery"
+        <checkbox>
+            "Delivery" >>label
+        render
+    ] with-string-writer
+] unit-test
+
+[ ] [ f "delivery" set-value ] unit-test
+
+[ "<input type='checkbox' name='delivery'>Delivery</input>" ] [
+    [
+        "delivery"
+        <checkbox>
+            "Delivery" >>label
+        render
+    ] with-string-writer
+] unit-test
+
+SINGLETON: link-test
+
+M: link-test link-title drop "<Link Title>" ;
+
+M: link-test link-href drop "http://www.apple.com/foo&bar" ;
+
+[ ] [ link-test "link" set-value ] unit-test
+
+[ "<a href='http://www.apple.com/foo&amp;bar'>&lt;Link Title&gt;</a>" ] [
+    [ "link" link render ] with-string-writer
+] unit-test
+
+[ ] [
+    "<html>arbitrary <b>markup</b> for the win!</html>" "html" set-value
+] unit-test
+
+[ "<html>arbitrary <b>markup</b> for the win!</html>" ] [
+    [ "html" html render ] with-string-writer
+] unit-test
+
+[ ] [ "int x = 4;" "code" set-value ] unit-test
+
+[ ] [ "java" "mode" set-value ] unit-test
+
+[ "<span class='KEYWORD3'>int</span> x <span class='OPERATOR'>=</span> <span class='DIGIT'>4</span>;\n" ] [
+    [ "code" <code> "mode" >>mode render ] with-string-writer
+] unit-test
+
+[ ] [ "-foo\n-bar" "farkup" set-value ] unit-test
+
+[ "<ul><li>foo</li><li>bar</li></ul>" ] [
+    [ "farkup" farkup render ] with-string-writer
+] unit-test
+
+[ ] [ { 1 2 3 } "object" set-value ] unit-test
+
+[ t ] [
+    [ "object" inspector render ] with-string-writer
+    [ "object" value [ describe ] with-html-stream ] with-string-writer
+    =
+] unit-test
+
+[ ] [ blank-values ] unit-test
+
+[ ] [
+    "factor" [
+        "concatenative" "model" set-value
+    ] nest-values
+] unit-test
+
+[ H{ { "factor" H{ { "model" "concatenative" } } } } ] [ values get ] unit-test

extra/html/components/components.factor

@@ -0,0 +1,224 @@
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel namespaces io math.parser assocs classes
+classes.tuple words arrays sequences sequences.lib splitting
+mirrors hashtables combinators continuations math strings
+fry locals calendar calendar.format xml.entities validators
+html.elements html.streams xmode.code2html farkup inspector
+lcs.diff2html ;
+IN: html.components
+
+SYMBOL: values
+
+: value values get at ;
+
+: set-value values get set-at ;
+
+: blank-values H{ } clone values set ;
+
+: prepare-value ( name object -- value name object )
+    [ [ value ] keep ] dip ; inline
+
+: from-assoc ( assoc -- ) values get swap update ;
+
+: from-tuple ( tuple -- ) <mirror> from-assoc ;
+
+: deposit-values ( destination names -- )
+    [ dup value ] H{ } map>assoc update ;
+
+: deposit-slots ( destination names -- )
+    [ <mirror> ] dip deposit-values ;
+
+: with-each-index ( seq quot -- )
+    '[
+        [
+            blank-values 1+ "index" set-value @
+        ] with-scope
+    ] each-index ; inline
+
+: with-each-value ( seq quot -- )
+    '[ "value" set-value @ ] with-each-index ; inline
+
+: with-each-assoc ( seq quot -- )
+    '[ from-assoc @ ] with-each-index ; inline
+
+: with-each-tuple ( seq quot -- )
+    '[ from-tuple @ ] with-each-index ; inline
+
+: with-assoc-values ( assoc quot -- )
+    '[ blank-values , from-assoc @ ] with-scope ; inline
+
+: with-tuple-values ( assoc quot -- )
+    '[ blank-values , from-tuple @ ] with-scope ; inline
+
+: nest-values ( name quot -- )
+    swap [
+        [
+            H{ } clone [ values set call ] keep
+        ] with-scope
+    ] dip set-value ; inline
+
+: nest-tuple ( name quot -- )
+    swap [
+        [
+            H{ } clone [ <mirror> values set call ] keep
+        ] with-scope
+    ] dip set-value ; inline
+
+: object>string ( object -- string )
+    {
+        { [ dup real? ] [ number>string ] }
+        { [ dup timestamp? ] [ timestamp>string ] }
+        { [ dup string? ] [ ] }
+        { [ dup word? ] [ word-name ] }
+        { [ dup not ] [ drop "" ] }
+    } cond ;
+
+GENERIC: render* ( value name render -- )
+
+: render ( name renderer -- )
+    over named-validation-messages get at [
+        [ value>> ] [ message>> ] bi
+        [ -rot render* ] dip
+        render-error
+    ] [
+        prepare-value render*
+    ] if* ;
+
+<PRIVATE
+
+: render-input ( value name type -- )
+    <input =type =name object>string =value input/> ;
+
+PRIVATE>
+
+SINGLETON: label
+
+M: label render* 2drop object>string escape-string write ;
+
+SINGLETON: hidden
+
+M: hidden render* drop "hidden" render-input ;
+
+: render-field ( value name size type -- )
+    <input
+        =type
+        [ object>string =size ] when*
+        =name
+        object>string =value
+    input/> ;
+
+TUPLE: field size ;
+
+: <field> ( -- field )
+    field new ;
+
+M: field render* size>> "text" render-field ;
+
+TUPLE: password size ;
+
+: <password> ( -- password )
+    password new ;
+
+M: password render*
+    #! Don't send passwords back to the user
+    [ drop "" ] 2dip size>> "password" render-field ;
+
+! Text areas
+TUPLE: textarea rows cols ;
+
+: <textarea> ( -- renderer )
+    textarea new ;
+
+M: textarea render*
+    <textarea
+        [ rows>> [ object>string =rows ] when* ]
+        [ cols>> [ object>string =cols ] when* ] bi
+        =name
+    textarea>
+        object>string escape-string write
+    </textarea> ;
+
+! Choice
+TUPLE: choice size multiple choices ;
+
+: <choice> ( -- choice )
+    choice new ;
+
+: render-option ( text selected? -- )
+    <option [ "true" =selected ] when option>
+        object>string escape-string write
+    </option> ;
+
+: render-options ( options selected -- )
+    '[ dup , member? render-option ] each ;
+
+M: choice render*
+    <select
+        swap =name
+        dup size>> [ object>string =size ] when*
+        dup multiple>> [ "true" =multiple ] when
+    select>
+        [ choices>> value ] [ multiple>> ] bi
+        [ swap ] [ swap 1array ] if
+        render-options
+    </select> ;
+
+! Checkboxes
+TUPLE: checkbox label ;
+
+: <checkbox> ( -- checkbox )
+    checkbox new ;
+
+M: checkbox render*
+    <input
+        "checkbox" =type
+        swap =name
+        swap [ "true" =selected ] when
+    input>
+        label>> escape-string write
+    </input> ;
+
+! Link components
+GENERIC: link-title ( obj -- string )
+GENERIC: link-href ( obj -- url )
+
+SINGLETON: link
+
+M: link render*
+    2drop
+    <a dup link-href =href a>
+        link-title object>string escape-string write
+    </a> ;
+
+! XMode code component
+TUPLE: code mode ;
+
+: <code> ( -- code )
+    code new ;
+
+M: code render*
+    [ string-lines ] [ drop ] [ mode>> value ] tri* htmlize-lines ;
+
+! Farkup component
+SINGLETON: farkup
+
+M: farkup render*
+    2drop string-lines "\n" join convert-farkup write ;
+
+! Inspector component
+SINGLETON: inspector
+
+M: inspector render*
+    2drop [ describe ] with-html-stream ;
+
+! Diff component
+SINGLETON: comparison
+
+M: comparison render*
+    2drop htmlize-diff ;
+
+! HTML component
+SINGLETON: html
+
+M: html render* 2drop write ;

extra/html/elements/elements-tests.factor

@@ -1,8 +1,5 @@
 IN: html.elements.tests
-USING: tools.test html html.elements io.streams.string ;
+USING: tools.test html.elements io.streams.string ;
-
-: make-html-string
-    [ with-html-stream ] with-string-writer ;
 
 [ "<a href='h&amp;o'>" ]
-[ [ <a "h&o" =href a> ] make-html-string ] unit-test
+[ [ <a "h&o" =href a> ] with-string-writer ] unit-test

extra/html/elements/elements.factor

@@ -57,6 +57,8 @@ SYMBOL: html
 : print-html ( str -- )
     write-html "\n" write-html ;
 
+<<
+
 : html-word ( name def effect -- )
     #! Define 'word creating' word to allow
     #! dynamically creating words.
@@ -137,30 +139,46 @@ SYMBOL: html
     dup "=" prepend swap
     [ write-attr ] curry attribute-effect html-word ;
 
+! Define some closed HTML tags
 [
-    ! Define some closed HTML tags
-    [
     "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
     "ol" "li" "form" "a" "p" "html" "head" "body" "title"
     "b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
     "script" "div" "span" "select" "option" "style" "input"
-    ] [ define-closed-html-word ] each
+] [ define-closed-html-word ] each
 
-    ! Define some open HTML tags
+! Define some open HTML tags
-    [
+[
     "input"
     "br"
     "link"
     "img"
-    ] [ define-open-html-word ] each
+] [ define-open-html-word ] each
 
-    ! Define some attributes
+! Define some attributes
-    [
+[
     "method" "action" "type" "value" "name"
     "size" "href" "class" "border" "rows" "cols"
     "id" "onclick" "style" "valign" "accesskey"
     "src" "language" "colspan" "onchange" "rel"
     "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
     "media" "title" "multiple"
-    ] [ define-attribute-word ] each
+] [ define-attribute-word ] each
-] with-compilation-unit
+
+>>
+
+: xhtml-preamble ( -- )
+    "<?xml version=\"1.0\"?>" write-html
+    "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" write-html ;
+
+: simple-page ( title quot -- )
+    #! Call the quotation, with all output going to the
+    #! body of an html page with the given title.
+    xhtml-preamble
+    <html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
+        <head> <title> swap write </title> </head>
+        <body> call </body>
+    </html> ;
+
+: render-error ( message -- )
+    <span "error" =class span> escape-string write </span> ;

extra/html/html.factor

@@ -1,267 +0,0 @@
-! Copyright (C) 2004, 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: generic assocs help http io io.styles io.files continuations
-io.streams.string kernel math math.order math.parser namespaces
-quotations assocs sequences strings words html.elements
-xml.entities sbufs continuations destructors ;
-IN: html
-
-GENERIC: browser-link-href ( presented -- href )
-
-M: object browser-link-href drop f ;
-
-TUPLE: html-stream last-div? ;
-
-! A hack: stream-nl after with-nesting or tabular-output is
-! ignored, so that HTML stream output looks like UI pane output
-: test-last-div? ( stream -- ? )
-    dup html-stream-last-div?
-    f rot set-html-stream-last-div? ;
-
-: not-a-div ( stream -- stream )
-    dup test-last-div? drop ; inline
-
-: a-div ( stream -- straem )
-    t over set-html-stream-last-div? ; inline
-
-: <html-stream> ( stream -- stream )
-    html-stream construct-delegate ;
-
-<PRIVATE
-
-TUPLE: html-sub-stream style stream ;
-
-: (html-sub-stream) ( style stream -- stream )
-    html-sub-stream boa
-    512 <sbuf> <html-stream> over set-delegate ;
-
-: <html-sub-stream> ( style stream class -- stream )
-    >r (html-sub-stream) r> construct-delegate ; inline
-
-: end-sub-stream ( substream -- string style stream )
-    dup delegate >string
-    over html-sub-stream-style
-    rot html-sub-stream-stream ;
-
-: delegate-write ( string -- )
-    output-stream get delegate stream-write ;
-
-: object-link-tag ( style quot -- )
-    presented pick at [
-        browser-link-href [
-            <a =href a> call </a>
-        ] [ call ] if*
-    ] [ call ] if* ; inline
-
-: hex-color, ( triplet -- )
-    3 head-slice
-    [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ;
-
-: fg-css, ( color -- )
-    "color: #" % hex-color, "; " % ;
-
-: bg-css, ( color -- )
-    "background-color: #" % hex-color, "; " % ;
-
-: style-css, ( flag -- )
-    dup
-    { italic bold-italic } member?
-    "font-style: " % "italic" "normal" ? % "; " %
-    { bold bold-italic } member?
-    "font-weight: " % "bold" "normal" ? % "; " % ;
-
-: size-css, ( size -- )
-    "font-size: " % # "pt; " % ;
-
-: font-css, ( font -- )
-    "font-family: " % % "; " % ;
-
-: apply-style ( style key quot -- style gadget )
-    >r over at r> when* ; inline
-
-: make-css ( style quot -- str )
-    "" make nip ; inline
-
-: span-css-style ( style -- str )
-    [
-        foreground [ fg-css,    ] apply-style
-        background [ bg-css,    ] apply-style
-        font       [ font-css,  ] apply-style
-        font-style [ style-css, ] apply-style
-        font-size  [ size-css,  ] apply-style
-    ] make-css ;
-
-: span-tag ( style quot -- )
-    over span-css-style dup empty? [
-        drop call
-    ] [
-        <span =style span> call </span>
-    ] if ; inline
-
-: format-html-span ( string style stream -- )
-    [
-        [ [ drop delegate-write ] span-tag ] object-link-tag
-    ] with-output-stream* ;
-
-TUPLE: html-span-stream ;
-
-M: html-span-stream dispose
-    end-sub-stream not-a-div format-html-span ;
-
-: border-css, ( border -- )
-    "border: 1px solid #" % hex-color, "; " % ;
-
-: padding-css, ( padding -- ) "padding: " % # "px; " % ;
-
-: pre-css, ( margin -- )
-    [ "white-space: pre; font-family: monospace; " % ] unless ;
-
-: div-css-style ( style -- str )
-    [
-        page-color   [ bg-css,      ] apply-style
-        border-color [ border-css,  ] apply-style
-        border-width [ padding-css, ] apply-style
-        wrap-margin over at pre-css,
-    ] make-css ;
-
-: div-tag ( style quot -- )
-    swap div-css-style dup empty? [
-        drop call
-    ] [
-        <div =style div> call </div>
-    ] if ; inline
-
-: format-html-div ( string style stream -- )
-    [
-        [ [ delegate-write ] div-tag ] object-link-tag
-    ] with-output-stream* ;
-
-TUPLE: html-block-stream ;
-
-M: html-block-stream dispose ( quot style stream -- )
-    end-sub-stream a-div format-html-div ;
-
-: border-spacing-css,
-    "padding: " % first2 max 2 /i # "px; " % ;
-
-: table-style ( style -- str )
-    [
-        table-border [ border-css,         ] apply-style
-        table-gap    [ border-spacing-css, ] apply-style
-    ] make-css ;
-
-: table-attrs ( style -- )
-    table-style " border-collapse: collapse;" append =style ;
-
-: do-escaping ( string style -- string )
-    html swap at [ escape-string ] unless ;
-
-PRIVATE>
-
-! Stream protocol
-M: html-stream stream-write1 ( char stream -- )
-    >r 1string r> stream-write ;
-
-M: html-stream stream-write ( str stream -- )
-    not-a-div >r escape-string r> delegate stream-write ;
-
-M: html-stream make-span-stream ( style stream -- stream' )
-    html-span-stream <html-sub-stream> ;
-
-M: html-stream stream-format ( str style stream -- )
-    >r html over at [ >r escape-string r> ] unless r>
-    format-html-span ;
-
-M: html-stream make-block-stream ( style stream -- stream' )
-    html-block-stream <html-sub-stream> ;
-
-M: html-stream stream-write-table ( grid style stream -- )
-    a-div [
-        <table dup table-attrs table> swap [
-            <tr> [
-                <td "top" =valign swap table-style =style td>
-                    >string write-html
-                </td>
-            ] with each </tr>
-        ] with each </table>
-    ] with-output-stream* ;
-
-M: html-stream make-cell-stream ( style stream -- stream' )
-    (html-sub-stream) ;
-
-M: html-stream stream-nl ( stream -- )
-    dup test-last-div? [ drop ] [ [ <br/> ] with-output-stream* ] if ;
-
-! Utilities
-: with-html-stream ( quot -- )
-    output-stream get <html-stream> swap with-output-stream* ; inline
-
-: xhtml-preamble
-    "<?xml version=\"1.0\"?>" write-html
-    "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" write-html ;
-
-: html-document ( body-quot head-quot -- )
-    #! head-quot is called to produce output to go
-    #! in the html head portion of the document.
-    #! body-quot is called to produce output to go
-    #! in the html body portion of the document.
-    xhtml-preamble
-    <html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
-        <head> call </head>
-        <body> call </body>
-    </html> ;
-
-: default-css ( -- )
-    <link
-    "stylesheet" =rel "text/css" =type
-    "/responder/resources/extra/html/stylesheet.css" =href
-    link/> ;
-
-: simple-html-document ( title quot -- )
-    swap [
-        <title> write </title>
-        default-css
-    ] html-document ;
-
-: vertical-layout ( list -- )
-    #! Given a list of HTML components, arrange them vertically.
-    <table>
-    [ <tr> <td> call </td> </tr> ] each
-    </table> ;
-
-: horizontal-layout ( list -- )
-    #! Given a list of HTML components, arrange them horizontally.
-    <table>
-     <tr "top" =valign tr> [ <td> call </td> ] each </tr>
-    </table> ;
-
-: button ( label -- )
-    #! Output an HTML submit button with the given label.
-    <input "submit" =type =value input/> ;
-
-: paragraph ( str -- )
-    #! Output the string as an html paragraph
-    <p> write </p> ;
-
-: simple-page ( title quot -- )
-    #! Call the quotation, with all output going to the
-    #! body of an html page with the given title.
-    <html>
-        <head> <title> swap write </title> </head>
-        <body> call </body>
-    </html> ;
-
-: styled-page ( title stylesheet-quot quot -- )
-    #! Call the quotation, with all output going to the
-    #! body of an html page with the given title. stylesheet-quot
-    #! is called to generate the required stylesheet.
-    <html>
-        <head>
-             <title> rot write </title>
-             swap call
-        </head>
-        <body> call </body>
-    </html> ;
-
-: render-error ( message -- )
-    <span "error" =class span> escape-string write </span> ;

extra/html/parser/analyzer/analyzer.factor

@@ -3,25 +3,27 @@ arrays shuffle unicode.case namespaces splitting http
 sequences.lib accessors io combinators http.client ;
 IN: html.parser.analyzer
 
+TUPLE: link attributes clickable ;
+
 : scrape-html ( url -- vector )
     http-get parse-html ;
 
 : (find-relative)
-    [ >r + dup r> ?nth* [ 2drop f f ] unless ] [ 2drop f ] if ;
+    [ >r + dup r> ?nth* [ 2drop f f ] unless ] [ 2drop f ] if ; inline
 
 : find-relative ( seq quot n -- i elt )
     >r over [ find drop ] dip r> swap pick
-    (find-relative) ;
+    (find-relative) ; inline
 
 : (find-all) ( n seq quot -- )
     2dup >r >r find-from [
         dupd 2array , 1+ r> r> (find-all)
     ] [
         r> r> 3drop
-    ] if* ;
+    ] if* ; inline
 
 : find-all ( seq quot -- alist )
-    [ 0 -rot (find-all) ] { } make ;
+    [ 0 -rot (find-all) ] { } make ; inline
 
 : (find-nth) ( offset seq quot n count -- obj )
     >r >r [ find-from ] 2keep 4 npick [
@@ -33,14 +35,14 @@ IN: html.parser.analyzer
         ] if
     ] [
         2drop r> r> 2drop
-    ] if ;
+    ] if ; inline
 
 : find-nth ( seq quot n -- i elt )
-    0 -roll 0 (find-nth) ;
+    0 -roll 0 (find-nth) ; inline
 
 : find-nth-relative ( seq quot n offest -- i elt )
     >r [ find-nth ] 3keep 2drop nip r> swap pick
-    (find-relative) ;
+    (find-relative) ; inline
 
 : remove-blank-text ( vector -- vector' )
     [
@@ -120,9 +122,14 @@ IN: html.parser.analyzer
     [ [ name>> "a" = ] [ attributes>> "href" swap at ] bi and ]
     find-between-all ;
 
+: <link> ( vector -- link )
+    [ first attributes>> ]
+    [ [ name>> { text "img" } member? ] filter ] bi
+    link boa ;
+
 : link. ( vector -- )
-    [ second text>> write bl ]
+    [ attributes>> "href" swap at write nl ]
-    [ first tag-link write nl ] bi ;
+    [ clickable>> [ bl bl text>> print ] each nl ] bi ;
 
 : find-by-text ( seq quot -- tag )
     [ dup name>> text = ] prepose find drop ;
@@ -136,12 +143,12 @@ IN: html.parser.analyzer
 
 : find-forms ( vector -- vector' )
     "form" over find-opening-tags-by-name
-    over [ >r first2 r> find-between* ] curry map
+    swap [ >r first2 r> find-between* ] curry map
     [ [ name>> { "form" "input" } member? ] filter ] map ;
 
 : find-html-objects ( string vector -- vector' )
-    find-opening-tags-by-name
+    [ find-opening-tags-by-name ] keep
-    over [ >r first2 r> find-between* ] curry map ;
+    [ >r first2 r> find-between* ] curry map ;
 
 : form-action ( vector -- string )
     [ name>> "form" = ] find nip 

extra/html/streams/streams-tests.factor

@@ -1,6 +1,7 @@
-USING: html http io io.streams.string io.styles kernel
+USING: html.streams html.streams.private
-namespaces tools.test xml.writer sbufs sequences html.private ;
+io io.streams.string io.styles kernel
-IN: html.tests
+namespaces tools.test xml.writer sbufs sequences inspector ;
+IN: html.streams.tests
 
 : make-html-string
     [ with-html-stream ] with-string-writer ; inline
@@ -69,3 +70,5 @@ M: funky browser-link-href
 ] [
     [ H{ } [ ] with-nesting nl ] make-html-string
 ] unit-test
+
+[ ] [ [ { 1 2 3 } describe ] with-html-stream ] unit-test

extra/html/streams/streams.factor

@@ -0,0 +1,195 @@
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: generic assocs help http io io.styles io.files continuations
+io.streams.string kernel math math.order math.parser namespaces
+quotations assocs sequences strings words html.elements
+xml.entities sbufs continuations destructors accessors ;
+IN: html.streams
+
+GENERIC: browser-link-href ( presented -- href )
+
+M: object browser-link-href drop f ;
+
+TUPLE: html-stream stream last-div ;
+
+! stream-nl after with-nesting or tabular-output is
+! ignored, so that HTML stream output looks like
+! UI pane output
+: last-div? ( stream -- ? )
+    [ f ] change-last-div drop ;
+
+: not-a-div ( stream -- stream )
+    f >>last-div ; inline
+
+: a-div ( stream -- straem )
+    t >>last-div ; inline
+
+: <html-stream> ( stream -- stream )
+    f html-stream boa ;
+
+<PRIVATE
+
+TUPLE: html-sub-stream < html-stream style parent ;
+
+: new-html-sub-stream ( style stream class -- stream )
+    new
+        512 <sbuf> >>stream
+        swap >>parent
+        swap >>style ; inline
+
+: end-sub-stream ( substream -- string style stream )
+    [ stream>> >string ] [ style>> ] [ parent>> ] tri ;
+
+: object-link-tag ( style quot -- )
+    presented pick at [
+        browser-link-href [
+            <a =href a> call </a>
+        ] [ call ] if*
+    ] [ call ] if* ; inline
+
+: hex-color, ( triplet -- )
+    3 head-slice
+    [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ;
+
+: fg-css, ( color -- )
+    "color: #" % hex-color, "; " % ;
+
+: bg-css, ( color -- )
+    "background-color: #" % hex-color, "; " % ;
+
+: style-css, ( flag -- )
+    dup
+    { italic bold-italic } member?
+    "font-style: " % "italic" "normal" ? % "; " %
+    { bold bold-italic } member?
+    "font-weight: " % "bold" "normal" ? % "; " % ;
+
+: size-css, ( size -- )
+    "font-size: " % # "pt; " % ;
+
+: font-css, ( font -- )
+    "font-family: " % % "; " % ;
+
+: apply-style ( style key quot -- style gadget )
+    >r over at r> when* ; inline
+
+: make-css ( style quot -- str )
+    "" make nip ; inline
+
+: span-css-style ( style -- str )
+    [
+        foreground [ fg-css,    ] apply-style
+        background [ bg-css,    ] apply-style
+        font       [ font-css,  ] apply-style
+        font-style [ style-css, ] apply-style
+        font-size  [ size-css,  ] apply-style
+    ] make-css ;
+
+: span-tag ( style quot -- )
+    over span-css-style dup empty? [
+        drop call
+    ] [
+        <span =style span> call </span>
+    ] if ; inline
+
+: format-html-span ( string style stream -- )
+    stream>> [
+        [ [ drop write ] span-tag ] object-link-tag
+    ] with-output-stream* ;
+
+TUPLE: html-span-stream < html-sub-stream ;
+
+M: html-span-stream dispose
+    end-sub-stream not-a-div format-html-span ;
+
+: border-css, ( border -- )
+    "border: 1px solid #" % hex-color, "; " % ;
+
+: padding-css, ( padding -- ) "padding: " % # "px; " % ;
+
+: pre-css, ( margin -- )
+    [ "white-space: pre; font-family: monospace; " % ] unless ;
+
+: div-css-style ( style -- str )
+    [
+        page-color   [ bg-css,      ] apply-style
+        border-color [ border-css,  ] apply-style
+        border-width [ padding-css, ] apply-style
+        wrap-margin over at pre-css,
+    ] make-css ;
+
+: div-tag ( style quot -- )
+    swap div-css-style dup empty? [
+        drop call
+    ] [
+        <div =style div> call </div>
+    ] if ; inline
+
+: format-html-div ( string style stream -- )
+    stream>> [
+        [ [ write ] div-tag ] object-link-tag
+    ] with-output-stream* ;
+
+TUPLE: html-block-stream < html-sub-stream ;
+
+M: html-block-stream dispose ( quot style stream -- )
+    end-sub-stream a-div format-html-div ;
+
+: border-spacing-css,
+    "padding: " % first2 max 2 /i # "px; " % ;
+
+: table-style ( style -- str )
+    [
+        table-border [ border-css,         ] apply-style
+        table-gap    [ border-spacing-css, ] apply-style
+    ] make-css ;
+
+: table-attrs ( style -- )
+    table-style " border-collapse: collapse;" append =style ;
+
+: do-escaping ( string style -- string )
+    html swap at [ escape-string ] unless ;
+
+PRIVATE>
+
+! Stream protocol
+M: html-stream stream-flush
+    stream>> stream-flush ;
+
+M: html-stream stream-write1
+    >r 1string r> stream-write ;
+
+M: html-stream stream-write
+    not-a-div >r escape-string r> stream>> stream-write ;
+
+M: html-stream stream-format
+    >r html over at [ >r escape-string r> ] unless r>
+    format-html-span ;
+
+M: html-stream stream-nl
+    dup last-div? [ drop ] [ [ <br/> ] with-output-stream* ] if ;
+
+M: html-stream make-span-stream
+    html-span-stream new-html-sub-stream ;
+
+M: html-stream make-block-stream
+    html-block-stream new-html-sub-stream ;
+
+M: html-stream make-cell-stream
+    html-sub-stream new-html-sub-stream ;
+
+M: html-stream stream-write-table
+    a-div stream>> [
+        <table dup table-attrs table> swap [
+            <tr> [
+                <td "top" =valign swap table-style =style td>
+                    stream>> >string write
+                </td>
+            ] with each </tr>
+        ] with each </table>
+    ] with-output-stream* ;
+
+M: html-stream dispose stream>> dispose ;
+
+: with-html-stream ( quot -- )
+    output-stream get <html-stream> swap with-output-stream* ; inline

extra/html/stylesheet.css

@@ -1,4 +0,0 @@
-a:link { text-decoration: none; color: black; }
-a:visited { text-decoration: none; color: black; }
-a:active { text-decoration: none; color: black; }
-a:hover { text-decoration: underline; color: black; }

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

@@ -0,0 +1,161 @@
+USING: html.templates html.templates.chloe
+tools.test io.streams.string kernel sequences ascii boxes
+namespaces xml html.components
+splitting unicode.categories ;
+IN: html.templates.chloe.tests
+
+[ 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 ] filter
+    "?>" split1 nip ; inline
+
+: test-template ( name -- template )
+    "resource:extra/html/templates/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
+
+[ ] [ blank-values ] unit-test
+
+[ ] [ "A label" "label" set-value ] unit-test
+
+SINGLETON: link-test
+
+M: link-test link-title drop "<Link Title>" ;
+
+M: link-test link-href drop "http://www.apple.com/foo&bar" ;
+
+[ ] [ link-test "link" set-value ] unit-test
+
+[ ] [ "int x = 5;" "code" set-value ] unit-test
+
+[ ] [ "c" "mode" set-value ] unit-test
+
+[ ] [ { 1 2 3 } "inspector" set-value ] unit-test
+
+[ ] [ "<p>a paragraph</p>" "html" set-value ] unit-test
+
+[ ] [ "sheeple" "field" set-value ] unit-test
+
+[ ] [ "a password" "password" set-value ] unit-test
+
+[ ] [ "a\nb\nc" "textarea" set-value ] unit-test
+
+[ ] [ "new york" "choice" set-value ] unit-test
+
+[ ] [ { "new york" "detroit" "minneapolis" } "choices" set-value ] unit-test
+
+[ ] [
+    [
+        "test8" test-template call-template
+    ] run-template drop
+] unit-test
+
+[ ] [ { 1 2 3 } "numbers" set-value ] unit-test
+
+[ "<ul><li>1</li><li>2</li><li>3</li></ul>" ] [
+    [
+        "test9" test-template call-template
+    ] run-template [ blank? not ] filter
+] unit-test
+
+TUPLE: person first-name last-name ;
+
+[ ] [
+    {
+        T{ person f "RBaxter" "Unknown" }
+        T{ person f "Doug" "Coleman" }
+    } "people" set-value
+] unit-test
+
+[ "<table><tr><td>RBaxter</td><td>Unknown</td></tr><tr><td>Doug</td><td>Coleman</td></tr></table>" ] [
+    [
+        "test10" test-template call-template
+    ] run-template [ blank? not ] filter
+] unit-test
+
+[ ] [
+    {
+        H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } }
+        H{ { "first-name" "Doug"    } { "last-name" "Coleman" } }
+    } "people" set-value
+] unit-test
+
+[ "<table><tr><td>RBaxter</td><td>Unknown</td></tr><tr><td>Doug</td><td>Coleman</td></tr></table>" ] [
+    [
+        "test11" test-template call-template
+    ] run-template [ blank? not ] filter
+] unit-test

extra/html/templates/chloe/chloe.factor

@@ -3,17 +3,17 @@
 USING: accessors kernel sequences combinators kernel namespaces
 classes.tuple assocs splitting words arrays memoize
 io io.files io.encodings.utf8 io.streams.string
-unicode.case tuple-syntax html html.elements
+unicode.case tuple-syntax mirrors fry math
 multiline xml xml.data xml.writer xml.utilities
+html.elements
+html.components
+html.templates
 http.server
 http.server.auth
 http.server.flows
 http.server.actions
-http.server.components
+http.server.sessions ;
-http.server.sessions
+IN: html.templates.chloe
-http.server.templating
-http.server.boilerplate ;
-IN: http.server.templating.chloe
 
 ! Chloe is Ed's favorite web designer
 
@@ -52,8 +52,11 @@ MEMO: chloe-name ( string -- name )
 : optional-attr ( tag name -- value )
     chloe-name swap at ;
 
+: process-tag-children ( tag -- )
+    [ process-template ] each ;
+
 : children>string ( tag -- string )
-    [ [ process-template ] each ] with-string-writer ;
+    [ process-tag-children ] with-string-writer ;
 
 : title-tag ( tag -- )
     children>string set-title ;
@@ -89,18 +92,6 @@ MEMO: chloe-name ( string -- name )
         atom-feed get value>> second write
     ] if ;
 
-: component-attr ( tag -- name )
-    "component" required-attr ;
-
-: view-tag ( tag -- )
-    component-attr component render-view ;
-
-: edit-tag ( tag -- )
-    component-attr component render-edit ;
-
-: summary-tag ( tag -- )
-    component-attr component render-summary ;
-
 : parse-query-attr ( string -- assoc )
     dup empty?
     [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
@@ -133,9 +124,6 @@ MEMO: chloe-name ( string -- name )
         a>
     ] with-scope ;
 
-: process-tag-children ( tag -- )
-    [ process-template ] each ;
-
 : a-tag ( tag -- )
     [ a-start-tag ]
     [ process-tag-children ]
@@ -156,7 +144,7 @@ MEMO: chloe-name ( string -- name )
             form>
         ] [
             hidden-form-field
-            "for" optional-attr [ component render-edit ] when*
+            "for" optional-attr [ hidden render ] when*
         ] bi
     ] with-scope ;
 
@@ -180,9 +168,9 @@ STRING: button-tag-markup
 : button-tag ( tag -- )
     button-tag-markup string>xml delegate
     {
-        [ >r tag-attrs chloe-attrs-only r> add-tag-attrs ]
+        [ [ tag-attrs chloe-attrs-only ] dip add-tag-attrs ]
-        [ >r tag-attrs non-chloe-attrs-only r> "button" tag-named add-tag-attrs ]
+        [ [ tag-attrs non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
-        [ >r children>string 1array r> "button" tag-named set-tag-children ]
+        [ [ children>string 1array ] dip "button" tag-named set-tag-children ]
         [ nip ]
     } 2cleave process-chloe-tag ;
 
@@ -208,30 +196,109 @@ STRING: button-tag-markup
 : if-tag ( tag -- )
     dup if-satisfied? [ process-tag-children ] [ drop ] if ;
 
+: even-tag ( tag -- )
+    "index" value even? [ process-tag-children ] [ drop ] if ;
+
+: odd-tag ( tag -- )
+    "index" value odd? [ process-tag-children ] [ drop ] if ;
+
+: (each-tag) ( tag quot -- )
+    [
+        [ "values" required-attr value ] keep
+        '[ , process-tag-children ]
+    ] dip call ; inline
+
+: each-tag ( tag -- )
+    [ with-each-value ] (each-tag) ;
+
+: each-tuple-tag ( tag -- )
+    [ with-each-tuple ] (each-tag) ;
+
+: each-assoc-tag ( tag -- )
+    [ with-each-assoc ] (each-tag) ;
+
+: (bind-tag) ( tag quot -- )
+    [
+        [ "name" required-attr value ] keep
+        '[ , process-tag-children ]
+    ] dip call ; inline
+
+: bind-tuple-tag ( tag -- )
+    [ with-tuple-values ] (bind-tag) ;
+
+: bind-assoc-tag ( tag -- )
+    [ with-assoc-values ] (bind-tag) ;
+
 : error-message-tag ( tag -- )
     children>string render-error ;
 
+: validation-messages-tag ( tag -- )
+    drop render-validation-messages ;
+
+: singleton-component-tag ( tag class -- )
+    [ "name" required-attr ] dip render ;
+
+: attrs>slots ( tag tuple -- )
+    [ attrs>> ] [ <mirror> ] bi*
+    '[
+        swap tag>> dup "name" =
+        [ 2drop ] [ , set-at ] if
+    ] assoc-each ;
+
+: tuple-component-tag ( tag class -- )
+    [ drop "name" required-attr ]
+    [ new [ attrs>slots ] keep ]
+    2bi render ;
+
 : process-chloe-tag ( tag -- )
     dup name-tag {
-        { "chloe" [ [ process-template ] each ] }
+        { "chloe" [ process-tag-children ] }
+
+        ! HTML head
         { "title" [ title-tag ] }
         { "write-title" [ write-title-tag ] }
         { "style" [ style-tag ] }
         { "write-style" [ write-style-tag ] }
         { "atom" [ atom-tag ] }
         { "write-atom" [ write-atom-tag ] }
-        { "view" [ view-tag ] }
+
-        { "edit" [ edit-tag ] }
+        ! HTML elements
-        { "summary" [ summary-tag ] }
         { "a" [ a-tag ] }
-        { "form" [ form-tag ] }
         { "button" [ button-tag ] }
+
+        ! Components
+        { "label" [ label singleton-component-tag ] }
+        { "link" [ link singleton-component-tag ] }
+        { "code" [ code tuple-component-tag ] }
+        { "farkup" [ farkup singleton-component-tag ] }
+        { "inspector" [ inspector singleton-component-tag ] }
+        { "comparison" [ comparison singleton-component-tag ] }
+        { "html" [ html singleton-component-tag ] }
+
+        ! Forms
+        { "form" [ form-tag ] }
         { "error-message" [ error-message-tag ] }
-        { "validation-message" [ drop render-validation-message ] }
+        { "validation-messages" [ validation-messages-tag ] }
+        { "hidden" [ hidden singleton-component-tag ] }
+        { "field" [ field tuple-component-tag ] }
+        { "password" [ password tuple-component-tag ] }
+        { "textarea" [ textarea tuple-component-tag ] }
+        { "choice" [ choice tuple-component-tag ] }
+        { "checkbox" [ checkbox tuple-component-tag ] }
+
+        ! Control flow
         { "if" [ if-tag ] }
+        { "even" [ even-tag ] }
+        { "odd" [ odd-tag ] }
+        { "each" [ each-tag ] }
+        { "each-assoc" [ each-assoc-tag ] }
+        { "each-tuple" [ each-tuple-tag ] }
+        { "bind-assoc" [ bind-assoc-tag ] }
+        { "bind-tuple" [ bind-tuple-tag ] }
         { "comment" [ drop ] }
         { "call-next-template" [ drop call-next-template ] }
-        [ "Unknown chloe tag: " swap append throw ]
+
+        [ "Unknown chloe tag: " prepend throw ]
     } case ;
 
 : process-tag ( tag -- )

extra/html/templates/chloe/test/test10.xml

@@ -0,0 +1,14 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<table>
+		<t:each-tuple t:values="people">
+			<tr>
+				<td><t:label t:name="first-name"/></td>
+				<td><t:label t:name="last-name"/></td>
+			</tr>
+		</t:each-tuple>
+	</table>
+
+</t:chloe>

extra/html/templates/chloe/test/test11.xml

@@ -0,0 +1,14 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<table>
+		<t:each-assoc t:values="people">
+			<tr>
+				<td><t:label t:name="first-name"/></td>
+				<td><t:label t:name="last-name"/></td>
+			</tr>
+		</t:each-assoc>
+	</table>
+
+</t:chloe>

extra/html/templates/chloe/test/test4.xml

@@ -2,7 +2,7 @@
 
 <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
 
-	<t:if t:code="http.server.templating.chloe.tests:test4-aux?">
+	<t:if t:code="html.templates.chloe.tests:test4-aux?">
 		True
 	</t:if>
 

extra/html/templates/chloe/test/test5.xml

@@ -2,7 +2,7 @@
 
 <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
 
-	<t:if t:code="http.server.templating.chloe.tests:test5-aux?">
+	<t:if t:code="html.templates.chloe.tests:test5-aux?">
 		True
 	</t:if>
 

extra/html/templates/chloe/test/test6.xml

@@ -2,7 +2,7 @@
 
 <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
 
-	<t:if t:var="http.server.templating.chloe.tests:test6-aux?">
+	<t:if t:var="html.templates.chloe.tests:test6-aux?">
 		True
 	</t:if>
 

extra/html/templates/chloe/test/test7.xml

@@ -2,7 +2,7 @@
 
 <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
 
-	<t:if t:var="http.server.templating.chloe.tests:test7-aux?">
+	<t:if t:var="html.templates.chloe.tests:test7-aux?">
 		True
 	</t:if>
 

extra/html/templates/chloe/test/test8.xml

@@ -0,0 +1,27 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:label t:name="label" />
+
+	<t:link t:name="link" />
+
+	<t:code t:name="code" mode="mode" />
+
+	<t:farkup t:name="farkup" />
+
+	<t:inspector t:name="inspector" />
+
+	<t:html t:name="html" />
+
+	<t:field t:name="field" t:size="13" />
+
+	<t:password t:name="password" t:size="10" />
+
+	<t:textarea t:name="textarea" t:rows="5" t:cols="10" />
+
+	<t:choice t:name="choice" t:choices="choices" />
+
+	<t:checkbox t:name="checkbox">Checkbox</t:checkbox>
+
+</t:chloe>

extra/html/templates/chloe/test/test9.xml

@@ -0,0 +1,11 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<ul>
+		<t:each t:values="numbers">
+			<li><t:label t:name="value"/></li>
+		</t:each>
+	</ul>
+
+</t:chloe>

extra/html/templates/fhtml/fhtml-tests.factor

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

extra/html/templates/fhtml/fhtml.factor

@@ -4,12 +4,10 @@
 USING: continuations sequences kernel namespaces debugger
 combinators math quotations generic strings splitting
 accessors assocs fry
-parser io io.files io.streams.string io.encodings.utf8 source-files
+parser io io.files io.streams.string io.encodings.utf8
-html html.elements
+html.elements
-http.server.static http.server http.server.templating ;
+html.templates ;
-IN: http.server.templating.fhtml
+IN: html.templates.fhtml
-
-: templating-vocab ( -- vocab-name ) "http.server.templating.fhtml" ;
 
 ! We use a custom lexer so that %> ends a token even if not
 ! followed by whitespace
@@ -35,7 +33,7 @@ DEFER: <% delimiter
 : found-<% ( accum lexer col -- accum )
     [
         over line-text>>
-        >r >r column>> r> r> subseq parsed
+        [ column>> ] 2dip subseq parsed
         \ write-html parsed
     ] 2keep 2 + >>column drop ;
 
@@ -62,37 +60,20 @@ DEFER: <% delimiter
 
 : parse-template ( string -- quot )
     [
-        use [ clone ] change
+        "quiet" on
-        templating-vocab use+
+        parser-notes off
+        "html.templates.fhtml" use+
         string-lines parse-template-lines
-    ] with-scope ;
+    ] with-file-vocabs ;
 
-: eval-template ( string -- ) parse-template call ;
+: eval-template ( string -- )
-
+    parse-template call ;
-: html-error. ( error -- )
-    <pre> error. </pre> ;
 
 TUPLE: fhtml path ;
 
 C: <fhtml> fhtml
 
 M: fhtml call-template* ( filename -- )
-    '[
+    '[ , path>> utf8 file-contents eval-template ] assert-depth ;
-        , path>> [
-            "quiet" on
-            parser-notes off
-            templating-vocab use+
-            ! so that reload works properly
-            dup source-file file set
-            utf8 file-contents
-            [ eval-template ] [ html-error. drop ] recover
-        ] with-file-vocabs
-    ] assert-depth ;
-
-! file responder integration
-: enable-fhtml ( responder -- responder )
-    [ <fhtml> serve-template ]
-    "application/x-factor-server-page"
-    pick special>> set-at ;
 
 INSTANCE: fhtml template

extra/html/templates/templates.factor

@@ -0,0 +1,85 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel fry io io.encodings.utf8 io.files
+debugger prettyprint continuations namespaces boxes sequences
+arrays strings html.elements io.streams.string quotations ;
+IN: html.templates
+
+MIXIN: template
+
+GENERIC: call-template* ( template -- )
+
+M: string call-template* write ;
+
+M: callable call-template* call ;
+
+M: object call-template* output-stream get stream-copy ;
+
+ERROR: template-error template error ;
+
+M: template-error error.
+    "Error while processing template " write
+    [ template>> short. ":" print nl ]
+    [ error>> error. ]
+    bi ;
+
+: call-template ( template -- )
+    [ call-template* ] [ \ template-error boa rethrow ] recover ;
+
+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: atom-feed
+
+: set-atom-feed ( title url -- )
+    2array atom-feed get >box ;
+
+: write-atom-feed ( -- )
+    atom-feed get value>> [
+        <link "alternate" =rel "application/atom+xml" =type
+        [ first =title ] [ second =href ] bi
+        link/>
+    ] when* ;
+
+SYMBOL: nested-template?
+
+SYMBOL: next-template
+
+: call-next-template ( -- )
+    next-template get write-html ;
+
+M: f call-template* drop call-next-template ;
+
+: with-boilerplate ( body template -- )
+    [
+        title get [ <box> title set ] unless
+        atom-feed get [ <box> atom-feed set ] unless
+        style get [ SBUF" " clone style set ] unless
+
+        [
+            [
+                nested-template? on
+                call-template
+            ] with-string-writer
+            next-template set
+        ]
+        [ call-template ]
+        bi*
+    ] with-scope ; inline
+
+: template-convert ( template output -- )
+    utf8 [ call-template ] with-file-writer ;

extra/http/client/client.factor

@@ -93,7 +93,7 @@ M: download-failed error.
 
 : download-to ( url file -- )
     #! Downloads the contents of a URL to a file.
-    >r http-get r> latin1 [ write ] with-file-writer ;
+    [ http-get ] dip latin1 [ write ] with-file-writer ;
 
 : download ( url -- )
     dup download-name download-to ;

extra/http/http-tests.factor

@@ -237,7 +237,7 @@ test-db [
 [ ] [
     [
         <dispatcher>
-            <action> [ "text/plain" <content> [ "Hi" write ] >>body ] >>display
+            <action> [ [ "Hi" write ] <text-content> ] >>display
             <login>
             <sessions>
             "" add-responder

extra/http/http.factor

@@ -9,7 +9,9 @@ math.parser calendar calendar.format
 io io.streams.string io.encodings.utf8 io.encodings.string
 io.sockets io.sockets.secure
 
-unicode.case unicode.categories qualified ;
+unicode.case unicode.categories qualified
+
+html.templates ;
 
 EXCLUDE: fry => , ;
 
@@ -65,14 +67,14 @@ M: https protocol>string drop "https" ;
     2dup length 2 - >= [
         2drop
     ] [
-        >r 1+ dup 2 + r> subseq  hex> [ , ] when*
+        [ 1+ dup 2 + ] dip subseq  hex> [ , ] when*
     ] if ;
 
 : url-decode-% ( index str -- index str )
-    2dup url-decode-hex >r 3 + r> ;
+    2dup url-decode-hex [ 3 + ] dip ;
 
 : url-decode-+-or-other ( index str ch -- index str )
-    dup CHAR: + = [ drop CHAR: \s ] when , >r 1+ r> ;
+    dup CHAR: + = [ drop CHAR: \s ] when , [ 1+ ] dip ;
 
 : url-decode-iter ( index str -- )
     2dup length >= [
@@ -158,7 +160,7 @@ M: https protocol>string drop "https" ;
     dup [
         "&" split H{ } clone [
             [
-                >r "=" split1 [ dup [ url-decode ] when ] bi@ swap r>
+                [ "=" split1 [ dup [ url-decode ] when ] bi@ swap ] dip
                 add-query-param
             ] curry each
         ] keep
@@ -174,7 +176,7 @@ M: https protocol>string drop "https" ;
     ] assoc-map
     [
         [
-            >r url-encode r>
+            [ url-encode ] dip
             [ url-encode "=" swap 3append , ] with each
         ] assoc-each
     ] { } make "&" join ;
@@ -342,7 +344,7 @@ SYMBOL: max-post-request
     dup "cookie" header [ parse-cookies >>cookies ] when* ;
 
 : parse-content-type-attributes ( string -- attributes )
-    " " split harvest [ "=" split1 >r >lower r> ] { } map>assoc ;
+    " " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ;
 
 : parse-content-type ( content-type -- type encoding )
     ";" split1 parse-content-type-attributes "charset" swap at ;
@@ -521,18 +523,8 @@ body ;
     over unparse-content-type "content-type" pick set-at
     write-header ;
 
-GENERIC: write-response-body* ( body -- )
-
-M: f write-response-body* drop ;
-
-M: string write-response-body* write ;
-
-M: callable write-response-body* call ;
-
-M: object write-response-body* output-stream get stream-copy ;
-
 : write-response-body ( response -- response )
-    dup body>> write-response-body* ;
+    dup body>> call-template ;
 
 M: response write-response ( respose -- )
     write-response-version
@@ -547,10 +539,10 @@ M: response write-full-response ( request response -- )
     swap method>> "HEAD" = [ write-response-body ] unless ;
 
 : get-cookie ( request/response name -- cookie/f )
-    >r cookies>> r> '[ , _ name>> = ] find nip ;
+    [ cookies>> ] dip '[ , _ name>> = ] find nip ;
 
 : delete-cookie ( request/response name -- )
-    over cookies>> >r get-cookie r> delete ;
+    over cookies>> [ get-cookie ] dip delete ;
 
 : put-cookie ( request/response cookie -- request/response )
     [ name>> dupd get-cookie [ dupd delete-cookie ] when* ] keep

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

@@ -1,16 +1,10 @@
-USING: http.server.actions http.server.validators
+USING: kernel http.server.actions validators
 tools.test math math.parser multiline namespaces http
 io.streams.string http.server sequences splitting accessors ;
 IN: http.server.actions.tests
 
-[
-    "a" [ v-number ] { { "a" "123" } } validate-param
-    [ 123 ] [ "a" get ] unit-test
-] with-scope
-
 <action>
-    [ "a" get "b" get + ] >>display
+    [ "a" param "b" param [ string>number ] bi@ + ] >>display
-    { { "a" [ v-number ] } { "b" [ v-number ] } } >>get-params
 "action-1" set
 
 : lf>crlf "\n" split "\r\n" join ;

extra/http/server/actions/actions.factor

@@ -1,68 +1,94 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors sequences kernel assocs combinators
+USING: accessors sequences kernel assocs combinators http.server
-http.server http.server.validators http hashtables namespaces
+validators http hashtables namespaces fry continuations locals
-fry continuations locals boxes xml.entities html.elements io ;
+boxes xml.entities html.elements html.components io arrays math ;
 IN: http.server.actions
 
 SYMBOL: params
 
-SYMBOL: validation-message
+SYMBOL: rest-param
 
-: render-validation-message ( -- )
+: render-validation-messages ( -- )
-    validation-message get value>> [
+    validation-messages get
-        <span "error" =class span>
+    dup empty? [ drop ] [
-            escape-string write
+        <ul "errors" =class ul>
-        </span>
+            [ <li> message>> escape-string write </li> ] each
-    ] when* ;
+        </ul>
-
-TUPLE: action init display submit get-params post-params ;
-
-: <action>
-    action new
-        [ ] >>init
-        [ <400> ] >>display
-        [ <400> ] >>submit ;
-
-:: validate-param ( name validator assoc -- )
-    name assoc at validator with-validator name set ; inline
-
-: action-params ( validators -- error? )
-    validation-failed? off
-    params get '[ , validate-param ] assoc-each
-    validation-failed? get ;
-
-: handle-get ( -- response )
-    action get get-params>> action-params [ <400> ] [
-        action get [ init>> call ] [ display>> call ] bi
     ] if ;
 
-: handle-post ( -- response )
+TUPLE: action rest-param init display validate submit ;
-    action get post-params>> action-params
+
-    [ <400> ] [ action get submit>> call ] if ;
+: new-action ( class -- action )
+    new
+        [ ] >>init
+        [ <400> ] >>display
+        [ ] >>validate
+        [ <400> ] >>submit ;
+
+: <action> ( -- action )
+    action new-action ;
+
+: handle-get ( action -- response )
+    blank-values
+    [ init>> call ]
+    [ display>> call ]
+    bi ;
 
 : validation-failed ( -- * )
-    action get display>> call exit-with ;
+    request get method>> "POST" =
+    [ action get display>> call ] [ <400> ] if exit-with ;
 
-: validation-failed-with ( string -- * )
+: handle-post ( action -- response )
-    validation-message get >box
+    init-validation
-    validation-failed ;
+    blank-values
+    [ validate>> call ]
+    [ submit>> call ] bi ;
+
+: handle-rest-param ( arg -- )
+    dup length 1 > action get rest-param>> not or
+    [ <404> exit-with ] [
+        action get rest-param>> associate rest-param set
+    ] if ;
 
 M: action call-responder* ( path action -- response )
+    dup action set
     '[
-        , [ CHAR: / = ] right-trim empty? [
+        , dup empty? [ drop ] [ handle-rest-param ] if
-            , action set
+
+        init-validation
+        ,
         request get
-            <box> validation-message set
+        [ request-params rest-param get assoc-union params set ]
-            [ request-params params set ]
+        [ method>> ] bi
-            [
+        {
-                method>> {
             { "GET" [ handle-get ] }
             { "HEAD" [ handle-get ] }
             { "POST" [ handle-post ] }
         } case
-            ] bi
-        ] [
-            <404>
-        ] if
     ] with-exit-continuation ;
+
+: param ( name -- value )
+    params get at ;
+
+: check-validation ( -- )
+    validation-failed? [ validation-failed ] when ;
+
+: validate-params ( validators -- )
+    params get swap validate-values from-assoc
+    check-validation ;
+
+: validate-integer-id ( -- )
+    { { "id" [ v-number ] } } validate-params ;
+
+TUPLE: page-action < action template ;
+
+: <page-action> ( -- page )
+    page-action new-action
+        dup '[ , template>> <html-content> ] >>display ;
+
+TUPLE: feed-action < action feed ;
+
+: <feed-action> ( -- feed )
+    feed-action new
+        dup '[ , feed>> call <feed-content> ] >>display ;

extra/http/server/auth/admin/admin.factor

@@ -1,179 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences accessors namespaces combinators words
-assocs locals db.tuples arrays splitting strings qualified
-
-http.server.templating.chloe
-http.server.boilerplate
-http.server.auth.providers
-http.server.auth.providers.db
-http.server.auth.login
-http.server.auth
-http.server.forms
-http.server.components.inspector
-http.server.validators
-http.server.sessions
-http.server.actions
-http.server.crud
-http.server ;
-EXCLUDE: http.server.components => string? number? ;
-IN: http.server.auth.admin
-
-: admin-template ( name -- template )
-    "resource:extra/http/server/auth/admin/" swap ".xml" 3append <chloe> ;
-
-: words>strings ( seq -- seq' )
-    [ [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ] map ;
-
-: strings>words ( seq -- seq' )
-    [ ":" split1 swap lookup ] map ;
-
-: <capabilities> ( id -- component )
-    capabilities get words>strings <menu> ;
-
-: <new-user-form> ( -- form )
-    "user" <form>
-        "new-user" admin-template >>edit-template
-        "username" <string> add-field
-        "realname" <string> add-field
-        "new-password" <password> t >>required add-field
-        "verify-password" <password> t >>required add-field
-        "email" <email> add-field
-        "capabilities" <capabilities> add-field ;
-
-: <edit-user-form> ( -- form )
-    "user" <form>
-        "edit-user" admin-template >>edit-template
-        "user-summary" admin-template >>summary-template
-        "username" <string> hidden >>renderer add-field
-        "realname" <string> add-field
-        "new-password" <password> add-field
-        "verify-password" <password> add-field
-        "email" <email> add-field
-        "profile" <inspector> add-field
-        "capabilities" <capabilities> add-field ;
-
-: <user-list-form> ( -- form )
-    "user-list" <form>
-        "user-list" admin-template >>view-template
-        "list" <edit-user-form> +unordered+ <list> add-field ;
-
-:: <new-user-action> ( form ctor next -- action )
-    <action>
-        [
-            blank-values
-
-            "username" get ctor call
-
-            {
-                [ username>> "username" set-value ]
-                [ realname>> "realname" set-value ]
-                [ email>> "email" set-value ]
-                [ profile>> "profile" set-value ]
-            } cleave
-        ] >>init
-
-        [ form edit-form ] >>display
-
-        [
-            blank-values
-
-            form validate-form
-
-            same-password-twice
-
-            user new "username" value >>username select-tuple
-            [ user-exists ] when
-
-            "username" value <user>
-                "realname" value >>realname
-                "email" value >>email
-                "new-password" value >>encoded-password
-                H{ } clone >>profile
-
-            insert-tuple
-
-            next f <standard-redirect>
-        ] >>submit ;
-    
-:: <edit-user-action> ( form ctor next -- action )
-    <action>
-        { { "username" [ v-required ] } } >>get-params
-
-        [
-            blank-values
-
-            "username" get ctor call select-tuple
-
-            {
-                [ username>> "username" set-value ]
-                [ realname>> "realname" set-value ]
-                [ email>> "email" set-value ]
-                [ profile>> "profile" set-value ]
-                [ capabilities>> words>strings "capabilities" set-value ]
-            } cleave
-        ] >>init
-
-        [ form edit-form ] >>display
-
-        [
-            blank-values
-
-            form validate-form
-
-            "username" value <user> select-tuple
-                "realname" value >>realname
-                "email" value >>email
-
-            { "new-password" "verify-password" }
-            [ value empty? ] all? [
-                same-password-twice
-                "new-password" value >>encoded-password
-            ] unless
-
-            "capabilities" value {
-                { [ dup string? ] [ 1array ] }
-                { [ dup array? ] [ ] }
-            } cond strings>words >>capabilities
-
-            update-tuple
-
-            next f <standard-redirect>
-        ] >>submit ;
-
-:: <delete-user-action> ( ctor next -- action )
-    <action>
-        { { "username" [ ] } } >>post-params
-
-        [
-            "username" get
-            [ <user> select-tuple 1 >>deleted update-tuple ]
-            [ logout-all-sessions ]
-            bi
-
-            next f <standard-redirect>
-        ] >>submit ;
-
-TUPLE: user-admin < dispatcher ;
-
-SYMBOL: can-administer-users?
-
-can-administer-users? define-capability
-
-:: <user-admin> ( -- responder )
-    [let | ctor [ [ <user> ] ] |
-        user-admin new-dispatcher
-            <user-list-form> ctor <list-action> "" add-responder
-            <new-user-form> ctor "$user-admin" <new-user-action> "new" add-responder
-            <edit-user-form> ctor "$user-admin" <edit-user-action> "edit" add-responder
-            ctor "$user-admin" <delete-user-action> "delete" add-responder
-        <boilerplate>
-            "admin" admin-template >>template
-        { can-administer-users? } <protected>
-    ] ;
-
-: make-admin ( username -- )
-    <user>
-    select-tuple
-    [ can-administer-users? suffix ] change-capabilities
-    update-tuple ;

extra/http/server/auth/admin/user-list.xml

@@ -1,9 +0,0 @@
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
-	<t:title>Users</t:title>
-
-	<t:summary t:component="list" />
-
-</t:chloe>

extra/http/server/auth/admin/user-summary.xml

@@ -1,9 +0,0 @@
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
-	<t:a t:href="$user-admin/edit" t:query="username">
-		<t:view t:component="username" />
-	</t:a>
-
-</t:chloe>

extra/http/server/auth/auth.factor

@@ -1,6 +1,6 @@
 ! Copyright (c) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs namespaces kernel sequences
+USING: accessors assocs namespaces kernel sequences sets
 http.server
 http.server.sessions
 http.server.auth.providers ;
@@ -38,4 +38,4 @@ SYMBOL: capabilities
 
 V{ } clone capabilities set-global
 
-: define-capability ( word -- ) capabilities get push-new ;
+: define-capability ( word -- ) capabilities get adjoin ;

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

@@ -10,12 +10,12 @@
 	
 	<tr>
 		<th class="field-label">User name:</th>
-		<td><t:view t:component="username" /></td>
+		<td><t:label t:name="username" /></td>
 	</tr>
 	
 	<tr>
 		<th class="field-label">Real name:</th>
-		<td><t:edit t:component="realname" /></td>
+		<td><t:field t:name="realname" /></td>
 	</tr>
 	
 	<tr>
@@ -25,7 +25,7 @@
 	
 	<tr>
 		<th class="field-label">Current password:</th>
-		<td><t:edit t:component="password" /></td>
+		<td><t:password t:name="password" /></td>
 	</tr>
 	
 	<tr>
@@ -35,12 +35,12 @@
 	
 	<tr>
 		<th class="field-label">New password:</th>
-		<td><t:edit t:component="new-password" /></td>
+		<td><t:password t:name="new-password" /></td>
 	</tr>
 	
 	<tr>
 		<th class="field-label">Verify:</th>
-		<td><t:edit t:component="verify-password" /></td>
+		<td><t:password t:name="verify-password" /></td>
 	</tr>
 	
 	<tr>
@@ -50,7 +50,7 @@
 	
 	<tr>
 		<th class="field-label">E-mail:</th>
-		<td><t:edit t:component="email" /></td>
+		<td><t:field t:name="email" /></td>
 	</tr>
 	
 	<tr>
@@ -62,7 +62,7 @@
 
 	<p>
 		<input type="submit" value="Update" />
-		<t:validation-message />
+		<t:validation-messages />
 	</p>
 
 	</t:form>

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

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors quotations assocs kernel splitting
 combinators sequences namespaces hashtables sets
-fry arrays threads locals qualified random
+fry arrays threads qualified random validators
 io
 io.sockets
 io.encodings.utf8
@@ -12,23 +12,22 @@ continuations
 destructors
 checksums
 checksums.sha2
+validators
+html.components
 html.elements
+html.templates
+html.templates.chloe
 http
 http.server
 http.server.auth
 http.server.auth.providers
 http.server.auth.providers.db
 http.server.actions
-http.server.components
 http.server.flows
-http.server.forms
 http.server.sessions
-http.server.boilerplate
+http.server.boilerplate ;
-http.server.templating
-http.server.templating.chloe
-http.server.validators ;
-IN: http.server.auth.login
 QUALIFIED: smtp
+IN: http.server.auth.login
 
 TUPLE: login < dispatcher users checksum ;
 
@@ -65,80 +64,60 @@ M: user-saver dispose
     3append <chloe> ;
 
 ! ! ! Login
-
-: <login-form>
-    "login" <form>
-        "login" login-template >>edit-template
-        "username" <username>
-            t >>required
-            add-field
-        "password" <password>
-            t >>required
-            add-field ;
-
 : successful-login ( user -- response )
-    username>> set-uid
+    username>> set-uid "$login" end-flow ;
-    "$login" end-flow ;
 
-: login-failed "invalid username or password" validation-failed-with ;
+: login-failed ( -- * )
+    "invalid username or password" validation-error
+    validation-failed ;
 
-:: <login-action> ( -- action )
+: <login-action> ( -- action )
-    [let | form [ <login-form> ] |
     <action>
-            [ blank-values ] >>init
+        [ "login" login-template <html-content> ] >>display
-
-            [ form edit-form ] >>display
 
         [
-                blank-values
+            {
+                { "username" [ v-required ] }
+                { "password" [ v-required ] }
+            } validate-params
 
-                form validate-form
+            "password" value
-
+            "username" value check-login
-                "password" value "username" value check-login
             [ successful-login ] [ login-failed ] if*
-            ] >>submit
+        ] >>submit ;
-    ] ;
 
 ! ! ! New user registration
 
-: <register-form> ( -- form )
+: user-exists ( -- * )
-    "register" <form>
+    "username taken" validation-error
-        "register" login-template >>edit-template
+    validation-failed ;
-        "username" <username>
-            t >>required
-            add-field
-        "realname" <string> add-field
-        "new-password" <password>
-            t >>required
-            add-field
-        "verify-password" <password>
-            t >>required
-            add-field
-        "email" <email> add-field
-        "captcha" <captcha> add-field ;
 
-: password-mismatch "passwords do not match" validation-failed-with ;
+: password-mismatch ( -- * )
-
+    "passwords do not match" validation-error
-: user-exists "username taken" validation-failed-with ;
+    validation-failed ;
 
 : same-password-twice ( -- )
     "new-password" value "verify-password" value =
     [ password-mismatch ] unless ;
 
-:: <register-action> ( -- action )
+: <register-action> ( -- action )
-    [let | form [ <register-form> ] |
+    <page-action>
-        <action>
+        "register" login-template >>template
-            [ blank-values ] >>init
-
-            [ form edit-form ] >>display
 
         [
-                blank-values
+            {
-
+                { "username" [ v-username ] }
-                form validate-form
+                { "realname" [ [ v-one-line ] v-optional ] }
+                { "new-password" [ v-password ] }
+                { "verify-password" [ v-password ] }
+                { "email" [ [ v-email ] v-optional ] }
+                { "captcha" [ v-captcha ] }
+            } validate-params
 
             same-password-twice
+        ] >>validate
 
+        [
             "username" value <user>
                 "realname" value >>realname
                 "new-password" value >>encoded-password
@@ -147,30 +126,16 @@ M: user-saver dispose
 
             users new-user [ user-exists ] unless*
 
-                successful-login
-
             login get init-user-profile
-            ] >>submit
+
-    ] ;
+            successful-login
+        ] >>submit ;
 
 ! ! ! Editing user profile
 
-: <edit-profile-form> ( -- form )
+: <edit-profile-action> ( -- action )
-    "edit-profile" <form>
-        "edit-profile" login-template >>edit-template
-        "username" <username> add-field
-        "realname" <string> add-field
-        "password" <password> add-field
-        "new-password" <password> add-field
-        "verify-password" <password> add-field
-        "email" <email> add-field ;
-
-:: <edit-profile-action> ( -- action )
-    [let | form [ <edit-profile-form> ] |
     <action>
         [
-                blank-values
-
             logged-in-user get
             [ username>> "username" set-value ]
             [ realname>> "realname" set-value ]
@@ -178,25 +143,33 @@ M: user-saver dispose
             tri
         ] >>init
 
-            [ form edit-form ] >>display
+        [ "edit-profile" login-template <html-content> ] >>display
 
         [
-                blank-values
             uid "username" set-value
 
-                form validate-form
+            {
-
+                { "realname" [ [ v-one-line ] v-optional ] }
-                logged-in-user get
+                { "password" [ ] }
+                { "new-password" [ [ v-password ] v-optional ] }
+                { "verify-password" [ [ v-password ] v-optional ] } 
+                { "email" [ [ v-email ] v-optional ] }
+            } validate-params
 
             { "password" "new-password" "verify-password" }
-                [ value empty? ] all? [
+            [ value empty? not ] contains? [
-                    same-password-twice
-
                 "password" value uid check-login
-                    [ login-failed ] unless
+                [ "incorrect password" validation-error ] unless
 
-                    "new-password" value >>encoded-password
+                same-password-twice
-                ] unless
+            ] when
+        ] >>validate
+
+        [
+            logged-in-user get
+
+            "new-password" value dup empty?
+            [ drop ] [ >>encoded-password ] if
 
             "realname" value >>realname
             "email" value >>email
@@ -206,8 +179,7 @@ M: user-saver dispose
             drop
 
             "$login" end-flow
-            ] >>submit
+        ] >>submit ;
-    ] ;
 
 ! ! ! Password recovery
 
@@ -250,92 +222,61 @@ SYMBOL: lost-password-from
     '[ , password-email smtp:send-email ]
     "E-mail send thread" spawn drop ;
 
-: <recover-form-1> ( -- form )
+: <recover-action-1> ( -- action )
-    "register" <form>
-        "recover-1" login-template >>edit-template
-        "username" <username>
-            t >>required
-            add-field
-        "email" <email>
-            t >>required
-            add-field
-        "captcha" <captcha> add-field ;
-
-:: <recover-action-1> ( -- action )
-    [let | form [ <recover-form-1> ] |
     <action>
-            [ blank-values ] >>init
+        [ "recover-1" login-template <html-content> ] >>display
-
-            [ form edit-form ] >>display
 
         [
-                blank-values
+            {
-
+                { "username" [ v-username ] }
-                form validate-form
+                { "email" [ v-email ] }
+                { "captcha" [ v-captcha ] }
+            } validate-params
+        ] >>validate
 
+        [
             "email" value "username" value
             users issue-ticket [
                 send-password-email
             ] when*
 
-                "recover-2" login-template serve-template
+            "recover-2" login-template <html-content>
-            ] >>submit
+        ] >>submit ;
-    ] ;
 
-: <recover-form-3>
+: <recover-action-3> ( -- action )
-    "new-password" <form>
-        "recover-3" login-template >>edit-template
-        "username" <username>
-            hidden >>renderer
-            t >>required
-            add-field
-        "new-password" <password>
-            t >>required
-            add-field
-        "verify-password" <password>
-            t >>required
-            add-field
-        "ticket" <string>
-            hidden >>renderer
-            t >>required
-            add-field ;
-
-:: <recover-action-3> ( -- action )
-    [let | form [ <recover-form-3> ] |
     <action>
         [
-                { "username" [ v-required ] }
+            {
+                { "username" [ v-username ] }
                 { "ticket" [ v-required ] }
-            ] >>get-params
+            } validate-params
-
-            [
-                [
-                    "username" [ get ] keep set
-                    "ticket" [ get ] keep set
-                ] H{ } make-assoc values set
         ] >>init
 
-            [ <recover-form-3> edit-form ] >>display
+        [ "recover-3" login-template <html-content> ] >>display
 
         [
-                blank-values
+            {
-
+                { "username" [ v-username ] }
-                form validate-form
+                { "ticket" [ v-required ] }
+                { "new-password" [ v-password ] }
+                { "verify-password" [ v-password ] }
+            } validate-params
 
             same-password-twice
+        ] >>validate
 
+        [
             "ticket" value
             "username" value
             users claim-ticket [
                 "new-password" value >>encoded-password
                 users update-user
 
-                    "recover-4" login-template serve-template
+                "recover-4" login-template <html-content>
             ] [
                 <400>
             ] if*
-            ] >>submit
+        ] >>submit ;
-    ] ;
 
 ! ! ! Logout
 : <logout-action> ( -- action )

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

@@ -10,12 +10,12 @@
 
 			<tr>
 				<th class="field-label">User name:</th>
-				<td><t:edit t:component="username" /></td>
+				<td><t:field t:name="username" /></td>
 			</tr>
 
 			<tr>
 				<th class="field-label">Password:</th>
-				<td><t:edit t:component="password" /></td>
+				<td><t:password t:name="password" /></td>
 			</tr>
 
 		</table>
@@ -23,7 +23,7 @@
 		<p>
 
 			<input type="submit" value="Log in" />
-			<t:validation-message />
+			<t:validation-messages />
 
 		</p>