Merge branch 'master' into new_ui

basis/db/sqlite/lib/lib.factor

@@ -5,8 +5,7 @@ namespaces sequences db.sqlite.ffi db combinators
 continuations db.types calendar.format serialize
 io.streams.byte-array byte-arrays io.encodings.binary
 io.backend db.errors present urls io.encodings.utf8
-io.encodings.string accessors shuffle io prettyprint
+io.encodings.string accessors shuffle io db.private ;
-db.private ;
 IN: db.sqlite.lib
 
 ERROR: sqlite-error < db-error n string ;
@@ -125,8 +124,7 @@ ERROR: sqlite-sql-error < sql-error n string ;
     ] if* (sqlite-bind-type) ;
 
 : sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ;
-: sqlite-reset ( handle -- )
+: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ;
-"resetting: " write dup . sqlite3_reset sqlite-check-result ;
 : sqlite-clear-bindings ( handle -- )
     sqlite3_clear_bindings sqlite-check-result ;
 : sqlite-#columns ( query -- int ) sqlite3_column_count ;

basis/db/sqlite/sqlite-tests.factor

@@ -1,6 +1,7 @@
 USING: io io.files io.files.temp io.directories io.launcher
 kernel namespaces prettyprint tools.test db.sqlite db sequences
-continuations db.types db.tuples unicode.case ;
+continuations db.types db.tuples unicode.case accessors arrays
+sorting ;
 IN: db.sqlite.tests
 
 : db-path ( -- path ) "test.db" temp-file ;
@@ -74,8 +75,9 @@ IN: db.sqlite.tests
     ] with-db
 ] unit-test
 
+[ \ swap ensure-table ] must-fail
+
 ! You don't need a primary key
-USING: accessors arrays sorting ;
 TUPLE: things one two ;
 
 things "THINGS" {
@@ -115,7 +117,7 @@ hi "HELLO" {
         1 <foo> insert-tuple
         f <foo> select-tuple
         1 1 <hi> insert-tuple
-        f <hi> select-tuple
+        f f <hi> select-tuple
         hi drop-table
         foo drop-table
     ] with-db
@@ -158,10 +160,9 @@ watch "WATCH" {
         show new insert-tuple
         show new select-tuple
         "littledan" f user boa select-tuple
+        swap [ username>> ] [ id>> ] bi*
         watch boa insert-tuple
         watch new select-tuple
         user>> f user boa select-tuple
     ] with-db
 ] unit-test
-
-[ \ swap ensure-table ] must-fail

basis/db/sqlite/sqlite.factor

@@ -1,12 +1,12 @@
 ! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien arrays assocs classes compiler db hashtables
-io.files kernel math math.parser namespaces prettyprint
+io.files kernel math math.parser namespaces prettyprint fry
 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 db.tuples.private interpolate
-io.streams.string multiline make db.private ;
+io.streams.string multiline make db.private sequences.deep ;
 IN: db.sqlite
 
 TUPLE: sqlite-db path ;
@@ -126,30 +126,6 @@ M: sqlite-statement query-results ( query -- result-set )
     dup handle>> sqlite-result-set new-result-set
     dup advance-row ;
 
