Merge branch 'master' into experimental

basis/alarms/summary.txt

@@ -0,0 +1 @@
+One-time and recurring events

basis/alias/summary.txt

@@ -0,0 +1 @@
+Defining multiple words with the same name

basis/ascii/ascii-docs.factor

@@ -46,6 +46,6 @@ ARTICLE: "ascii" "ASCII character classes"
 { $subsection printable? }
 { $subsection control? }
 { $subsection quotable? }
-"Modern applications should use Unicode 5.0 instead (" { $vocab-link "unicode" } ")." ;
+"Modern applications should use Unicode 5.0 instead (" { $vocab-link "unicode.categories" } ")." ;
 
 ABOUT: "ascii"

basis/binary-search/summary.txt

@@ -0,0 +1 @@
+Fast searching of sorted arrays

basis/bootstrap/image/image.factor

@@ -26,7 +26,6 @@ IN: bootstrap.image
         "x86.32"
         "x86.64"
         "linux-ppc" "macosx-ppc"
-        ! "arm"
     } ;
 
 <PRIVATE
@@ -412,14 +411,14 @@ M: quotation '
     all-words [ emit-word ] each ;
 
 : emit-global ( -- )
-    [
+    {
-        {
+        dictionary source-files builtins
-            dictionary source-files builtins
+        update-map implementors-map
-            update-map implementors-map class<=-cache
+    } [ [ bootstrap-word ] [ get ] bi ] H{ } map>assoc
-            class-not-cache classes-intersect-cache class-and-cache
+    {
-            class-or-cache
+        class<=-cache class-not-cache classes-intersect-cache
-        } [ dup get swap bootstrap-word set ] each
+        class-and-cache class-or-cache next-method-quot-cache
-    ] H{ } make-assoc
+    } [ H{ } clone ] H{ } map>assoc assoc-union
     bootstrap-global set
     bootstrap-global emit-userenv ;
 

basis/bootstrap/random/random.factor

@@ -13,4 +13,4 @@ IN: bootstrap.random
 [
     [ 32 random-bits ] with-system-random
     <mersenne-twister> random-generator set-global
-] "generator.random" add-init-hook
+] "bootstrap.random" add-init-hook

basis/boxes/summary.txt

@@ -0,0 +1 @@
+An abstraction for enforcing a mutual-exclusion invariant

basis/calendar/calendar-docs.factor

@@ -21,8 +21,8 @@ HELP: <date>
 { $description "Returns a timestamp object representing the start of the specified day in your current timezone." }
 { $examples
     { $example "USING: calendar prettyprint ;"
-               "2010 12 25 <date> ."
+               "2010 12 25 <date> >gmt midnight ."
-               "T{ timestamp\n    { year 2010 }\n    { month 12 }\n    { day 25 }\n    { gmt-offset T{ duration { hour -5 } } }\n}"
+               "T{ timestamp { year 2010 } { month 12 } { day 25 } }"
     }
 } ;
 

basis/calendar/format/format-tests.factor

@@ -62,3 +62,15 @@ IN: calendar.format.tests
         T{ duration f 0 0 0 -5 0 0 }
     }
 ] [ "2008-05-26T00:37:42.12345-05:00" rfc3339>timestamp ] unit-test
+
+[
+    T{ timestamp
+        { year 2008 }
+        { month 10 }
+        { day 2 }
+        { hour 23 }
+        { minute 59 }
+        { second 59 }
+        { gmt-offset T{ duration f 0 0 0 0 0 0 } }
+    }
+] [ "Thursday, 02-Oct-2008 23:59:59 GMT" cookie-string>timestamp ] unit-test

basis/calendar/format/format.factor

@@ -201,9 +201,13 @@ ERROR: invalid-timestamp-format ;
 : rfc822>timestamp ( str -- timestamp )
     [ (rfc822>timestamp) ] with-string-reader ;
 
+: check-day-name ( str -- )
+    [ day-abbreviations3 member? ] [ day-names member? ] bi or
+    check-timestamp drop ;
+
 : (cookie-string>timestamp-1) ( -- timestamp )
     timestamp new
-        "," read-token day-abbreviations3 member? check-timestamp drop
+        "," read-token check-day-name
         read1 CHAR: \s assert=
         "-" read-token checked-number >>day
         "-" read-token month-abbreviations index 1+ check-timestamp >>month
@@ -218,7 +222,7 @@ ERROR: invalid-timestamp-format ;
 
 : (cookie-string>timestamp-2) ( -- timestamp )
     timestamp new
-        read-sp day-abbreviations3 member? check-timestamp drop
+        read-sp check-day-name
         read-sp month-abbreviations index 1+ check-timestamp >>month
         read-sp checked-number >>day
         ":" read-token checked-number >>hour

basis/channels/remote/tags.txt

@@ -1 +1 @@
-extensions
+concurrency

basis/channels/tags.txt

@@ -1 +1 @@
-extensions
+concurrency

basis/circular/circular-docs.factor

@@ -43,7 +43,7 @@ HELP: push-growing-circular
      { "elt" object } { "circular" circular } }
 { $description "Pushes an element onto a " { $link growing-circular } " object." } ;
 
-ARTICLE: "circular" "circular"
+ARTICLE: "circular" "Circular sequences"
 "The " { $vocab-link "circular" } " vocabulary implements the " { $link "sequence-protocol" } " to allow an arbitrary start index and wrap-around indexing." $nl
 "Creating a new circular object:"
 { $subsection <circular> }

basis/cocoa/cocoa-docs.factor

@@ -19,7 +19,7 @@ HELP: SUPER->
 ARTICLE: "objc-calling" "Calling Objective C code"
 "Before an Objective C class can be used, it must be imported; by default, a small set of common classes are imported automatically, but additional classes can be imported as needed."
 { $subsection import-objc-class }
-"Every imported Objective C class has as corresponding class word in the " { $vocab-link "objc-classes" } " vocabulary. Class words push the class object in the stack, allowing class methods to be invoked."
+"Every imported Objective C class has as corresponding class word in the " { $vocab-link "cocoa.classes" } " vocabulary. Class words push the class object in the stack, allowing class methods to be invoked."
 $nl
 "Messages can be sent to classes and instances using a pair of parsing words:"
 { $subsection POSTPONE: -> }

basis/colors/summary.txt

@@ -0,0 +1 @@
+Colors as a first-class data type

basis/combinators/short-circuit/short-circuit-docs.factor

@@ -64,7 +64,7 @@ HELP: n||-rewrite
      { "quot" quotation } }
 { $description "A macro that reqrites the code to pass " { $snippet "N" } " parameters from the stack to each OR quotation." } ;
 
-ARTICLE: "combinators.short-circuit" "combinators.short-circuit"
+ARTICLE: "combinators.short-circuit" "Short-circuit combinators"
 "The " { $vocab-link "combinators.short-circuit" } " vocabulary stops a computation early once a condition is met." $nl
 "AND combinators:"
 { $subsection 0&& }

basis/combinators/short-circuit/smart/smart-docs.factor

@@ -27,8 +27,9 @@ HELP: ||
     }
 } ;
 
-ARTICLE: "combinators.short-circuit.smart" "combinators.short-circuit.smart"
+ARTICLE: "combinators.short-circuit.smart" "Smart short-circuit combinators"
-"The " { $vocab-link "combinators.short-circuit.smart" } " vocabulary infers the number of inputs that the sequence of quotations takes." $nl
+"The " { $vocab-link "combinators.short-circuit.smart" } " vocabulary is similar to " { $vocab-link "combinators.short-circuit" } " except the combinators here infer the number of inputs that the sequence of quotations takes."
+$nl
 "Generalized AND:"
 { $subsection && }
 "Generalized OR:"

basis/compiler/generator/generator-docs.factor

@@ -4,7 +4,7 @@ kernel vectors arrays effects sequences ;
 IN: compiler.generator
 
 ARTICLE: "generator" "Compiled code generator"
-"Most of the words in the " { $vocab-link "generator" } " vocabulary are internal to the compiler and user code has no reason to call them."
+"Most of the words in the " { $vocab-link "compiler.generator" } " vocabulary are internal to the compiler and user code has no reason to call them."
 $nl
 "Debugging information can be enabled or disabled; this hook is used by " { $link "tools.deploy" } ":"
 { $subsection compiled-stack-traces? }

basis/compiler/intrinsics/intrinsics.factor

@@ -4,20 +4,42 @@ USING: kernel classes.tuple classes.tuple.private math arrays
 byte-arrays words stack-checker.known-words ;
 IN: compiler.intrinsics
 
-: (tuple) ( layout -- tuple )
+ERROR: missing-intrinsic ;
-    "BUG: missing (tuple) intrinsic" throw ;
+
+: (tuple) ( n -- tuple ) missing-intrinsic ;
 
 \ (tuple) { tuple-layout } { tuple } define-primitive
 \ (tuple) make-flushable
 
-: (array) ( n -- array )
+: (array) ( n -- array ) missing-intrinsic ;
-    "BUG: missing (array) intrinsic" throw ;
 
 \ (array) { integer } { array } define-primitive
 \ (array) make-flushable
 
-: (byte-array) ( n -- byte-array )
+: (byte-array) ( n -- byte-array ) missing-intrinsic ;
-    "BUG: missing (byte-array) intrinsic" throw ;
 
 \ (byte-array) { integer } { byte-array } define-primitive
 \ (byte-array) make-flushable
+
+: (ratio) ( -- ratio ) missing-intrinsic ;
+
+\ (ratio) { } { ratio } define-primitive
+\ (ratio) make-flushable
+
+: (complex) ( -- complex ) missing-intrinsic ;
+
+\ (complex) { } { complex } define-primitive
+\ (complex) make-flushable
+
+: (wrapper) ( -- wrapper ) missing-intrinsic ;
+
+\ (wrapper) { } { wrapper } define-primitive
+\ (wrapper) make-flushable
+
+: (set-slot) ( val obj n -- ) missing-intrinsic ;
+
+\ (set-slot) { object object fixnum } { } define-primitive
+
+: (write-barrier) ( obj -- ) missing-intrinsic ;
+
+\ (write-barrier) { object } { } define-primitive

basis/compiler/tree/propagation/info/info.factor

@@ -298,6 +298,12 @@ SYMBOL: value-infos
 : node-output-infos ( node -- seq )
     dup out-d>> [ node-value-info ] with map ;
 
