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 ;
] 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 ;
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 ;
] 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" {
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
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
! 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 ;
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%
: 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"')
: 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"')
"> 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"')
: 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"')
"> 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"')
"> 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};
"> 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 ;
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 ;
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 )
: 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 )
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 ;
>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
}
{ $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 }
"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"
! 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
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 -- )
'[ _ @ @ <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
projects / factor.git / commitdiff