-M: sqlite-db-connection create-sql-statement ( class -- statement )
-    [
-        dupd
-        "create table " 0% 0%
-        "(" 0% [ ", " 0% ] [
-            dup "sql-spec" set
-            dup column-name>> [ "table-id" set ] [ 0% ] bi
-            " " 0%
-            dup type>> lookup-create-type 0%
-            modifiers 0%
-        ] interleave
-
-        find-primary-key [
-            ", " 0%
-            "primary key(" 0%
-            [ "," 0% ] [ column-name>> 0% ] interleave
-            ")" 0%
-        ] unless-empty
-        ");" 0%
-    ] query-make ;
-
-M: sqlite-db-connection drop-sql-statement ( class -- statement )
-    [ "drop table " 0% 0% ";" 0% drop ] query-make ;
-
 M: sqlite-db-connection <insert-db-assigned-statement> ( tuple -- statement )
     [
         "insert into " 0% 0%
@@ -225,7 +201,7 @@ M: sqlite-db-connection persistent-table ( -- assoc )
 : insert-trigger ( -- string )
     [
     <"
-        CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id
+        CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
         BEFORE INSERT ON ${table-name}
         FOR EACH ROW BEGIN
             SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
@@ -237,7 +213,7 @@ M: sqlite-db-connection persistent-table ( -- assoc )
 : insert-trigger-not-null ( -- string )
     [
     <"
-        CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id
+        CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
         BEFORE INSERT ON ${table-name}
         FOR EACH ROW BEGIN
             SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
@@ -247,10 +223,17 @@ M: sqlite-db-connection persistent-table ( -- assoc )
     "> interpolate
     ] with-string-writer ;
 
+: drop-insert-trigger ( -- string )
+    [
+        <"
+            DROP TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id;
+        "> interpolate
+    ] with-string-writer ;
+
 : update-trigger ( -- string )
     [
     <"
-        CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id
+        CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
         BEFORE UPDATE ON ${table-name}
         FOR EACH ROW BEGIN
             SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
@@ -262,7 +245,7 @@ M: sqlite-db-connection persistent-table ( -- assoc )
 : update-trigger-not-null ( -- string )
     [
     <"
-        CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id
+        CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
         BEFORE UPDATE ON ${table-name}
         FOR EACH ROW BEGIN
             SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
@@ -272,10 +255,17 @@ M: sqlite-db-connection persistent-table ( -- assoc )
     "> interpolate
     ] with-string-writer ;
 
+: drop-update-trigger ( -- string )
+    [
+        <"
+            DROP TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id;
+        "> interpolate
+    ] with-string-writer ;
+
 : delete-trigger-restrict ( -- string )
     [
     <"
-        CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id
+        CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
         BEFORE DELETE ON ${foreign-table-name}
         FOR EACH ROW BEGIN
             SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
@@ -284,10 +274,17 @@ M: sqlite-db-connection persistent-table ( -- assoc )
     "> interpolate
     ] with-string-writer ;
 
+: drop-delete-trigger-restrict ( -- string )
+    [
+        <"
+            DROP TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id;
+        "> interpolate
+    ] with-string-writer ;
+
 : delete-trigger-cascade ( -- string )
     [
     <"
-        CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id
+        CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
         BEFORE DELETE ON ${foreign-table-name}
         FOR EACH ROW BEGIN
             DELETE from ${table-name} WHERE ${table-id} = OLD.${foreign-table-id};
@@ -295,6 +292,13 @@ M: sqlite-db-connection persistent-table ( -- assoc )
     "> interpolate
     ] with-string-writer ;
 
+: drop-delete-trigger-cascade ( -- string )
+    [
+        <"
+            DROP TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id;
+        "> interpolate
+    ] with-string-writer ;
+
 : can-be-null? ( -- ? )
     "sql-spec" get modifiers>> [ +not-null+ = ] any? not ;
 
@@ -318,14 +322,69 @@ M: sqlite-db-connection persistent-table ( -- assoc )
         delete-trigger-restrict sqlite-trigger,
     ] if ;
 
+: drop-sqlite-triggers ( -- )
+    drop-insert-trigger sqlite-trigger,
+    drop-update-trigger sqlite-trigger,
+    delete-cascade? [
+        drop-delete-trigger-cascade sqlite-trigger,
+    ] [
+        drop-delete-trigger-restrict sqlite-trigger,
+    ] if ;
+
+: db-triggers ( sql-specs word -- )
+    '[
+        [ modifiers>> [ +foreign-id+ = ] deep-any? ] filter
+        [
+            [ class>> db-table-name "db-table" set ]
+            [ column-name>> "table-id" set ]
+            [
+                modifiers>> [ [ +foreign-id+ = ] deep-any? ] filter
+                [
+                    [ second db-table-name "foreign-table-name" set ]
+                    [ third "foreign-table-id" set ] bi
+                    _ execute
+                ] each
+            ] tri
+        ] each
+    ] call ;
+
+: sqlite-create-table ( sql-specs class-name -- )
+    [
+        "create table " 0% 0%
+        "(" 0% [ ", " 0% ] [
+            dup "sql-spec" set
+            dup column-name>> [ "table-id" set ] [ 0% ] bi
+            " " 0%
+            dup type>> lookup-create-type 0%
+            modifiers 0%
+        ] interleave
+    ] [
+        drop
+        find-primary-key [
+            ", " 0%
+            "primary key(" 0%
+            [ "," 0% ] [ column-name>> 0% ] interleave
+            ")" 0%
+        ] unless-empty
+        ");" 0%
+    ] 2bi ;
+
+M: sqlite-db-connection create-sql-statement ( class -- statement )
+    [
+        ! specs name
+        [ sqlite-create-table ]
+        [ drop \ create-sqlite-triggers db-triggers ] 2bi
+    ] query-make ;
+
+M: sqlite-db-connection drop-sql-statement ( class -- statements )
+    [
+        [ nip "drop table " 0% 0% ";" 0% ]
+        [ drop \ drop-sqlite-triggers db-triggers ] 2bi
+    ] query-make ;
+
 M: sqlite-db-connection compound ( string seq -- new-string )
     over {
         { "default" [ first number>string " " glue ] }
-        { "references" [
+        { "references" [ >reference-string ] }
-            [ >reference-string ] keep
-            first2 [ db-table-name "foreign-table-name" set ]
-            [ "foreign-table-id" set ] bi*
-            create-sqlite-triggers
-        ] }
         [ 2drop ]
     } case ;

basis/db/tuples/tuples.factor

@@ -3,7 +3,8 @@
 USING: arrays assocs classes db kernel namespaces
 classes.tuple words sequences slots math accessors
 math.parser io prettyprint db.types continuations
-destructors mirrors sets db.types db.private ;
+destructors mirrors sets db.types db.private fry
+combinators.short-circuit ;
 IN: db.tuples
 
 HOOK: create-sql-statement db-connection ( class -- object )
@@ -29,7 +30,7 @@ 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>> _ set-slot-named ] 2each
     ] keep ;
 
 : query-tuples ( exemplar-tuple statement -- seq )
