Merge branch 'master' into new_ui
Slava Pestov
commit
9d89739cf1
|
|
@ -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
|
||||
db.private ;
|
||||
io.encodings.string accessors shuffle io 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 -- )
|
||||
"resetting: " write dup . sqlite3_reset sqlite-check-result ;
|
||||
: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ;
|
||||
: sqlite-clear-bindings ( handle -- )
|
||||
sqlite3_clear_bindings sqlite-check-result ;
|
||||
: sqlite-#columns ( query -- int ) sqlite3_column_count ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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" [
|
||||
[ >reference-string ] keep
|
||||
first2 [ db-table-name "foreign-table-name" set ]
|
||||
[ "foreign-table-id" set ] bi*
|
||||
create-sqlite-triggers
|
||||
] }
|
||||
{ "references" [ >reference-string ] }
|
||||
[ 2drop ]
|
||||
} case ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
[ f ] [ first ] if-empty ;
|
||||
>query 1 >>limit [ tuple>> ] [ query>statement ] bi
|
||||
do-select [ f ] [ first ] if-empty ;
|
||||
|
||||
: count-tuples ( query/tuple -- n )
|
||||
>query [ tuple>> ] [ <count-statement> ] bi do-count
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
combinators.smart generic compiler.units ;
|
||||
macros generic compiler.units words effects vocabs
|
||||
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 -- )
|
||||
[
|
||||
[ stack-effect ]
|
||||
[ name>> "d" prepend "math.dual" create ]
|
||||
bi [ set-stack-effect ] keep
|
||||
]
|
||||
keep
|
||||
'[ _ dual-op ] define ;
|
||||
dup name>> "d" prepend "math.dual" create
|
||||
[ [ stack-effect ] dip set-stack-effect ]
|
||||
[ set-dual-help ]
|
||||
[ swap '[ _ dual-op ] define ]
|
||||
2tri ;
|
||||
|
||||
! Specialize math functions to operate on dual numbers.
|
||||
[ all-words [ "derivative" word-prop ] filter
|
||||
|
|
|
|||
Loading…
Reference in New Issue