+: first-literal ( #call -- obj )
+    dup in-d>> first node-value-info literal>> ;
+
+: last-literal ( #call -- obj )
+    dup out-d>> peek node-value-info literal>> ;
+
 : immutable-tuple-boa? ( #call -- ? )
     dup word>> \ <tuple-boa> eq? [
         dup in-d>> peek node-value-info

basis/concurrency/combinators/tags.txt

@@ -0,0 +1 @@
+concurrency

basis/concurrency/conditions/tags.txt

@@ -0,0 +1 @@
+concurrency

basis/concurrency/count-downs/tags.txt

@@ -0,0 +1 @@
+concurrency

basis/concurrency/distributed/tags.txt

@@ -1,2 +1,2 @@
+concurrency
 enterprise
-extensions

basis/concurrency/exchangers/tags.txt

@@ -0,0 +1 @@
+concurrency

basis/concurrency/flags/tags.txt

@@ -0,0 +1 @@
+concurrency

basis/concurrency/futures/tags.txt

@@ -0,0 +1 @@
+concurrency

basis/concurrency/locks/tags.txt

@@ -0,0 +1 @@
+concurrency

basis/concurrency/mailboxes/tags.txt

@@ -0,0 +1 @@
+concurrency

basis/concurrency/messaging/tags.txt

@@ -0,0 +1 @@
+concurrency

basis/concurrency/promises/tags.txt

@@ -0,0 +1 @@
+concurrency

basis/concurrency/semaphores/tags.txt

@@ -0,0 +1 @@
+concurrency

basis/core-foundation/fsevents/fsevents.factor

@@ -3,13 +3,10 @@
 USING: alien alien.c-types alien.strings alien.syntax kernel
 math sequences namespaces make assocs init accessors
 continuations combinators core-foundation
-core-foundation.run-loop io.encodings.utf8 destructors ;
+core-foundation.run-loop core-foundation.run-loop.thread
+io.encodings.utf8 destructors ;
 IN: core-foundation.fsevents
 
-! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
-! FSEventStream API, Leopard only !
-! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
-
 : kFSEventStreamCreateFlagUseCFTypes 2 ; inline
 : kFSEventStreamCreateFlagWatchRoot 4 ; inline
 

basis/core-foundation/run-loop/run-loop.factor

@@ -35,5 +35,3 @@ FUNCTION: SInt32 CFRunLoopRunInMode (
 
 : start-run-loop-thread ( -- )
     [ run-loop-thread t ] "CFRunLoop dispatcher" spawn-server drop ;
-
-[ start-run-loop-thread ] "core-foundation.run-loop" add-init-hook

basis/core-foundation/run-loop/thread/thread.factor

@@ -0,0 +1,8 @@
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: init core-foundation.run-loop ;
+IN: core-foundation.run-loop.thread
+
+! Load this vocabulary if you need a run loop running.
+
+[ start-run-loop-thread ] "core-foundation.run-loop.thread" add-init-hook

basis/db/db-docs.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: classes kernel help.markup help.syntax sequences
-alien assocs strings math multiline ;
+alien assocs strings math multiline quotations ;
 IN: db
 
 HELP: db
@@ -45,7 +45,22 @@ HELP: prepared-statement
 { $description } ;
 
 HELP: result-set
-{ $description } ;
+{ $description "An object encapsulating a raw SQL result object. There are two ways in which a result set can be accessed, but they are specific to the database backend in use."
+    { $subsection "db-random-access-result-set" }
+    { $subsection "db-sequential-result-set" }
+} ;
+
+HELP: init-result-set
+{ $values
+     { "result-set" result-set } }
+{ $description "" } ;
+
+HELP: new-result-set
+{ $values
+     { "query" "a query" } { "handle" alien } { "class" class }
+     { "result-set" result-set } }
+{ $description "Creates a new " { $link result-set } " object of type " { $snippet "class" } "." } ;
+
 
 HELP: new-statement
 { $values { "sql" string } { "in" sequence } { "out" sequence } { "class" class } { "statement" statement } }
@@ -81,7 +96,7 @@ HELP: query-results
 { $values { "query" object }
     { "result-set" result-set }
 }
-{ $description "" } ;
+{ $description "Returns a " { $link result-set } " object representing the reults of a SQL query." } ;
 
 HELP: #rows
 { $values { "result-set" result-set } { "n" integer } }
@@ -95,36 +110,126 @@ HELP: row-column
 { $values { "result-set" result-set } { "column" integer }
     { "obj" object }
 }
-{ $description "" } ;
+{ $description "Returns the value indexed by " { $snippet "column" } " in the current row of a " { $link result-set } "." } ;
 
 HELP: row-column-typed
 { $values { "result-set" result-set } { "column" integer }
     { "sql" "sql" } }
-{ $description "" } ;
+{ $description "Returns the value indexed by " { $snippet "column" } " in the current row of a " { $link result-set } " and converts the result based on a type stored in the " { $link result-set } "'s " { $slot "out-params" } "." } ;
 
 HELP: advance-row
 { $values { "result-set" result-set } }
-;
+{ $description "Advanced the pointer to an underlying SQL result set stored in a " { $link result-set } " object." } ;
 
 HELP: more-rows?
 { $values { "result-set" result-set } { "?" "a boolean" } }
-;
+{ $description "Returns true if the " { $link result-set } " has more rows to traverse." } ;
 
 HELP: execute-statement*
 { $values { "statement" statement } { "type" object } }
 { $description } ;
 
+HELP: execute-one-statement
+{ $values
+     { "statement" null } }
+{ $description "" } ;
+
 HELP: execute-statement
 { $values { "statement" statement } }
-{ $description } ;
+{ $description "" } ;
 
-ARTICLE: "db" "Low-level database library"
+
+
+
+
+
+HELP: begin-transaction
+{ $description "Begins a new transaction. User code should make use of the " { $link with-transaction } " combinator." } ;
+
+HELP: bind-statement
+{ $values
+     { "obj" object } { "statement" null } }
+{ $description "" } ;
+
+HELP: commit-transaction
+{ $description "Commits a transaction. User code should make use of the " { $link with-transaction } " combinator." } ;
+
+HELP: default-query
+{ $values
+     { "query" null }
+     { "result-set" null } }
+{ $description "" } ;
+
+HELP: in-transaction
+{ $description "A variable that is set true when a transaction is in progress." } ;
+
+HELP: in-transaction?
+{ $values
+     { "?" "a boolean" } }
+{ $description "Returns true if there is currently a transaction in progress in this scope." } ;
+
+HELP: query-each
+{ $values
+     { "statement" null } { "quot" quotation } }
+{ $description "" } ;
+
+HELP: query-map
+{ $values
+     { "statement" null } { "quot" quotation }
+     { "seq" sequence } }
+{ $description "" } ;
+
+HELP: rollback-transaction
+{ $description "Rolls back a transaction; no data is committed to the database. User code should make use of the " { $link with-transaction } " combinator." } ;
+
+HELP: sql-command
+{ $values
+     { "sql" string } }
+{ $description "Executes a SQL string using the databse in the " { $link db } " symbol." } ;
+
+HELP: sql-query
+{ $values
+     { "sql" string }
+     { "rows" "an array of arrays of strings" } }
+{ $description "Runs a SQL query of raw text in the database in the " { $link db } " symbol. Each row is returned as an array of strings; no type-conversions are done on the resulting data." } ;
+
+{ sql-command sql-query } related-words
+
+HELP: sql-row
+{ $values
+     { "result-set" result-set }
+     { "seq" sequence } }
+{ $description "Returns the current row in a " { $link result-set } " as an array of strings." } ;
+
+HELP: sql-row-typed
+{ $values
+     { "result-set" result-set }
+     { "seq" sequence } }
+{ $description "Returns the current row in a " { $link result-set } " as an array of typed Factor objects." } ;
+
+{ sql-row sql-row-typed } related-words
+
+HELP: with-db
+{ $values
+     { "seq" sequence } { "class" class } { "quot" quotation } }
+{ $description "Calls the quotation with a database bound to the " { $link db } " symbol. The database called is based on the " { $snippet "class" } " with the " } ;
+
+HELP: with-transaction
+{ $values
+     { "quot" quotation } }
+{ $description "" } ;
+
+ARTICLE: "db" "Database library"
 { $subsection "db-custom-database-combinators" }
 { $subsection "db-protocol" }
+{ $subsection "db-result-sets" }
 { $subsection "db-lowlevel-tutorial" }
 "Higher-level database:"
 { $vocab-subsection "Database types" "db.types" }
 { $vocab-subsection "High-level tuple/database integration" "db.tuples" }
+! { $subsection "db-tuples" }
+! { $subsection "db-tuples-protocol" }
+! { $subsection "db-tuples-tutorial" }
 "Supported database backends:"
 { $vocab-subsection "SQLite" "db.sqlite" }
 { $vocab-subsection "PostgreSQL" "db.postgresql" }
@@ -132,6 +237,40 @@ ARTICLE: "db" "Low-level database library"
 { $subsection "db-porting-the-library" }
 ;
 
+ARTICLE: "db-random-access-result-set" "Random access result sets"
+"Random-access result sets do not have to be traversed in order. For instance, PostgreSQL's result set object can be accessed as a matrix with i,j coordinates."
+$nl
+"Databases which work in this way must provide methods for the following traversal words:"
+{ $subsection #rows }
+{ $subsection #columns }
+{ $subsection row-column }
+{ $subsection row-column-typed } ;
+
+ARTICLE: "db-sequential-result-set" "Sequential result sets"
+"Sequential result sets can be iterated one element after the next.  SQLite's result sets offer this method of traversal."
+$nl
+"Databases which work in this way must provide methods for the following traversal words:"
+{ $subsection more-rows? }
+{ $subsection advance-row }
+{ $subsection row-column }
+{ $subsection row-column-typed } ;
+
+ARTICLE: "db-result-sets" "Result sets"
+"Result sets are the encapsulated, database-specific results from a SQL query."
+$nl
+"Two possible protocols for iterating over result sets exist:"
+{ $subsection "db-random-access-result-set" }
+{ $subsection "db-sequential-result-set" }
+"Query the number of rows or columns:"
+{ $subsection #rows }
+{ $subsection #columns }
+"Traversing a result set:"
+{ $subsection advance-row }
+{ $subsection more-rows? }
+"Pulling out a single row of results:"
+{ $subsection row-column }
+{ $subsection row-column-typed } ;
+
 ARTICLE: "db-protocol" "Low-level database protocol"
 "The high-level protocol (see " { $vocab-link "db.tuples" } ") uses this low-level protocol for executing statements and queries."
 ;
@@ -144,7 +283,6 @@ ARTICLE: "db-porting-the-library" "Porting the database library"
 "This section is not yet written."
 ;
 
-
 ARTICLE: "db-custom-database-combinators" "Custom database combinators"
 "Every database library requires some effort on the programmer's part to initialize and open a database.  SQLite uses files on your harddisk, so a simple pathname is all the setup required. With PostgreSQL, you log in to a networked server as a user on a specfic port." $nl
 
@@ -155,7 +293,6 @@ USING: db.sqlite db io.files ;
     { "my-database.db" temp-file } sqlite-db rot with-db ;
 "> }
 
-
 ;
 
 ABOUT: "db"

basis/db/db.factor

@@ -80,11 +80,14 @@ GENERIC: execute-statement* ( statement type -- )
 M: object execute-statement* ( statement type -- )
     drop query-results dispose ;
 
+: execute-one-statement ( statement -- )
+    dup type>> execute-statement* ;
+
 : execute-statement ( statement -- )
     dup sequence? [
-        [ execute-statement ] each
+        [ execute-one-statement ] each
     ] [
-        dup type>> execute-statement*
+        execute-one-statement
     ] if ;
 
 : bind-statement ( obj statement -- )

basis/db/postgresql/postgresql.factor

@@ -5,7 +5,7 @@ kernel math math.parser namespaces make prettyprint quotations
 sequences debugger db db.postgresql.lib db.postgresql.ffi
 db.tuples db.types tools.annotations math.ranges
 combinators classes locals words tools.walker
-nmake accessors random db.queries destructors ;
+nmake accessors random db.queries destructors db.tuples.private ;
 USE: tools.walker
 IN: db.postgresql
 
@@ -37,8 +37,7 @@ M: postgresql-db db-open ( db -- db )
 M: postgresql-db dispose ( db -- )
     handle>> PQfinish ;
 
-M: postgresql-statement bind-statement* ( statement -- )
+M: postgresql-statement bind-statement* ( statement -- ) drop ;
-    drop ;
 
 GENERIC: postgresql-bind-conversion ( tuple object -- low-level-binding )
 
@@ -67,11 +66,11 @@ M: postgresql-result-set #columns ( result-set -- n )
     [ handle>> ] [ n>> ] bi ;
 
 M: postgresql-result-set row-column ( result-set column -- object )
-    >r result-handle-n r> pq-get-string ;
+    [ result-handle-n ] dip pq-get-string ;
 
 M: postgresql-result-set row-column-typed ( result-set column -- object )
     dup pick out-params>> nth type>>
-    >r >r result-handle-n r> r> postgresql-column-typed ;
+    [ result-handle-n ] 2dip postgresql-column-typed ;
 
 M: postgresql-statement query-results ( query -- result-set )
     dup bind-params>> [
@@ -126,13 +125,20 @@ M: postgresql-db bind# ( spec object -- )
 
 : create-table-sql ( class -- statement )
     [
+        dupd
         "create table " 0% 0%
         "(" 0% [ ", " 0% ] [
             dup column-name>> 0%
             " " 0%
             dup type>> lookup-create-type 0%
             modifiers 0%
-        ] interleave ");" 0%
+        ] interleave
+
+        ", " 0%
+        find-primary-key
+        "primary key(" 0%
+        [ "," 0% ] [ column-name>> 0% ] interleave
+        "));" 0%
     ] query-make ;
 
 : create-function-sql ( class -- statement )
@@ -160,8 +166,7 @@ M: postgresql-db bind# ( spec object -- )
 M: postgresql-db create-sql-statement ( class -- seq )
     [
         [ create-table-sql , ] keep
-        dup db-columns find-primary-key db-assigned-id-spec?
+        dup db-assigned? [ create-function-sql , ] [ drop ] if
-        [ create-function-sql , ] [ drop ] if
     ] { } make ;
 
 : drop-function-sql ( class -- statement )
@@ -181,15 +186,14 @@ M: postgresql-db create-sql-statement ( class -- seq )
 M: postgresql-db drop-sql-statement ( class -- seq )
     [
         [ drop-table-sql , ] keep
-        dup db-columns find-primary-key db-assigned-id-spec?
+        dup db-assigned? [ drop-function-sql , ] [ drop ] if
-        [ drop-function-sql , ] [ drop ] if
     ] { } make ;
 
 M: postgresql-db <insert-db-assigned-statement> ( class -- statement )
     [
         "select add_" 0% 0%
         "(" 0%
-        dup find-primary-key 2,
+        dup find-primary-key first 2,
         remove-id
         [ ", " 0% ] [ bind% ] interleave
         ");" 0%
@@ -218,14 +222,23 @@ M: postgresql-db <insert-user-assigned-statement> ( class -- statement )
         ");" 0%
     ] query-make ;
 
-M: postgresql-db insert-tuple* ( tuple statement -- )
+M: postgresql-db insert-tuple-set-key ( tuple statement -- )
     query-modify-tuple ;
 
 M: postgresql-db persistent-table ( -- hashtable )
     H{
-        { +db-assigned-id+ { "integer" "serial primary key" f } }
+        { +db-assigned-id+ { "integer" "serial" f } }
-        { +user-assigned-id+ { f f "primary key" } }
+        { +user-assigned-id+ { f f f } }
-        { +random-id+ { "bigint" "bigint primary key" f } }
+        { +random-id+ { "bigint" "bigint" f } }
+
+        { +foreign-id+ { f f "references" } }
+
+        { +on-delete+ { f f "on delete" } }
+        { +restrict+ { f f "restrict" } }
+        { +cascade+ { f f "cascade" } }
+        { +set-null+ { f f "set null" } }
+        { +set-default+ { f f "set default" } }
+
         { TEXT { "text" "text" f } }
         { VARCHAR { "varchar" "varchar" f } }
         { INTEGER { "integer" "integer" f } }
@@ -240,7 +253,6 @@ M: postgresql-db persistent-table ( -- hashtable )
         { BLOB { "bytea" "bytea" f } }
         { FACTOR-BLOB { "bytea" "bytea" f } }
         { URL { "varchar" "varchar" f } }
-        { +foreign-id+ { f f "references" } }
         { +autoincrement+ { f f "autoincrement" } }
         { +unique+ { f f "unique" } }
         { +default+ { f f "default" } }
@@ -256,10 +268,6 @@ M: postgresql-db compound ( string object -- string' )
     over {
         { "default" [ first number>string join-space ] }
         { "varchar" [ first number>string paren append ] }
-        { "references" [
+        { "references" [ >reference-string ] }
-                first2 >r [ unparse join-space ] keep db-columns r>
-                swap [ slot-name>> = ] with find nip
-                column-name>> paren append
-            ] }
         [ drop no-compound-found ]
     } case ;

basis/db/queries/queries.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel math namespaces make sequences random
 strings math.parser math.intervals combinators math.bitwise
-nmake db db.tuples db.types db.sql classes words shuffle arrays
+nmake db db.tuples db.types classes words shuffle arrays
-destructors continuations ;
+destructors continuations db.tuples.private prettyprint ;
 IN: db.queries
 
 GENERIC: where ( specs obj -- )
@@ -45,14 +45,22 @@ M: retryable execute-statement* ( statement type -- )
 : sql-props ( class -- columns table )
     [ db-columns ] [ db-table ] bi ;
 
-: query-make ( class quot -- )
+: query-make ( class quot -- statements )
-    >r sql-props r>
+    #! query, input, outputs, secondary queries
-    [ 0 sql-counter rot with-variable ] curry { "" { } { } } nmake
+    over unparse "table" set
-    <simple-statement> maybe-make-retryable ; inline
+    [ sql-props ] dip
+    [ 0 sql-counter rot with-variable ] curry
+    { "" { } { } { } } nmake
+    [ <simple-statement> maybe-make-retryable ] dip
+    [ [ 1array ] dip append ] unless-empty ; inline
 
 : where-primary-key% ( specs -- )
     " where " 0%
-    find-primary-key dup column-name>> 0% " = " 0% bind% ;
+    find-primary-key [
+        " and " 0%
+    ] [
+        dup column-name>> 0% " = " 0% bind%
+    ] interleave ;
 
 M: db <update-tuple-statement> ( class -- statement )
     [
@@ -121,16 +129,15 @@ M: string where ( spec obj -- ) object-where ;
         dup double-infinite-interval? [ drop f ] when
     ] with filter ;
 
-: where-clause ( tuple specs -- )
+: many-where ( tuple seq -- )
-    dupd filter-slots [
+    " where " 0% [
-        drop
+        " and " 0%
     ] [
-        " where " 0% [
+        2dup slot-name>> swap get-slot-named where
-            " and " 0%
+    ] interleave drop ;
-        ] [
+
-            2dup slot-name>> swap get-slot-named where
+: where-clause ( tuple specs -- )
-        ] interleave drop
+    dupd filter-slots [ drop ] [ many-where ] if-empty ;
-    ] if-empty ;
 
 M: db <delete-tuples-statement> ( tuple table -- sql )
     [
@@ -141,34 +148,30 @@ M: db <delete-tuples-statement> ( tuple table -- sql )
 M: db <select-by-slots-statement> ( tuple class -- statement )
     [
         "select " 0%
-        over [ ", " 0% ]
+        [ dupd filter-ignores ] dip
+        over
+        [ ", " 0% ]
         [ dup column-name>> 0% 2, ] interleave
-
         " from " 0% 0%
         where-clause
     ] query-make ;
 
+: splice ( string1 string2 string3 -- string )
+    swap 3append ;
+
 : do-group ( tuple groups -- )
-    [
+    [ ", " join " group by " splice ] curry change-sql drop ;
-        ", " join " group by " swap 3append
-    ] curry change-sql drop ;
 
 : do-order ( tuple order -- )
-    [
+    [ ", " join " order by " splice ] curry change-sql drop ;
-        ", " join " order by " swap 3append
-    ] curry change-sql drop ;
 
 : do-offset ( tuple n -- )
-    [
+    [ number>string " offset " splice ] curry change-sql drop ;
-        number>string " offset " swap 3append
-    ] curry change-sql drop ;
 
 : do-limit ( tuple n -- )
-    [
+    [ number>string " limit " splice ] curry change-sql drop ;
-        number>string " limit " swap 3append
-    ] curry change-sql drop ;
 
-: make-query ( tuple query -- tuple' )
+: make-query* ( tuple query -- tuple' )
     dupd
     {
         [ group>> [ drop ] [ do-group ] if-empty ]
@@ -177,28 +180,16 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
         [ offset>> [ do-offset ] [ drop ] if* ]
     } 2cleave ;
 
-M: db <query> ( tuple class query -- tuple )
+M: db query>statement ( query -- tuple )
-    [ <select-by-slots-statement> ] dip make-query ;
+    [ tuple>> dup class ] keep
+    [ <select-by-slots-statement> ] dip make-query* ;
 
 ! select ID, NAME, SCORE from EXAM limit 1 offset 3
 
-: select-tuples* ( tuple -- statement )
+M: db <count-statement> ( query -- statement )
-    dup
+    [ tuple>> dup class ] keep
-    [
-        select 0,
-        dup class db-columns [ ", " 0, ]
-        [ dup column-name>> 0, 2, ] interleave
-        from 0,
-        class name>> 0,
-    ] { { } { } { } } nmake
-    >r >r parse-sql 4drop r> r>
-    <simple-statement> maybe-make-retryable do-select ;
-
-M: db <count-statement> ( tuple class groups -- statement )
-    \ query new
-        swap >>group
     [ [ "select count(*) from " 0% 0% where-clause ] query-make ]
-    dip make-query ;
+    dip make-query* ;
 
 : create-index ( index-name table-name columns -- )
     [

basis/db/sqlite/sqlite.factor

@@ -5,7 +5,8 @@ io.files kernel math math.parser namespaces prettyprint
 sequences strings classes.tuple alien.c-types continuations
 db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
 math.intervals io nmake accessors vectors math.ranges random
-math.bitwise db.queries destructors ;
+math.bitwise db.queries destructors db.tuples.private interpolate
+io.streams.string multiline make ;
 IN: db.sqlite
 
 TUPLE: sqlite-db < db path ;
@@ -88,7 +89,7 @@ M: sqlite-statement bind-tuple ( tuple statement -- )
     db get handle>> sqlite3_last_insert_rowid
     dup zero? [ "last-id failed" throw ] when ;
 
-M: sqlite-db insert-tuple* ( tuple statement -- )
+M: sqlite-db insert-tuple-set-key ( tuple statement -- )
     execute-statement last-insert-id swap set-primary-key ;
 
 M: sqlite-result-set #columns ( result-set -- n )
@@ -114,13 +115,21 @@ M: sqlite-statement query-results ( query -- result-set )
 
 M: sqlite-db create-sql-statement ( class -- statement )
     [
+        dupd
         "create table " 0% 0%
         "(" 0% [ ", " 0% ] [
-            dup column-name>> 0%
+            dup "sql-spec" set
+            dup column-name>> [ "table-id" set ] [ 0% ] bi
             " " 0%
             dup type>> lookup-create-type 0%
             modifiers 0%
-        ] interleave ");" 0%
+        ] interleave
+
+        ", " 0%
+        find-primary-key
+        "primary key(" 0%
+        [ "," 0% ] [ column-name>> 0% ] interleave
+        "));" 0%
     ] query-make ;
 
 M: sqlite-db drop-sql-statement ( class -- statement )
@@ -161,23 +170,31 @@ M: sqlite-db bind% ( spec -- )
 
 M: sqlite-db persistent-table ( -- assoc )
     H{
-        { +db-assigned-id+ { "integer primary key" "integer primary key" "primary key" } }
+        { +db-assigned-id+ { "integer" "integer" f } }
-        { +user-assigned-id+ { f f "primary key" } }
+        { +user-assigned-id+ { f f f } }
-        { +random-id+ { "integer primary key" "integer primary key" "primary key" } }
+        { +random-id+ { "integer" "integer" f } }
-        { INTEGER { "integer" "integer" "primary key" } }
+        { +foreign-id+ { "integer" "integer" "references" } }
-        { BIG-INTEGER { "bigint" "bigint" } }
+
-        { SIGNED-BIG-INTEGER { "bigint" "bigint" } }
+        { +on-delete+ { f f "on delete" } }
-        { UNSIGNED-BIG-INTEGER { "bigint" "bigint" } }
+        { +restrict+ { f f "restrict" } }
-        { TEXT { "text" "text" } }
+        { +cascade+ { f f "cascade" } }
-        { VARCHAR { "text" "text" } }
+        { +set-null+ { f f "set null" } }
-        { DATE { "date" "date" } }
+        { +set-default+ { f f "set default" } }
-        { TIME { "time" "time" } }
+
-        { DATETIME { "datetime" "datetime" } }
+        { INTEGER { "integer" "integer" f } }
-        { TIMESTAMP { "timestamp" "timestamp" } }
+        { BIG-INTEGER { "bigint" "bigint" f } }
-        { DOUBLE { "real" "real" } }
+        { SIGNED-BIG-INTEGER { "bigint" "bigint" f } }
-        { BLOB { "blob" "blob" } }
+        { UNSIGNED-BIG-INTEGER { "bigint" "bigint" f } }
-        { FACTOR-BLOB { "blob" "blob" } }
+        { TEXT { "text" "text" f } }
-        { URL { "text" "text" } }
+        { VARCHAR { "text" "text" f } }
+        { DATE { "date" "date" f } }
+        { TIME { "time" "time" f } }
+        { DATETIME { "datetime" "datetime" f } }
+        { TIMESTAMP { "timestamp" "timestamp" f } }
+        { DOUBLE { "real" "real" f } }
+        { BLOB { "blob" "blob" f } }
+        { FACTOR-BLOB { "blob" "blob" f } }
+        { URL { "text" "text" f } }
         { +autoincrement+ { f f "autoincrement" } }
         { +unique+ { f f "unique" } }
         { +default+ { f f "default" } }
@@ -188,8 +205,110 @@ M: sqlite-db persistent-table ( -- assoc )
         { random-generator { f f f } }
     } ;
 
-M: sqlite-db compound ( str seq -- str' )
+: insert-trigger ( -- string )
+    [
+    <"
+        CREATE TRIGGER fki_${table}_${foreign-table}_id
+        BEFORE INSERT ON ${table}
+        FOR EACH ROW BEGIN
+            SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
+            WHERE  (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
+        END;
+    "> interpolate
+    ] with-string-writer ;
+
+: insert-trigger-not-null ( -- string )
+    [
+    <"
+        CREATE TRIGGER fki_${table}_${foreign-table}_id
+        BEFORE INSERT ON ${table}
+        FOR EACH ROW BEGIN
+            SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
+            WHERE NEW.${foreign-table-id} IS NOT NULL
+                AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
+        END;
+    "> interpolate
+    ] with-string-writer ;
+
+: update-trigger ( -- string )
+    [
+    <"
+        CREATE TRIGGER fku_${table}_${foreign-table}_id
+        BEFORE UPDATE ON ${table}
+        FOR EACH ROW BEGIN
+            SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
+            WHERE  (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
+        END;
+    "> interpolate
+    ] with-string-writer ;
+
+: update-trigger-not-null ( -- string )
+    [
+    <"
+        CREATE TRIGGER fku_${table}_${foreign-table}_id
+        BEFORE UPDATE ON ${table}
+        FOR EACH ROW BEGIN
+            SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
+            WHERE NEW.${foreign-table-id} IS NOT NULL
+                AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
+        END;
+    "> interpolate
+    ] with-string-writer ;
+
+: delete-trigger-restrict ( -- string )
+    [
+    <"
+        CREATE TRIGGER fkd_${table}_${foreign-table}_id
+        BEFORE DELETE ON ${foreign-table}
+        FOR EACH ROW BEGIN
+            SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table}" violates foreign key constraint "fk_${foreign-table}_id"')
+            WHERE  (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
+        END;
+    "> interpolate
+    ] with-string-writer ;
+
+: delete-trigger-cascade ( -- string )
+    [
+    <"
+        CREATE TRIGGER fkd_${table}_${foreign-table}_id
+        BEFORE DELETE ON ${foreign-table}
+        FOR EACH ROW BEGIN
+            DELETE from ${table} WHERE ${table-id} = OLD.${foreign-table-id};
+        END;
+    "> interpolate
+    ] with-string-writer ;
+
+: can-be-null? ( -- ? )
+    "sql-spec" get modifiers>> [ +not-null+ = ] contains? not ;
+
+: delete-cascade? ( -- ? )
+    "sql-spec" get modifiers>> { +on-delete+ +cascade+ } swap subseq? ;
+
+: sqlite-trigger, ( string -- )
+    { } { } <simple-statement> 3, ;
+
+: create-sqlite-triggers ( -- )
+    can-be-null? [
+        insert-trigger sqlite-trigger,
+        update-trigger sqlite-trigger,
+    ] [ 
+        insert-trigger-not-null sqlite-trigger,
+        update-trigger-not-null sqlite-trigger,
+    ] if
+    delete-cascade? [
+        delete-trigger-cascade sqlite-trigger,
+    ] [
+        delete-trigger-restrict sqlite-trigger,
+    ] if ;
+
+M: sqlite-db compound ( string seq -- new-string )
     over {
         { "default" [ first number>string join-space ] }
-        [ 2drop ] 
+        { "references" [
+            [ >reference-string ] keep
+            first2 [ "foreign-table" set ]
+            [ "foreign-table-id" set ] bi*
+            create-sqlite-triggers
+        ] }
+        [ 2drop ]
     } case ;

basis/db/tuples/tuples-docs.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: classes help.markup help.syntax io.streams.string kernel
-quotations sequences strings multiline math ;
+quotations sequences strings multiline math db.types ;
 IN: db.tuples
 
 HELP: define-persistent
@@ -11,7 +11,18 @@ HELP: define-persistent
 { $list
     { "a slot name from the " { $snippet "tuple class" } }
     { "the name of a database column that maps to the slot" }        { "a database type (see " { $link "db.types" } ")" }
-} } ;
+} "Throws an error if the slot name (column one from each row) is not a slot in the tuple or its superclases." }
+{ $examples
+    { $unchecked-example "USING: db.tuples db.types ;"
+        "TUPLE: boat id year name ;"
+        "boat \"BOAT\" {"
+        "    { \"id\" \"ID\" +db-assigned-id+ }"
+        "    { \"year\" \"YEAR\" INTEGER }"
+        "    { \"name\" \"NAME\" TEXT }"
+        "} define-persistent"
+        ""
+    }
+} ;
 
 HELP: create-table
 { $values
@@ -64,36 +75,35 @@ HELP: delete-tuples
 
 HELP: select-tuple
 { $values
-     { "tuple" tuple }
+     { "query/tuple" tuple }
      { "tuple/f" "a tuple or f" } }
 { $description "A SQL query is constructed from the slots of the exemplar tuple that are not " { $link f } ". Returns a single tuple from the database if it matches the query constructed from the exemplar tuple." } ;
 
 HELP: select-tuples
 { $values
-     { "tuple" tuple }
+     { "query/tuple" tuple }
      { "tuples" "an array of tuples" } }
 { $description "A SQL query is constructed from the slots of the exemplar tuple that are not " { $link f } ". Returns a multiple tuples from the database that match the query constructed from the exemplar tuple." } ;
 
 HELP: count-tuples
 { $values
-     { "tuple" tuple } { "groups" "an array of slots to group by" }
+     { "query/tuple" tuple }
      { "n" integer } }
-{ $description "" } ;
+{ $description "Returns the number of items that would be returned if the query were a select query. Counting the tuples with this word is more efficient than calling " { $link length } " on the result of " { $link select-tuples } "." } ;
+
+{ select-tuple select-tuples count-tuples } related-words
 
-HELP: query
-{ $values
-     { "tuple" tuple } { "query" query }
-     { "tuples" "a sequence of tuples" } }
-{ $description "Allows for queries with group by, order by, limit, and offset clauses.  " } ;
 
-{ select-tuple select-tuples count-tuples query } related-words
 
 ARTICLE: "db-tuples" "High-level tuple/database integration"
 "Start with a tutorial:"
 { $subsection "db-tuples-tutorial" }
+"Database types supported:"
+{ $subsection "db.types" }
 "Useful words:"
 { $subsection "db-tuples-words" }
-
+"For porting db.tuples to other databases:"
+{ $subsection "db-tuples-protocol" }
 ;
 
 ARTICLE: "db-tuples-words" "High-level tuple/database words"
@@ -115,12 +125,9 @@ ARTICLE: "db-tuples-words" "High-level tuple/database words"
 "Querying tuples:"
 { $subsection select-tuple }
 { $subsection select-tuples }
-{ $subsection count-tuples }
+{ $subsection count-tuples } ;
-"Advanced querying of tuples:"
-{ $subsection query } ;
 
-
+ARTICLE: "db-tuples-protocol" "Tuple database protocol"
-ARTICLE: "db-tuples-protocol" "High-level tuple/database protocol"
 ;
 
 ARTICLE: "db-tuples-tutorial" "Tuple database tutorial"

basis/db/tuples/tuples-tests.factor

@@ -4,9 +4,20 @@ USING: io.files kernel tools.test db db.tuples classes
 db.types continuations namespaces math math.ranges
 prettyprint calendar sequences db.sqlite math.intervals
 db.postgresql accessors random math.bitwise
-math.ranges strings urls fry ;
+math.ranges strings urls fry db.tuples.private ;
 IN: db.tuples.tests
 
+: test-sqlite ( quot -- )
+    [ ] swap '[
+        "tuples-test.db" temp-file sqlite-db _ with-db
+    ] unit-test ;
+
+: test-postgresql ( quot -- )
+    [ ] swap '[
+        { "localhost" "postgres" "foob" "factor-test" }
+        postgresql-db _ with-db
+    ] unit-test ;
+
 TUPLE: person the-id the-name the-number the-real
 ts date time blob factor-blob url ;
 
@@ -165,46 +176,124 @@ SYMBOL: person4
         T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
         f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" <user-assigned-person> person4 set ;
 
+
 TUPLE: paste n summary author channel mode contents timestamp annotations ;
 TUPLE: annotation n paste-id summary author mode contents ;
 
-: db-assigned-paste-schema ( -- )
+paste "PASTE"
-    paste "PASTE"
+{
-    {
+    { "n" "ID" +db-assigned-id+ }
-        { "n" "ID" +db-assigned-id+ }
+    { "summary" "SUMMARY" TEXT }
-        { "summary" "SUMMARY" TEXT }
+    { "author" "AUTHOR" TEXT }
-        { "author" "AUTHOR" TEXT }
+    { "channel" "CHANNEL" TEXT }
-        { "channel" "CHANNEL" TEXT }
+    { "mode" "MODE" TEXT }
-        { "mode" "MODE" TEXT }
+    { "contents" "CONTENTS" TEXT }
-        { "contents" "CONTENTS" TEXT }
+    { "timestamp" "DATE" TIMESTAMP }
-        { "date" "DATE" TIMESTAMP }
+    { "annotations" { +has-many+ annotation } }
-        { "annotations" { +has-many+ annotation } }
+} define-persistent
-    } define-persistent
 
+: annotation-schema-foreign-key ( -- )
     annotation "ANNOTATION"
     {
         { "n" "ID" +db-assigned-id+ }
-        { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" } }
+        { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } }
         { "summary" "SUMMARY" TEXT }
         { "author" "AUTHOR" TEXT }
         { "mode" "MODE" TEXT }
         { "contents" "CONTENTS" TEXT }
     } define-persistent ;
 
-! { "localhost" "postgres" "" "factor-test" } postgresql-db [
+: annotation-schema-foreign-key-not-null ( -- )
-    ! [ paste drop-table ] [ drop ] recover
+    annotation "ANNOTATION"
-    ! [ annotation drop-table ] [ drop ] recover
+    {
-    ! [ paste drop-table ] [ drop ] recover
+        { "n" "ID" +db-assigned-id+ }
-    ! [ annotation drop-table ] [ drop ] recover
+        { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } +not-null+ }
-    ! [ ] [ paste create-table ] unit-test
+        { "summary" "SUMMARY" TEXT }
-    ! [ ] [ annotation create-table ] unit-test
+        { "author" "AUTHOR" TEXT }
-! ] with-db
+        { "mode" "MODE" TEXT }
+        { "contents" "CONTENTS" TEXT }
+    } define-persistent ;
 
-: test-sqlite ( quot -- )
+: annotation-schema-cascade ( -- )
-    [ ] swap '[ "tuples-test.db" temp-file sqlite-db _ with-db ] unit-test ;
+    annotation "ANNOTATION"
+    {
+        { "n" "ID" +db-assigned-id+ }
+        { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" }
+            +on-delete+ +cascade+ }
+        { "summary" "SUMMARY" TEXT }
+        { "author" "AUTHOR" TEXT }
+        { "mode" "MODE" TEXT }
+        { "contents" "CONTENTS" TEXT }
+    } define-persistent ;
 
-: test-postgresql ( quot -- )
+: annotation-schema-restrict ( -- )
-    [ ] swap '[ { "localhost" "postgres" "foob" "factor-test" } postgresql-db _ with-db ] unit-test ;
+    annotation "ANNOTATION"
+    {
+        { "n" "ID" +db-assigned-id+ }
+        { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } }
+        { "summary" "SUMMARY" TEXT }
+        { "author" "AUTHOR" TEXT }
+        { "mode" "MODE" TEXT }
+        { "contents" "CONTENTS" TEXT }
+    } define-persistent ;
+
+: test-paste-schema ( -- )
+    [ ] [ paste ensure-table ] unit-test
+    [ ] [ annotation ensure-table ] unit-test
+    [ ] [ annotation drop-table ] unit-test
+    [ ] [ paste drop-table ] unit-test
+    [ ] [ paste create-table ] unit-test
+    [ ] [ annotation create-table ] unit-test
+
+    [ ] [
+        paste new
+            "summary1" >>summary
+            "erg" >>author
+            "#lol" >>channel
+            "contents1" >>contents
+            now >>timestamp
+        insert-tuple
+    ] unit-test
+
+    [ ] [
+        annotation new
+            1 >>paste-id
+            "annotation1" >>summary
+            "erg" >>author
+            "annotation contents" >>contents
+        insert-tuple
+    ] unit-test ;
+
+: test-foreign-key ( -- )
+    [ ] [ annotation-schema-foreign-key ] unit-test
+    test-paste-schema
+    [ paste new 1 >>n delete-tuples ] must-fail ;
+
+: test-foreign-key-not-null ( -- )
+    [ ] [ annotation-schema-foreign-key-not-null ] unit-test
+    test-paste-schema
+    [ paste new 1 >>n delete-tuples ] must-fail ;
+
+: test-cascade ( -- )
+    [ ] [ annotation-schema-cascade ] unit-test
+    test-paste-schema
+    [ ] [ paste new 1 >>n delete-tuples ] unit-test
+    [ 0 ] [ paste new select-tuples length ] unit-test ;
+
+: test-restrict ( -- )
+    [ ] [ annotation-schema-restrict ] unit-test
+    test-paste-schema
+    [ paste new 1 >>n delete-tuples ] must-fail ;
+
+[ test-foreign-key ] test-sqlite
+[ test-foreign-key-not-null ] test-sqlite
+[ test-cascade ] test-sqlite
+[ test-restrict ] test-sqlite
+
+[ test-foreign-key ] test-postgresql
+[ test-foreign-key-not-null ] test-postgresql
+[ test-cascade ] test-postgresql
+[ test-restrict ] test-postgresql
 
 : test-repeated-insert
     [ ] [ person ensure-table ] unit-test
@@ -236,6 +325,17 @@ TUPLE: exam id name score ;
     exam boa ;
 
 : test-intervals ( -- )
+    [
+        exam "EXAM"
+        {
+            { "idd" "ID" +db-assigned-id+ }
+            { "named" "NAME" TEXT }
+            { "score" "SCORE" INTEGER }
+        } define-persistent
+    ] [
+        seq>> { "idd" "named" } =
+    ] must-fail-with
+
     exam "EXAM"
     {
         { "id" "ID" +db-assigned-id+ }
@@ -250,6 +350,16 @@ TUPLE: exam id name score ;
     [ ] [ T{ exam f f "Kenny" 60 } insert-tuple ] unit-test
     [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test
 
+    [ 4 ]
+    [ T{ exam { name IGNORE } { score IGNORE } } select-tuples length ] unit-test
+
+    [ f ]
+    [ T{ exam { name IGNORE } { score IGNORE } } select-tuples first score>> ] unit-test
+
+    ! FIXME
+    ! [ f ]
+    ! [ T{ exam { name IGNORE } { score IGNORE } { id IGNORE } } select-tuples first score>> ] unit-test
+
     [
         {
             T{ exam f 3 "Kenny" 60 }
@@ -346,7 +456,7 @@ TUPLE: exam id name score ;
         T{ exam } select-tuples
     ] unit-test
 
-    [ 4 ] [ T{ exam } f count-tuples ] unit-test ;
+    [ 4 ] [ T{ exam } count-tuples ] unit-test ;
 
 TUPLE: bignum-test id m n o ;
 : <bignum-test> ( m n o -- obj )
@@ -499,3 +609,42 @@ string-encoding-test "STRING_ENCODING_TEST" {
 \ ensure-table must-infer
 \ create-table must-infer
 \ drop-table must-infer
+
+: test-queries ( -- )
+    [ ] [ exam ensure-table ] unit-test
+    [ ] [ 1000 [ random-exam insert-tuple ] times ] unit-test
+    [ 5 ] [
+        <query>
+        T{ exam { score T{ interval { from { 0 t } } { to { 100 t } } } } }
+            >>tuple
+        5 >>limit select-tuples length
+    ] unit-test ;
+
+TUPLE: compound-foo a b c ;
+
+compound-foo "COMPOUND_FOO" 
+{
+    { "a" "A" INTEGER +user-assigned-id+ }
+    { "b" "B" INTEGER +user-assigned-id+ }
+    { "c" "C" INTEGER }
+} define-persistent
+
+: test-compound-primary-key ( -- )
+    [ ] [ compound-foo ensure-table ] unit-test
+    [ ] [ compound-foo drop-table ] unit-test
+    [ ] [ compound-foo create-table ] unit-test
+    [ ] [ 1 2 3 compound-foo boa insert-tuple ] unit-test
+    [ 1 2 3 compound-foo boa insert-tuple ] must-fail
+    [ ] [ 2 3 4 compound-foo boa insert-tuple ] unit-test
+    [ T{ compound-foo { a 2 } { b 3 } { c 4 } } ]
+    [ compound-foo new 4 >>c select-tuple ] unit-test ;
+
+[ test-compound-primary-key ] test-sqlite
+[ test-compound-primary-key ] test-postgresql
+
+: sqlite-test-db ( -- )
+    "tuples-test.db" temp-file sqlite-db make-db db-open db set ;
+
+: postgresql-test-db ( -- )
+    { "localhost" "postgres" "foob" "factor-test" } postgresql-db
+    make-db db-open db set ;

basis/db/tuples/tuples.factor

@@ -3,36 +3,10 @@
 USING: arrays assocs classes db kernel namespaces
 classes.tuple words sequences slots math accessors
 math.parser io prettyprint db.types continuations
-destructors mirrors ;
+destructors mirrors sets db.types ;
 IN: db.tuples
 
-: define-persistent ( class table columns -- )
+<PRIVATE
-    >r dupd "db-table" set-word-prop dup r>
-    [ relation? ] partition swapd
-    dupd [ spec>tuple ] with map
-    "db-columns" set-word-prop
-    "db-relations" set-word-prop ;
-
-ERROR: not-persistent class ;
-
-: db-table ( class -- object )
-    dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
-
-: db-columns ( class -- object )
-    superclasses [ "db-columns" word-prop ] map concat ;
-
-: db-relations ( class -- object )
-    "db-relations" word-prop ;
-
-: set-primary-key ( key tuple -- )
-    [
-        class db-columns find-primary-key slot-name>>
-    ] keep set-slot-named ;
-
-SYMBOL: sql-counter
-: next-sql-counter ( -- str )
-    sql-counter [ inc ] [ get ] bi number>string ;
-
 ! returns a sequence of prepared-statements
 HOOK: create-sql-statement db ( class -- object )
 HOOK: drop-sql-statement db ( class -- object )
@@ -42,19 +16,20 @@ HOOK: <insert-user-assigned-statement> db ( class -- object )
 HOOK: <update-tuple-statement> db ( class -- object )
 HOOK: <delete-tuples-statement> db ( tuple class -- object )
 HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
-TUPLE: query group order offset limit ;
+HOOK: <count-statement> db ( query -- statement )
-HOOK: <query> db ( tuple class query -- statement' )
+HOOK: query>statement db ( query -- statement )
-HOOK: <count-statement> db ( tuple class groups -- n )
 
-HOOK: insert-tuple* db ( tuple statement -- )
+HOOK: insert-tuple-set-key db ( tuple statement -- )
+
+SYMBOL: sql-counter
+: next-sql-counter ( -- str )
+    sql-counter [ inc ] [ get ] bi number>string ;
 
 GENERIC: eval-generator ( singleton -- object )
 
 : resulting-tuple ( exemplar-tuple row out-params -- tuple )
     rot class new [
-        [
+        [ [ slot-name>> ] dip set-slot-named ] curry 2each
-            [ slot-name>> ] dip set-slot-named
-        ] curry 2each
     ] keep ;
 
 : query-tuples ( exemplar-tuple statement -- seq )
@@ -75,6 +50,51 @@ GENERIC: eval-generator ( singleton -- object )
         with-disposal
     ] if ; inline
 
+: insert-db-assigned-statement ( tuple -- )
+    dup class
+    db get insert-statements>> [ <insert-db-assigned-statement> ] cache
+    [ bind-tuple ] 2keep insert-tuple-set-key ;
+
+: insert-user-assigned-statement ( tuple -- )
+    dup class
+    db get insert-statements>> [ <insert-user-assigned-statement> ] cache
+    [ bind-tuple ] keep execute-statement ;
+
+: do-select ( exemplar-tuple statement -- tuples )
+    [ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
+
+: do-count ( exemplar-tuple statement -- tuples )
+    [ [ bind-tuple ] [ nip default-query ] 2bi ] with-disposal ;
+PRIVATE>
+
+
+! High level
+ERROR: no-slots-named class seq ;
+: check-columns ( class columns -- )
+    tuck
+    [ [ first ] map ]
+    [ all-slots [ name>> ] map ] bi* diff
+    [ drop ] [ no-slots-named ] if-empty ;
+
+: define-persistent ( class table columns -- )
+    pick dupd
+    check-columns
+    [ dupd "db-table" set-word-prop dup ] dip
+    [ relation? ] partition swapd
+    dupd [ spec>tuple ] with map
+    "db-columns" set-word-prop
+    "db-relations" set-word-prop ;
+
+TUPLE: query tuple group order offset limit ;
+
+: <query> ( -- query ) \ query new ;
+
+GENERIC: >query ( object -- query )
+
+M: query >query clone ;
+
+M: tuple >query <query> swap >>tuple ;
+
 : create-table ( class -- )
     create-sql-statement [ execute-statement ] with-disposals ;
 
@@ -87,21 +107,9 @@ GENERIC: eval-generator ( singleton -- object )
         ] curry ignore-errors
     ] [ create-table ] bi ;
 
-: ensure-table ( class -- )
+: ensure-table ( class -- ) [ create-table ] curry ignore-errors ;
-    [ create-table ] curry ignore-errors ;
 
-: ensure-tables ( classes -- )
+: ensure-tables ( classes -- ) [ ensure-table ] each ;
-    [ ensure-table ] each ;
-
-: insert-db-assigned-statement ( tuple -- )
-    dup class
-    db get insert-statements>> [ <insert-db-assigned-statement> ] cache
-    [ bind-tuple ] 2keep insert-tuple* ;
-
-: insert-user-assigned-statement ( tuple -- )
-    dup class
-    db get insert-statements>> [ <insert-user-assigned-statement> ] cache
-    [ bind-tuple ] keep execute-statement ;
 
 : insert-tuple ( tuple -- )
     dup class db-columns find-primary-key db-assigned-id-spec?
@@ -117,25 +125,14 @@ GENERIC: eval-generator ( singleton -- object )
         [ bind-tuple ] keep execute-statement
     ] with-disposal ;
 
-: do-select ( exemplar-tuple statement -- tuples )
+: select-tuples ( query/tuple -- tuples )
-    [ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
+    >query [ tuple>> ] [ query>statement ] bi do-select ;
 
-: query ( tuple query -- tuples )
+: select-tuple ( query/tuple -- tuple/f )
-    [ dup dup class ] dip <query> do-select ;
+    >query 1 >>limit [ tuple>> ] [ query>statement ] bi do-select
-
-: select-tuples ( tuple -- tuples )
-    dup dup class <select-by-slots-statement> do-select ;
-
-: select-tuple ( tuple -- tuple/f )
-    dup dup class \ query new 1 >>limit <query> do-select
     [ f ] [ first ] if-empty ;
 
-: do-count ( exemplar-tuple statement -- tuples )
+: count-tuples ( query/tuple -- n )
-    [
+    >query [ tuple>> ] [ <count-statement> ] bi do-count
-        [ bind-tuple ] [ nip default-query ] 2bi
-    ] with-disposal ;
-
-: count-tuples ( tuple groups -- n )
-    >r dup dup class r> <count-statement> do-count
     dup length 1 =
     [ first first string>number ] [ [ first string>number ] map ] if ;

basis/db/types/types-docs.factor

@@ -1,14 +1,9 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: classes hashtables help.markup help.syntax io.streams.string kernel sequences strings ;
+USING: classes hashtables help.markup help.syntax io.streams.string
+kernel sequences strings math ;
 IN: db.types
 
-HELP: (lookup-type)
-{ $values
-     { "obj" object }
-     { "string" string } }
-{ $description "" } ;
-
 HELP: +autoincrement+
 { $description "" } ;
 
@@ -55,7 +50,7 @@ HELP: <low-level-binding>
 { $description "" } ;
 
 HELP: BIG-INTEGER
-{ $description "A 64-bit integer." } ;
+{ $description "A 64-bit integer. Whether this number is signed or unsigned depends on the database backend." } ;
 
 HELP: BLOB
 { $description "A serialized Factor object.  The database library automatically serializes the object for a SQL insert or update and deserializes it on a tuple query." } ;
@@ -73,13 +68,13 @@ HELP: DOUBLE
 { $description "Corresponds to Factor's 64bit floating-point numbers." } ;
 
 HELP: FACTOR-BLOB
-{ $description "" } ;
+{ $description "A serialized Factor object." } ;
 
 HELP: INTEGER
-{ $description "" } ;
+{ $description "A small integer, at least 32 bits in length. Whether this number is signed or unsigned depends on the database backend." } ;
 
 HELP: NULL
-{ $description "" } ;
+{ $description "The SQL null type." } ;
 
 HELP: REAL
 { $description "" } ;
@@ -94,22 +89,24 @@ HELP: TIME
 { $description "" } ;
 
 HELP: TIMESTAMP
-{ $description "" } ;
+{ $description "A Factor timestamp." } ;
 
 HELP: UNSIGNED-BIG-INTEGER
-{ $description "" } ;
+{ $description "For portability, if a number is known to be 64bit, then this datatype may be used.  Some databases, like SQLite, cannot store arbitrary bignums as BIGINT types.  If storing arbitrary bignums, use " { $link FACTOR-BLOB } "." } ;
+
+{ INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER } related-words
 
 HELP: URL
-{ $description "" } ;
+{ $description "A Factor " { $link "urls" } "  object." } ;
 
 HELP: VARCHAR
-{ $description "" } ;
+{ $description "The SQL varchar type.  This type can take an integer as an argument." } ;
 
-HELP: assigned-id-spec?
+HELP: user-assigned-id-spec?
 { $values
-     { "spec" null }
+     { "specs" "a sequence of sql specs" }
      { "?" "a boolean" } }
-{ $description "" } ;
+{ $description "Tests if any of the sql specs has the type " { $link +user-assigned-id+ } "." } ;
 
 HELP: bind#
 { $values
@@ -129,24 +126,25 @@ HELP: compound
 
 HELP: db-assigned-id-spec?
 { $values
-     { "spec" null }
+     { "specs" "a sequence of sql specs" }
      { "?" "a boolean" } }
-{ $description "" } ;
+{ $description "Tests if any of the sql specs has the type " { $link +db-assigned-id+ } "." } ;
 
 HELP: find-primary-key
 { $values
-     { "specs" null }
+     { "specs" "a sequence of sql-specs" }
-     { "obj" object } }
+     { "seq" "a sequence of sql-specs" } }
-{ $description "" } ;
+{ $description "Returns the rows from the sql-specs array that are part of the primary key. Composite primary keys are supported, so this word must return a sequence." }
+{ $notes "This is a low-level word." } ;
 
 HELP: generator-bind
 { $description "" } ;
 
 HELP: get-slot-named
 { $values
-     { "name" null } { "obj" object }
+     { "name" "a slot name" } { "tuple" tuple }
-     { "value" null } }
+     { "value" "the value stored in the slot" } }
-{ $description "" } ;
+{ $description "Returns the value stored in a tuple slot, where the tuple slot is a string." } ;
 
 HELP: join-space
 { $values
@@ -185,30 +183,20 @@ HELP: modifiers
 { $description "" } ;
 
 HELP: no-sql-type
-{ $description "" } ;
+{ $values
+     { "type" "a sql type" } }
+{ $description "Throws an error containing a sql type that is unsupported or the result of a typo." } ;
 
 HELP: normalize-spec
 { $values
      { "spec" null } }
 { $description "" } ;
 
-HELP: number>string*
-{ $values
-     { "n/string" null }
-     { "string" string } }
-{ $description "" } ;
-
 HELP: offset-of-slot
 { $values
-     { "string" string } { "obj" object }
+     { "string" string } { "tuple" tuple }
-     { "n" null } }
+     { "n" integer } }
-{ $description "" } ;
+{ $description "Returns the offset of a tuple slot accessed by name." } ;
-
-HELP: paren
-{ $values
-     { "string" string }
-     { "new-string" null } }
-{ $description "" } ;
 
 HELP: persistent-table
 { $values
@@ -264,7 +252,8 @@ HELP: sql-spec
 { $description "" } ;
 
 HELP: unknown-modifier
-{ $description "" } ;
+{ $values { "modifier" string } }
+{ $description "Throws an error containing an unknown sql modifier." } ;
 
 ARTICLE: "db.types" "Database types"
 "The " { $vocab-link "db.types" } " vocabulary maps Factor types to database types." $nl
@@ -294,7 +283,6 @@ ARTICLE: "db.types" "Database types"
 { $subsection BLOB }
 { $subsection FACTOR-BLOB }
 "Factor URLs:"
-{ $subsection URL }
+{ $subsection URL } ;
-;
 
 ABOUT: "db.types"

basis/db/types/types.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs db kernel math math.parser
-sequences continuations sequences.deep
+sequences continuations sequences.deep prettyprint
 words namespaces slots slots.private classes mirrors
 classes.tuple combinators calendar.format symbols
 classes.singleton accessors quotations random ;
@@ -22,22 +22,59 @@ SINGLETON: random-id-generator
 TUPLE: low-level-binding value ;
 C: <low-level-binding> low-level-binding
 
-SINGLETON: +db-assigned-id+
+SINGLETONS: +db-assigned-id+ +user-assigned-id+ +random-id+ ;
-SINGLETON: +user-assigned-id+
-SINGLETON: +random-id+
 UNION: +primary-key+ +db-assigned-id+ +user-assigned-id+ +random-id+ ;
 
 SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
-+foreign-id+ +has-many+ ;
++foreign-id+ +has-many+ +on-delete+ +restrict+ +cascade+ +set-null+
++set-default+ ;
+
+SYMBOL: IGNORE
+
+: filter-ignores ( tuple specs -- specs' )
+    [ <mirror> [ nip IGNORE = ] assoc-filter keys ] dip
+    [ slot-name>> swap member? not ] with filter ;
+
+ERROR: no-slot ;
+
+: offset-of-slot ( string tuple -- n )
+    class superclasses [ "slots" word-prop ] map concat
+    slot-named dup [ no-slot ] unless offset>> ;
+
+: get-slot-named ( name tuple -- value )
+    tuck offset-of-slot slot ;
+
+: set-slot-named ( value name obj -- )
+    tuck offset-of-slot set-slot ;
+
+ERROR: not-persistent class ;
+
+: db-table ( class -- object )
+    dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
+
+: db-columns ( class -- object )
+    superclasses [ "db-columns" word-prop ] map concat ;
+
+: db-relations ( class -- object )
+    "db-relations" word-prop ;
+
+: find-primary-key ( specs -- seq )
+    [ primary-key>> ] filter ;
+
+: set-primary-key ( value tuple -- )
+    [
+        class db-columns
+        find-primary-key first slot-name>>
+    ] keep set-slot-named ;
 
 : primary-key? ( spec -- ? )
     primary-key>> +primary-key+? ;
 
-: db-assigned-id-spec? ( spec -- ? )
+: db-assigned-id-spec? ( specs -- ? )
-    primary-key>> +db-assigned-id+? ;
+    [ primary-key>> +db-assigned-id+? ] contains? ;
 
-: assigned-id-spec? ( spec -- ? )
+: user-assigned-id-spec? ( specs -- ? )
-    primary-key>> +user-assigned-id+? ;
+    [ primary-key>> +user-assigned-id+? ] contains? ;
 
 : normalize-spec ( spec -- )
     dup type>> dup +primary-key+? [
@@ -49,8 +86,8 @@ SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
         [ >>primary-key drop ] [ drop ] if*
     ] if ;
 
-: find-primary-key ( specs -- obj )
+: db-assigned? ( class -- ? )
-    [ primary-key>> ] find nip ;
+    db-columns find-primary-key db-assigned-id-spec? ;
 
 : relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
 
@@ -58,16 +95,17 @@ SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
 DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB
 FACTOR-BLOB NULL URL ;
 
-: spec>tuple ( class spec -- tuple )
+: <sql-spec> ( class slot-name column-name type modifiers -- sql-spec )
-    3 f pad-right
-    [ first3 ] keep 3 tail
     sql-spec new
         swap >>modifiers
         swap >>type
         swap >>column-name
         swap >>slot-name
         swap >>class
-    dup normalize-spec ;
+        dup normalize-spec ;
+
+: spec>tuple ( class spec -- tuple )
+    3 f pad-right [ first3 ] keep 3 tail <sql-spec> ;
 
 : number>string* ( n/string -- string )
     dup number? [ number>string ] when ;
@@ -86,18 +124,21 @@ FACTOR-BLOB NULL URL ;
 ! PostgreSQL Types:
 ! http://developer.postgresql.org/pgdocs/postgres/datatype.html
 
-ERROR: unknown-modifier ;
+: ?at ( obj assoc -- value/obj ? )
+    dupd at* [ [ nip ] [ drop ] if ] keep ;
+
+ERROR: unknown-modifier modifier ;
 
 : lookup-modifier ( obj -- string )
     {
         { [ dup array? ] [ unclip lookup-modifier swap compound ] }
-        [ persistent-table at* [ unknown-modifier ] unless third ]
+        [ persistent-table ?at [ unknown-modifier ] unless third ]
     } cond ;
 
-ERROR: no-sql-type ;
+ERROR: no-sql-type type ;
 
 : (lookup-type) ( obj -- string )
-    persistent-table at* [ no-sql-type ] unless ;
+    persistent-table ?at [ no-sql-type ] unless ;
 
 : lookup-type ( obj -- string )
     dup array? [
@@ -126,12 +167,11 @@ ERROR: no-sql-type ;
 HOOK: bind% db ( spec -- )
 HOOK: bind# db ( spec obj -- )
 
-: offset-of-slot ( string obj -- n )
+ERROR: no-column column ;
-    class superclasses [ "slots" word-prop ] map concat
-    slot-named offset>> ;
 
-: get-slot-named ( name obj -- value )
+: >reference-string ( string pair -- string )
-    tuck offset-of-slot slot ;
+    first2
-
+    [ [ unparse join-space ] [ db-columns ] bi ] dip
-: set-slot-named ( value name obj -- )
+    swap [ column-name>> = ] with find nip
-    tuck offset-of-slot set-slot ;
+    [ no-column ] unless*
+    column-name>> paren append ;

basis/debugger/debugger.factor

@@ -22,6 +22,9 @@ M: tuple error-help class ;
 
 M: string error. print ;
 
+: :error ( -- )
+    error get error. ;
+
 : :s ( -- )
     error-continuation get data>> stack. ;
 
@@ -323,3 +326,5 @@ M: bad-effect summary
     drop "Bad stack effect declaration" ;
 
 M: bad-escape summary drop "Bad escape code" ;
+
+M: bad-literal-tuple summary drop "Bad literal tuple" ;

basis/editors/macvim/authors.txt

@@ -0,0 +1 @@
+John Benediktsson

basis/editors/macvim/macvim.factor

@@ -0,0 +1,13 @@
+USING: definitions io.launcher kernel math math.parser parser
+namespaces prettyprint editors make ;
+
+IN: editors.macvim
+
+: macvim-location ( file line -- )
+    drop
+    [ "open" , "-a" , "MacVim", , ] { } make
+    try-process ;
+
+[ macvim-location ] edit-hook set-global
+
+

basis/editors/macvim/summary.txt

@@ -0,0 +1 @@
+MacVim editor integration

basis/editors/macvim/tags.txt

@@ -0,0 +1 @@
+unportable

basis/editors/textedit/authors.txt

@@ -0,0 +1 @@
+John Benediktsson

basis/editors/textedit/summary.txt

@@ -0,0 +1 @@
+TextEdit editor integration

basis/editors/textedit/tags.txt

@@ -0,0 +1 @@
+unportable

basis/editors/textedit/textedit.factor

@@ -0,0 +1,13 @@
+USING: definitions io.launcher kernel math math.parser parser
+namespaces prettyprint editors make ;
+
+IN: editors.textedit
+
+: textedit-location ( file line -- )
+    drop
+    [ "open" , "-a" , "TextEdit", , ] { } make
+    try-process ;
+
+[ textedit-location ] edit-hook set-global
+
+

basis/eval/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/eval/summary.txt

@@ -0,0 +1 @@
+Ad-hoc evaluation of strings of code

basis/farkup/farkup-docs.factor

@@ -9,7 +9,7 @@ HELP: write-farkup
 { $values { "string" string } }
 { $description "Parse a Farkup string and writes the resulting HTML to " { $link output-stream } "." } ;
 
-HELP: farkup ( string -- farkup )
+HELP: parse-farkup ( string -- farkup )
 { $values { "string" string } { "farkup" "a Farkup syntax tree node" } }
 { $description "Parses Farkup and outputs a tree of " { $link "farkup-ast" } "." } ;
 
@@ -18,7 +18,7 @@ HELP: (write-farkup)
 { $description "Writes a Farkup syntax tree as HTML on " { $link output-stream } "." } ;
 
 ARTICLE: "farkup-ast" "Farkup syntax tree nodes"
-"The " { $link farkup } " word outputs a tree of nodes corresponding to the Farkup syntax of the input string. This tree can be programatically traversed and mutated before being passed on to " { $link write-farkup } "."
+"The " { $link parse-farkup } " word outputs a tree of nodes corresponding to the Farkup syntax of the input string. This tree can be programatically traversed and mutated before being passed on to " { $link write-farkup } "."
 { $subsection heading1 }
 { $subsection heading2 }
 { $subsection heading3 }
@@ -30,7 +30,8 @@ ARTICLE: "farkup-ast" "Farkup syntax tree nodes"
 { $subsection inline-code }
 { $subsection paragraph }
 { $subsection list-item }
-{ $subsection list }
+{ $subsection unordered-list }
+{ $subsection ordered-list }
 { $subsection table }
 { $subsection table-row }
 { $subsection link }
@@ -44,7 +45,7 @@ $nl
 { $subsection convert-farkup }
 { $subsection write-farkup }
 "The syntax tree of a piece of Farkup can also be inspected and modified:"
-{ $subsection farkup }
+{ $subsection parse-farkup }
 { $subsection (write-farkup) }
 { $subsection "farkup-ast" } ;
 

basis/farkup/farkup-tests.factor

@@ -11,13 +11,11 @@ link-no-follow? off
 [ "Baz" ] [ "Baz" simple-link-title ] unit-test
 
 [ ] [
-    "abcd-*strong*\nasdifj\nweouh23ouh23"
+    "abcd-*strong*\nasdifj\nweouh23ouh23" parse-farkup drop
-    "paragraph" \ farkup rule parse drop
 ] unit-test
 
 [ ] [
-    "abcd-*strong*\nasdifj\nweouh23ouh23\n"
+    "abcd-*strong*\nasdifj\nweouh23ouh23\n" parse-farkup drop
-    "paragraph" \ farkup rule parse drop
 ] unit-test
 
 [ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test
@@ -37,22 +35,30 @@ link-no-follow? off
 
 [ "<ul><li>foo</li>\n</ul><p>bar\n</p>" ] [ "-foo\nbar\n" convert-farkup ] unit-test
 
+[ "<ol><li>a-b</li></ol>" ] [ "#a-b" convert-farkup ] unit-test
+[ "<ol><li>foo</li></ol>" ] [ "#foo" convert-farkup ] unit-test
+[ "<ol><li>foo</li>\n</ol>" ] [ "#foo\n" convert-farkup ] unit-test
+[ "<ol><li>foo</li>\n<li>bar</li></ol>" ] [ "#foo\n#bar" convert-farkup ] unit-test
+[ "<ol><li>foo</li>\n<li>bar</li>\n</ol>" ] [ "#foo\n#bar\n" convert-farkup ] unit-test
+
+[ "<ol><li>foo</li>\n</ol><p>bar\n</p>" ] [ "#foo\nbar\n" convert-farkup ] unit-test
+
 
 [ "\n\n" ] [ "\n\n" convert-farkup ] unit-test
 [ "\n\n" ] [ "\r\n\r\n" convert-farkup ] unit-test
 [ "\n\n\n\n" ] [ "\r\r\r\r" convert-farkup ] unit-test
 [ "\n\n\n" ] [ "\r\r\r" convert-farkup ] unit-test
 [ "\n\n\n" ] [ "\n\n\n" convert-farkup ] unit-test
-[ "<p>foo</p><p>bar</p>" ] [ "foo\n\nbar" convert-farkup ] unit-test
+[ "<p>foo\n</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\n</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\n</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
+[ "<p>foo\n</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><p>bar</p>" ] [ "foo\n\n\nbar" convert-farkup ] unit-test
+[ "<p>foo\n</p><p>bar</p>" ] [ "foo\n\n\nbar" convert-farkup ] unit-test
 
 [ "" ] [ "" convert-farkup ] unit-test
 
@@ -107,7 +113,7 @@ link-no-follow? off
 ] [ "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:</p><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</p><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>"
 ] [ "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
 
 [
@@ -118,3 +124,36 @@ link-no-follow? off
 ] unit-test
 
 [ "<p><a href='a'>a</a> <a href='b'>c</a></p>" ] [ "[[a]] [[b|c]]" convert-farkup ] unit-test
+
+[ "<p><a href='C%2b%2b'>C++</a></p>" ] [ "[[C++]]" convert-farkup ] unit-test
+
+[ "<p>&lt;foo&gt;</p>" ] [ "<foo>" convert-farkup ] unit-test
+
+[ "<p>asdf\n<ul><li>lol</li>\n<li>haha</li></ul></p>" ] [ "asdf\n-lol\n-haha" convert-farkup ] unit-test
+
+[ "<p>asdf\n</p><ul><li>lol</li>\n<li>haha</li></ul>" ]
+ [ "asdf\n\n-lol\n-haha" convert-farkup ] unit-test
+
+[ "<hr/>" ] [ "___" convert-farkup ] unit-test
+[ "<hr/>\n" ] [ "___\n" convert-farkup ] unit-test
+
+[ "<p>before:\n<pre><span class='OPERATOR'>{</span> <span class='DIGIT'>1</span> <span class='DIGIT'>2</span> <span class='DIGIT'>3</span> <span class='OPERATOR'>}</span> <span class='DIGIT'>1</span> tail\n</pre></p>" ] 
+[ "before:\n[factor{{ 1 2 3 } 1 tail}]" convert-farkup ] unit-test
+ 
+[ "<p><a href='Factor'>Factor</a>-rific!</p>" ]
+[ "[[Factor]]-rific!" convert-farkup ] unit-test
+
+[ "<p>[ factor { 1 2 3 }]</p>" ]
+[ "[ factor { 1 2 3 }]" convert-farkup ] unit-test
+
+[ "<p>paragraph\n<hr/></p>" ]
+[ "paragraph\n___" convert-farkup ] unit-test
+
+[ "<p>paragraph\n a ___ b</p>" ]
+[ "paragraph\n a ___ b" convert-farkup ] unit-test
+
+[ "\n<ul><li> a</li>\n</ul><hr/>" ]
+[ "\n- a\n___" convert-farkup ] unit-test
+
+[ "<p>hello_world how are you today?\n<ul><li> hello_world how are you today?</li></ul></p>" ]
+[ "hello_world how are you today?\n- hello_world how are you today?" convert-farkup ] unit-test

basis/farkup/farkup.factor

@@ -1,32 +1,36 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators html.elements io io.streams.string
+USING: accessors arrays combinators html.elements io
-kernel math memoize namespaces peg peg.ebnf prettyprint
+io.streams.string kernel math namespaces peg peg.ebnf
-sequences sequences.deep strings xml.entities vectors splitting
+sequences sequences.deep strings xml.entities
-xmode.code2html ;
+vectors splitting xmode.code2html urls.encoding ;
 IN: farkup
 
 SYMBOL: relative-link-prefix
 SYMBOL: disable-images?
 SYMBOL: link-no-follow?
+SYMBOL: line-breaks?
 
-TUPLE: heading1 obj ;
+TUPLE: heading1 child ;
-TUPLE: heading2 obj ;
+TUPLE: heading2 child ;
-TUPLE: heading3 obj ;
+TUPLE: heading3 child ;
-TUPLE: heading4 obj ;
+TUPLE: heading4 child ;
-TUPLE: strong obj ;
+TUPLE: strong child ;
-TUPLE: emphasis obj ;
+TUPLE: emphasis child ;
-TUPLE: superscript obj ;
+TUPLE: superscript child ;
-TUPLE: subscript obj ;
+TUPLE: subscript child ;
-TUPLE: inline-code obj ;
+TUPLE: inline-code child ;
-TUPLE: paragraph obj ;
+TUPLE: paragraph child ;
-TUPLE: list-item obj ;
+TUPLE: list-item child ;
-TUPLE: list obj ;
+TUPLE: unordered-list child ;
-TUPLE: table obj ;
+TUPLE: ordered-list child ;
-TUPLE: table-row obj ;
+TUPLE: table child ;
+TUPLE: table-row child ;
 TUPLE: link href text ;
 TUPLE: image href text ;
 TUPLE: code mode string ;
+TUPLE: line ;
+TUPLE: line-break ;
 
 : absolute-url? ( string -- ? )
     { "http://" "https://" "ftp://" } [ head? ] with contains? ;
@@ -34,9 +38,9 @@ TUPLE: code mode string ;
 : simple-link-title ( string -- string' )
     dup absolute-url? [ "/" last-split1 swap or ] unless ;
 
-EBNF: farkup
+EBNF: parse-farkup
 nl               = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]]
-2nl              = nl nl
+whitespace       = " " | "\t" | nl
 
 heading1      = "=" (!("=" | nl).)+ "="
     => [[ second >string heading1 boa ]]
@@ -50,6 +54,10 @@ heading3      = "===" (!("=" | nl).)+ "==="
 heading4      = "====" (!("=" | nl).)+ "===="
     => [[ second >string heading4 boa ]]
 
+heading          = heading4 | heading3 | heading2 | heading1
+
+
+
 strong        = "*" (!("*" | nl).)+ "*"
     => [[ second >string strong boa ]]
 
@@ -65,8 +73,6 @@ subscript     = "~" (!("~" | nl).)+ "~"
 inline-code   = "%" (!("%" | nl).)+ "%"
     => [[ second >string inline-code boa ]]
 
-escaped-char  = "\" .                => [[ second ]]
-
 link-content     = (!("|"|"]").)+
 
 image-link       = "[[image:" link-content  "|" link-content "]]"
@@ -82,44 +88,73 @@ labelled-link    = "[[" link-content "|" link-content "]]"
 
 link             = image-link | labelled-link | simple-link
 
-heading          = heading4 | heading3 | heading2 | heading1
+escaped-char  = "\" .
+    => [[ second 1string ]]
 
 inline-tag       = strong | emphasis | superscript | subscript | inline-code
                    | link | escaped-char
 
+
+
 inline-delimiter = '*' | '_' | '^' | '~' | '%' | '\' | '['
 
-table-column     = (list | (!(nl | inline-delimiter | '|').)+ | inline-tag | inline-delimiter  ) '|'
+cell             = (!(inline-delimiter | '|' | nl).)+
+    => [[ >string ]]
+    
+table-column     = (list | cell | inline-tag | inline-delimiter  ) '|'
     => [[ first ]]
 table-row        = "|" (table-column)+
     => [[ second table-row boa ]]
 table            =  ((table-row nl => [[ first ]] )+ table-row? | table-row)
     => [[ table boa ]]
 
-paragraph-item = ( table | (!(nl | code | heading | inline-delimiter | table ).) | inline-tag | inline-delimiter)+
+text = (!(nl | code | heading | inline-delimiter | table ).)+
-paragraph = ((paragraph-item nl => [[ first ]])+ nl+ => [[ first ]]
+    => [[ >string ]]
-             | (paragraph-item nl)+ paragraph-item?
+
+paragraph-nl-item = nl list
+    | nl line
+    | nl => [[ line-breaks? get [ drop line-break new ] when ]]
+paragraph-item = (table | code | text | inline-tag | inline-delimiter)+
+paragraph = ((paragraph-item paragraph-nl-item)+ nl+ => [[ first ]]
+             | (paragraph-item paragraph-nl-item)+ paragraph-item?
              | paragraph-item)
     => [[ paragraph boa ]]
-                
-list-item      = '-' ((!(inline-delimiter | nl).)+ | inline-tag)*
-    => [[ second list-item boa ]]
-list = ((list-item nl)+ list-item? | list-item)
-    => [[ list boa ]]
 
-code       =  '[' (!('{' | nl | '[').)+ '{' (!("}]").)+ "}]"
+
+list-item     = (cell | inline-tag | inline-delimiter)*
+
+ordered-list-item      = '#' list-item
+    => [[ second list-item boa ]]
+ordered-list = ((ordered-list-item nl)+ ordered-list-item? | ordered-list-item)
+    => [[ ordered-list boa ]]
+
+unordered-list-item    = '-' list-item
+    => [[ second list-item boa ]]
+unordered-list = ((unordered-list-item nl)+ unordered-list-item? | unordered-list-item)
+    => [[ unordered-list boa ]]
+
+list = ordered-list | unordered-list
+
+
+line = '___'
+    => [[ drop line new ]]
+
+
+named-code
+           =  '[' (!('{' | whitespace | '[').)+ '{' (!("}]").)+ "}]"
     => [[ [ second >string ] [ fourth >string ] bi code boa ]]
 
 simple-code
            = "[{" (!("}]").)+ "}]"
     => [[ second f swap code boa ]]
 
+code = named-code | simple-code
+
+
 stand-alone
-           = (code | simple-code | heading | list | table | paragraph | nl)*
+           = (line | code | heading | list | table | paragraph | nl)*
 ;EBNF
 
-
-
 : invalid-url "javascript:alert('Invalid URL in farkup');" ;
 
 : check-url ( href -- href' )
@@ -136,7 +171,7 @@ stand-alone
 
 : write-link ( href text -- )
     escape-link
-    [ <a =href link-no-follow? get [ "true" =nofollow ] when a> ]
+    [ <a url-encode =href link-no-follow? get [ "true" =nofollow ] when a> ]
     [ write </a> ]
     bi* ;
 
@@ -146,7 +181,7 @@ stand-alone
         <strong> "Images are not allowed" write </strong>
     ] [
         escape-link
-        [ <img =src ] [ [ =alt ] unless-empty img/> ] bi*
+        [ <img url-encode =src ] [ [ =alt ] unless-empty img/> ] bi*
     ] if ;
 
 : render-code ( string mode -- string' )
@@ -161,31 +196,33 @@ GENERIC: (write-farkup) ( farkup -- )
 : <foo.> ( string -- ) <foo> write ;
 : </foo.> ( string -- ) </foo> write ;
 : in-tag. ( obj quot string -- ) [ <foo.> call ] keep </foo.> ; inline
-M: heading1 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h1" in-tag. ;
+M: heading1 (write-farkup) [ child>> (write-farkup) ] "h1" in-tag. ;
-M: heading2 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h2" in-tag. ;
+M: heading2 (write-farkup) [ child>> (write-farkup) ] "h2" in-tag. ;
-M: heading3 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h3" in-tag. ;
+M: heading3 (write-farkup) [ child>> (write-farkup) ] "h3" in-tag. ;
-M: heading4 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h4" in-tag. ;
+M: heading4 (write-farkup) [ child>> (write-farkup) ] "h4" in-tag. ;
-M: strong (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "strong" in-tag. ;
+M: strong (write-farkup) [ child>> (write-farkup) ] "strong" in-tag. ;
-M: emphasis (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "em" in-tag. ;
+M: emphasis (write-farkup) [ child>> (write-farkup) ] "em" in-tag. ;
-M: superscript (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "sup" in-tag. ;
+M: superscript (write-farkup) [ child>> (write-farkup) ] "sup" in-tag. ;
-M: subscript (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "sub" in-tag. ;
+M: subscript (write-farkup) [ child>> (write-farkup) ] "sub" in-tag. ;
-M: inline-code (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "code" in-tag. ;
+M: inline-code (write-farkup) [ child>> (write-farkup) ] "code" in-tag. ;
-M: list-item (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "li" in-tag. ;
+M: list-item (write-farkup) [ child>> (write-farkup) ] "li" in-tag. ;
-M: list (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "ul" in-tag. ;
+M: unordered-list (write-farkup) [ child>> (write-farkup) ] "ul" in-tag. ;
-M: paragraph (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "p" in-tag. ;
+M: ordered-list (write-farkup) [ child>> (write-farkup) ] "ol" in-tag. ;
-M: link (write-farkup) ( obj -- ) [ href>> ] [ text>> ] bi write-link ;
+M: paragraph (write-farkup) [ child>> (write-farkup) ] "p" in-tag. ;
-M: image (write-farkup) ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ;
+M: link (write-farkup) [ href>> ] [ text>> ] bi write-link ;
-M: code (write-farkup) ( obj -- ) [ string>> ] [ mode>> ] bi render-code ;
+M: image (write-farkup) [ href>> ] [ text>> ] bi write-image-link ;
+M: code (write-farkup) [ string>> ] [ mode>> ] bi render-code ;
+M: line (write-farkup) drop <hr/> ;
+M: line-break (write-farkup) drop <br/> nl ;
 M: table-row (write-farkup) ( obj -- )
-    obj>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ;
+    child>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ;
-M: table (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "table" in-tag. ;
+M: table (write-farkup) [ child>> (write-farkup) ] "table" in-tag. ;
-M: fixnum (write-farkup) ( obj -- ) write1 ;
+M: string (write-farkup) escape-string write ;
-M: string (write-farkup) ( obj -- ) write ;
+M: vector (write-farkup) [ (write-farkup) ] each ;
-M: vector (write-farkup) ( obj -- ) [ (write-farkup) ] each ;
+M: f (write-farkup) drop ;
-M: f (write-farkup) ( obj -- ) drop ;
 
 : write-farkup ( string -- )
-    farkup (write-farkup) ;
+    parse-farkup (write-farkup) ;
 
 : convert-farkup ( string -- string' )
-    farkup [ (write-farkup) ] with-string-writer ;
+    parse-farkup [ (write-farkup) ] with-string-writer ;

basis/furnace/actions/actions.factor

@@ -14,7 +14,8 @@ html.elements
 html.components
 html.components
 html.templates.chloe
-html.templates.chloe.syntax ;
+html.templates.chloe.syntax
+html.templates.chloe.compiler ;
 IN: furnace.actions
 
 SYMBOL: params
@@ -29,7 +30,8 @@ SYMBOL: rest
         </ul>
     ] unless-empty ;
 
-CHLOE: validation-messages drop render-validation-messages ;
+CHLOE: validation-messages
+    drop [ render-validation-messages ] [code] ;
 
 TUPLE: action rest authorize init display validate submit ;
 
@@ -77,14 +79,14 @@ TUPLE: action rest authorize init display validate submit ;
 
 : revalidate-url ( -- url/f )
     revalidate-url-key param
-    dup [ >url [ same-host? ] keep and ] when ;
+    dup [ >url ensure-port [ same-host? ] keep and ] when ;
 
 : validation-failed ( -- * )
     post-request? revalidate-url and [
         begin-conversation
         nested-forms-key param " " split harvest nested-forms cset
         form get form cset
-        <redirect>
+        <continue-conversation>
     ] [ <400> ] if*
     exit-with ;
 

basis/furnace/actions/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/furnace/actions/summary.txt

@@ -0,0 +1 @@
+Actions and form validation

basis/furnace/actions/tags.txt

@@ -0,0 +1 @@
+web

basis/furnace/alloy/alloy.factor

@@ -3,6 +3,7 @@
 USING: kernel sequences db.tuples alarms calendar db fry
 furnace.db
 furnace.cache
+furnace.asides
 furnace.referrer
 furnace.sessions
 furnace.conversations
@@ -10,20 +11,24 @@ furnace.auth.providers
 furnace.auth.login.permits ;
 IN: furnace.alloy
 
-: <alloy> ( responder db params -- responder' )
+: state-classes { session aside conversation permit } ; inline
-    '[
-        <conversations>
-        <sessions>
-        _ _ <db-persistence>
-        <check-form-submissions>
-    ] call ;
-
-: state-classes { session conversation permit } ; inline
 
 : init-furnace-tables ( -- )
     state-classes ensure-tables
     user ensure-table ;
 
+: <alloy> ( responder db params -- responder' )
+    [ [ init-furnace-tables ] with-db ]
+    [
+        [
+            <asides>
+            <conversations>
+            <sessions>
+        ] 2dip
+        <db-persistence>
+        <check-form-submissions>
+    ] 2bi ;
+
 : start-expiring ( db params -- )
     '[
         _ _ [ state-classes [ expire-state ] each ] with-db

basis/furnace/alloy/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/furnace/alloy/summary.txt

@@ -0,0 +1 @@
+Convenience responder combines several features

basis/furnace/alloy/tags.txt

@@ -0,0 +1 @@
+web

basis/furnace/asides/asides.factor

@@ -0,0 +1,111 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces assocs kernel sequences accessors hashtables
+urls db.types db.tuples math.parser fry logging combinators
+html.templates.chloe.syntax
+http http.server http.server.filters http.server.redirection
+furnace
+furnace.cache
+furnace.sessions
+furnace.redirection ;
+IN: furnace.asides
+
+TUPLE: aside < server-state
+session method url post-data ;
+
+: <aside> ( id -- aside )
+    aside new-server-state ;
+
+aside "ASIDES" {
+    { "session" "SESSION" BIG-INTEGER +not-null+ }
+    { "method" "METHOD" { VARCHAR 10 } }
+    { "url" "URL" URL }
+    { "post-data" "POST_DATA" FACTOR-BLOB }
+} define-persistent
+
+: aside-id-key "__a" ;
+
+TUPLE: asides < server-state-manager ;
+
+: <asides> ( responder -- responder' )
+    asides new-server-state-manager ;
+
+SYMBOL: aside-id
+
+: get-aside ( id -- aside )
+    dup [ aside get-state ] when check-session ;
+
+: request-aside-id ( request -- id )
+    aside-id-key swap request-params at string>number ;
+
+: request-aside ( request -- aside )
+    request-aside-id get-aside ;
+
+: set-aside ( aside -- )
+    [ id>> aside-id set ] when* ;
+
+: init-asides ( asides -- )
+    asides set
+    request get request-aside-id
+    get-aside
+    set-aside ;
+
+M: asides call-responder*
+    [ init-asides ] [ asides set ] [ call-next-method ] tri ;
+
+: touch-aside ( aside -- )
+    asides get touch-state ;
+
+: begin-aside ( url -- )
+    f <aside>
+        swap >>url
+        session get id>> >>session
+        request get method>> >>method
+        request get post-data>> >>post-data
+    [ touch-aside ] [ insert-tuple ] [ set-aside ] tri ;
+
+: end-aside-post ( aside -- response )
+    [ url>> ] [ post-data>> ] bi
+    request [
+        clone
+            swap >>post-data
+            over >>url
+    ] change
+    [ url set ] [ path>> split-path ] bi
+    asides get responder>> call-responder ;
+
+\ end-aside-post DEBUG add-input-logging
+
+ERROR: end-aside-in-get-error ;
+
+: move-on ( id -- response )
+    post-request? [ end-aside-in-get-error ] unless
+    dup method>> {
+        { "GET" [ url>> <redirect> ] }
+        { "HEAD" [ url>> <redirect> ] }
+        { "POST" [ end-aside-post ] }
+    } case ;
+
+: end-aside ( default -- response )
+    aside-id get aside-id off get-aside [ move-on ] [ <redirect> ] ?if ;
+
+M: asides link-attr ( tag -- )
+    drop
+    "aside" optional-attr {
+        { "none" [ aside-id off ] }
+        { "begin" [ url get begin-aside ] }
+        { "current" [ ] }
+        { f [ ] }
+    } case ;
+
+M: asides modify-query ( query asides -- query' )
+    drop
+    aside-id get [
+        aside-id-key associate assoc-union
+    ] when* ;
+
+M: asides modify-form ( asides -- )
+    drop
+    aside-id get
+    aside-id-key
+    hidden-form-field ;

basis/furnace/asides/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/furnace/asides/summary.txt

@@ -0,0 +1 @@
+Asides start an interaction which can return to the original page

basis/furnace/asides/tags.txt

@@ -0,0 +1 @@
+web

basis/furnace/auth/auth.factor

@@ -3,7 +3,7 @@
 USING: accessors assocs namespaces kernel sequences sets
 destructors combinators fry logging
 io.encodings.utf8 io.encodings.string io.binary random
-checksums checksums.sha2
+checksums checksums.sha2 urls
 html.forms
 http.server
 http.server.filters
@@ -60,6 +60,10 @@ TUPLE: realm < dispatcher name users checksum secure ;
 
 GENERIC: login-required* ( description capabilities realm -- response )
 
+GENERIC: user-registered ( user realm -- response )
+
+M: object user-registered 2drop URL" $realm" <redirect> ;
+
 GENERIC: init-realm ( realm -- )
 
 GENERIC: logged-in-username ( realm -- username )

basis/furnace/auth/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/furnace/auth/basic/summary.txt

@@ -0,0 +1 @@
+Basic client authentication

basis/furnace/auth/features/deactivate-user/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/furnace/auth/features/deactivate-user/deactivate-user.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel assocs namespaces accessors db db.tuples urls
 http.server.dispatchers
-furnace.conversations
+furnace.asides
 furnace.actions
 furnace.auth
 furnace.auth.providers ;

basis/furnace/auth/features/deactivate-user/summary.txt

@@ -0,0 +1 @@
+Allow users to deactivate their accounts

basis/furnace/auth/features/deactivate-user/tags.txt

@@ -0,0 +1 @@
+web

basis/furnace/auth/features/edit-profile/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/furnace/auth/features/edit-profile/edit-profile.factor

@@ -3,8 +3,8 @@
 USING: kernel accessors namespaces sequences assocs
 validators urls html.forms http.server.dispatchers
 furnace.auth
-furnace.actions
+furnace.asides
-furnace.conversations ;
+furnace.actions ;
 IN: furnace.auth.features.edit-profile
 
 : <edit-profile-action> ( -- action )

basis/furnace/auth/features/edit-profile/edit-profile.xml

@@ -4,7 +4,7 @@
 
 	<t:title>Edit Profile</t:title>
 
-	<t:form t:action="$realm/edit-profile">
+	<t:form t:action="$realm/edit-profile" autocomplete="off">
 
 	<table>
 	
@@ -61,7 +61,7 @@
 	</table>
 
 	<p>
-		<input type="submit" value="Update" />
+		<button>Update</button>
 		<t:validation-messages />
 	</p>
 

basis/furnace/auth/features/edit-profile/summary.txt

@@ -0,0 +1 @@
+Allow users to edit account info

basis/furnace/auth/features/edit-profile/tags.txt

@@ -0,0 +1 @@
+web

basis/furnace/auth/features/recover-password/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/furnace/auth/features/recover-password/recover-1.xml

@@ -32,7 +32,7 @@
 
 		</table>
 
-		<input type="submit" value="Recover password" />
+		<button>Recover password</button>
 
 	</t:form>
 

basis/furnace/auth/features/recover-password/recover-3.xml

@@ -31,7 +31,7 @@
 		</table>
 
 		<p>
-			<input type="submit" value="Set password" />
+			<button>Set password</button>
 			<t:validation-messages />
 		</p>
 

basis/furnace/auth/features/recover-password/recover-password.factor

@@ -19,7 +19,7 @@ SYMBOL: lost-password-from
         [ username>> "username" set-query-param ]
         [ ticket>> "ticket" set-query-param ]
         bi
-    adjust-url relative-to-request ;
+    adjust-url ;
 
 : password-email ( user -- email )
     <email>

basis/furnace/auth/features/recover-password/summary.txt

@@ -0,0 +1 @@
+Allow users to receive a new password

basis/furnace/auth/features/recover-password/tags.txt

@@ -0,0 +1 @@
+web

basis/furnace/auth/features/registration/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/furnace/auth/features/registration/register.xml

@@ -4,7 +4,7 @@
 
 	<t:title>New User Registration</t:title>
 
-	<t:form t:action="register">
+	<t:form t:action="register" autocomplete="off">
 
 		<table>
 
@@ -62,7 +62,7 @@
 
 		<p>
 
-			<input type="submit" value="Register" />
+			<button>Register</button>
 			<t:validation-messages />
 
 		</p>

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

@@ -33,8 +33,7 @@ IN: furnace.auth.features.registration
             users new-user [ user-exists ] unless*
 
             realm get init-user-profile
-
+            realm get user-registered
-            URL" $realm" <redirect>
         ] >>submit
     <auth-boilerplate>
     <secure-realm-only> ;

basis/furnace/auth/features/registration/summary.txt

@@ -0,0 +1 @@
+Allow new users to register from the login page

basis/furnace/auth/features/registration/tags.txt

@@ -0,0 +1 @@
+web

basis/furnace/auth/login/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/furnace/auth/login/login.factor

@@ -5,6 +5,7 @@ calendar validators urls logging html.forms
 http http.server http.server.dispatchers
 furnace
 furnace.auth
+furnace.asides
 furnace.actions
 furnace.sessions
 furnace.utilities
@@ -93,9 +94,18 @@ SYMBOL: capabilities
         [ logout ] >>submit ;
 
 M: login-realm login-required* ( description capabilities login -- response )
-    begin-aside
+    begin-conversation
-    [ description cset ] [ capabilities cset ] [ drop ] tri*
+    [ description cset ] [ capabilities cset ] [ secure>> ] tri*
-    URL" $realm/login" >secure-url <redirect> ;
+    [
+        url get >secure-url begin-aside
+        URL" $realm/login" >secure-url <continue-conversation>
+    ] [
+        url get begin-aside
+        URL" $realm/login" <continue-conversation>
+    ] if ;
+
+M: login-realm user-registered ( user realm -- )
+    drop successful-login ;
 
 : <login-realm> ( responder name -- auth )
     login-realm new-realm

basis/furnace/auth/login/login.xml

@@ -35,7 +35,7 @@
 
 		<p>
 
-			<input type="submit" value="Log in" />
+			<button>Log in</button>
 			<t:validation-messages />
 
 		</p>

basis/furnace/auth/login/permits/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/furnace/auth/login/permits/tags.txt

@@ -0,0 +1 @@
+web

basis/furnace/auth/login/summary.txt

@@ -0,0 +1 @@
+Login page authentication