@@ -98,33 +99,49 @@ M: query >query clone ;
 
 M: tuple >query <query> swap >>tuple ;
 
+ERROR: no-defined-persistent object ;
+
+: ensure-defined-persistent ( object -- object )
+    dup { [ class? ] [ "db-table" word-prop ] } 1&& [
+        no-defined-persistent
+    ] unless ;
+
 : create-table ( class -- )
+    ensure-defined-persistent
     create-sql-statement [ execute-statement ] with-disposals ;
 
 : drop-table ( class -- )
+    ensure-defined-persistent
     drop-sql-statement [ execute-statement ] with-disposals ;
 
 : recreate-table ( class -- )
+    ensure-defined-persistent
     [
-        [ drop-sql-statement [ execute-statement ] with-disposals
+        '[
-        ] curry ignore-errors
+            _ drop-sql-statement [ execute-statement ] with-disposals
+        ] ignore-errors
     ] [ create-table ] bi ;
 
-: ensure-table ( class -- ) [ create-table ] curry ignore-errors ;
+: ensure-table ( class -- )
+    ensure-defined-persistent
+    '[ _ create-table ] ignore-errors ;
 
 : ensure-tables ( classes -- ) [ ensure-table ] each ;
 
 : insert-tuple ( tuple -- )
-    dup class db-columns find-primary-key db-assigned-id-spec?
+    dup class ensure-defined-persistent
+    db-columns find-primary-key db-assigned-id-spec?
     [ insert-db-assigned-statement ] [ insert-user-assigned-statement ] if ;
 
 : update-tuple ( tuple -- )
-    dup class
+    dup class ensure-defined-persistent
     db-connection get update-statements>> [ <update-tuple-statement> ] cache
     [ bind-tuple ] keep execute-statement ;
 
 : delete-tuples ( tuple -- )
-    dup dup class <delete-tuples-statement> [
+    dup
+    dup class ensure-defined-persistent
+    <delete-tuples-statement> [
         [ bind-tuple ] keep execute-statement
     ] with-disposal ;
 
@@ -132,8 +149,8 @@ M: tuple >query <query> swap >>tuple ;
     >query [ tuple>> ] [ query>statement ] bi do-select ;
 
 : select-tuple ( query/tuple -- tuple/f )
-    >query 1 >>limit [ tuple>> ] [ query>statement ] bi do-select
+    >query 1 >>limit [ tuple>> ] [ query>statement ] bi
-    [ f ] [ first ] if-empty ;
+    do-select [ f ] [ first ] if-empty ;
 
 : count-tuples ( query/tuple -- n )
     >query [ tuple>> ] [ <count-statement> ] bi do-count

extra/math/dual/dual-docs.factor

@@ -10,84 +10,6 @@ HELP: <dual>
 }
 { $description "Creates a dual number from its ordinary and epsilon parts." } ;
 
-HELP: d*
-{ $values
-    { "x" dual } { "y" dual }
-    { "x*y" dual }
-}
-{ $description "Multiply dual numbers." } ;
-
-HELP: d+
-{ $values
-    { "x" dual } { "y" dual }
-    { "x+y" dual }
-}
-{ $description "Add dual numbers." } ;
-
-HELP: d-
-{ $values
-    { "x" dual } { "y" dual }
-    { "x-y" dual }
-}
-{ $description "Subtract dual numbers." } ;
-
-HELP: d/
-{ $values
-    { "x" dual } { "y" dual }
-    { "x/y" dual }
-}
-{ $description "Divide dual numbers." } 
-{ $errors "Throws an error if the ordinary part of " { $snippet "x" } " is zero." } ;
-
-HELP: d^
-{ $values
-    { "x" dual } { "y" dual }
-    { "x^y" dual }
-}
-{ $description "Raise a dual number to a (possibly dual) power" } ;
-
-HELP: dabs
-{ $values
-     { "x" dual }
-     { "|x|" dual }
-}
-{ $description "Absolute value of a dual number." } ;
-
-HELP: dacosh
-{ $values
-     { "x" dual }
-     { "y" dual }
-}
-{ $description "Inverse hyberbolic cosine of a dual number." } ;
-
-HELP: dasinh
-{ $values
-     { "x" dual }
-     { "y" dual }
-}
-{ $description "Inverse hyberbolic sine of a dual number." } ;
-
-HELP: datanh
-{ $values
-     { "x" dual }
-     { "y" dual }
-}
-{ $description "Inverse hyberbolic tangent of a dual number." } ;
-
-HELP: dneg
-{ $values
-     { "x" dual }
-     { "-x" dual }
-}
-{ $description "Negative of a dual number." } ;
-
-HELP: drecip
-{ $values
-     { "x" dual }
-     { "1/x" dual }
-}
-{ $description "Reciprocal of a dual number." } ;
-
 HELP: define-dual
 { $values
     { "word" word }
@@ -128,5 +50,4 @@ $nl
 "Dual numbers are ordered pairs " { $snippet "<o,e>"} "--an ordinary part and an epsilon part--with component-wise addition and multiplication defined by "{ $snippet "<o1,e1>*<o2,e2> = <o1*o2,e1*o2 + e2*o1>" } ". They are analagous to complex numbers with " { $snippet "i^2 = 0" } "instead of " { $snippet "i^2 = -1" } ". For well-behaved functions " { $snippet "f" } ", " { $snippet "f(<o1,e1>) = f(o1) + e1*f'(o1)" } ", where " { $snippet "f'"} " is the derivative of " { $snippet "f" } "."
 ;
 
-
 ABOUT: "math.dual"

extra/math/dual/dual.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2009 Jason W. Merrill.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math math.functions math.derivatives accessors
-    macros words effects vocabs sequences generalizations fry
+    macros generic compiler.units words effects vocabs
-    combinators.smart generic compiler.units ;
+    sequences arrays assocs generalizations fry make
+    combinators.smart help help.markup ;
 
 IN: math.dual
 
@@ -48,6 +49,19 @@ MACRO: chain-rule ( word -- e )
     tri
     '[ [ @ _ @ ] sum-outputs ] ;
 
+: set-dual-help ( word dword -- ) 
+    [ swap
+        [ stack-effect [ in>> ] [ out>> ] bi append 
+            [ dual ] { } map>assoc { $values } prepend
+        ]
+        [ [ { $description } % "Version of " , 
+                   { $link } swap suffix , 
+                   " extended to work on dual numbers." , ] 
+            { } make
+        ]
+        bi* 2array
+    ] keep set-word-help ;
+
 PRIVATE>
 
 MACRO: dual-op ( word -- )
@@ -58,13 +72,11 @@ MACRO: dual-op ( word -- )
     '[ _ @ @ <dual> ] ;
 
 : define-dual ( word -- )
-    [ 
+    dup name>> "d" prepend "math.dual" create
-        [ stack-effect ] 
+    [ [ stack-effect ] dip set-stack-effect ]
-        [ name>> "d" prepend "math.dual" create ]
+    [ set-dual-help ]
-        bi [ set-stack-effect ] keep
+    [ swap '[ _ dual-op ] define ]
-    ]
+    2tri ;
-    keep
-    '[ _ dual-op ] define ;
 
 ! Specialize math functions to operate on dual numbers.
 [ all-words [ "derivative" word-prop ] filter