"(" 0% [ ", " 0% ] [
dup column-name>> 0%
" " 0%
- dup type>> t lookup-type 0%
+ dup type>> lookup-create-type 0%
modifiers 0%
] interleave ");" 0%
] postgresql-make ;
"(" 0%
over [ "," 0% ]
[
- type>> f lookup-type 0%
+ type>> lookup-type 0%
] interleave
")" 0%
" returns bigint as '" 0%
"drop function add_" 0% 0%
"(" 0%
remove-id
- [ ", " 0% ] [ type>> f lookup-type 0% ] interleave
+ [ ", " 0% ] [ type>> lookup-type 0% ] interleave
");" 0%
] postgresql-make ;
] if ";" 0%
] postgresql-make ;
-M: postgresql-db type-table ( -- hash )
+M: postgresql-db persistent-table ( -- hashtable )
H{
- { +native-id+ "integer" }
- { +random-id+ "bigint" }
- { TEXT "text" }
- { VARCHAR "varchar" }
- { INTEGER "integer" }
- { DOUBLE "real" }
- { DATE "date" }
- { TIME "time" }
- { DATETIME "timestamp" }
- { TIMESTAMP "timestamp" }
- { BLOB "bytea" }
- { FACTOR-BLOB "bytea" }
- } ;
-
-M: postgresql-db create-type-table ( -- hash )
- H{
- { +native-id+ "serial primary key" }
- { +random-id+ "bigint primary key" }
- } ;
-
-M: postgresql-db modifier-table ( -- hashtable )
- H{
- { +native-id+ "primary key" }
- { +assigned-id+ "primary key" }
- { +random-id+ "primary key" }
- { +foreign-id+ "references" }
- { +autoincrement+ "autoincrement" }
- { +unique+ "unique" }
- { +default+ "default" }
- { +null+ "null" }
- { +not-null+ "not null" }
- { system-random-generator "" }
- { secure-random-generator "" }
- { random-generator "" }
+ { +native-id+ { "integer" "serial primary key" f } }
+ { +assigned-id+ { f f "primary key" } }
+ { +random-id+ { "bigint" "bigint primary key" f } }
+ { TEXT { "text" f f } }
+ { VARCHAR { "varchar" "varchar" f } }
+ { INTEGER { "integer" "integer" f } }
+ { BIG-INTEGER { "bigint" "bigint" f } }
+ { UNSIGNED-BIG-INTEGER { "bigint" "bigint" f } }
+ { SIGNED-BIG-INTEGER { "bigint" "bigint" f } }
+ { DOUBLE { "real" "real" f } }
+ { DATE { "date" "date" f } }
+ { TIME { "time" "time" f } }
+ { DATETIME { "timestamp" "timestamp" f } }
+ { TIMESTAMP { "timestamp" "timestamp" f } }
+ { BLOB { "bytea" "bytea" f } }
+ { FACTOR-BLOB { "bytea" "bytea" f } }
+ { +foreign-id+ { f f "references" } }
+ { +autoincrement+ { f f "autoincrement" } }
+ { +unique+ { f f "unique" } }
+ { +default+ { f f "default" } }
+ { +null+ { f f "null" } }
+ { +not-null+ { f f "not null" } }
+ { system-random-generator { f f f } }
+ { secure-random-generator { f f f } }
+ { random-generator { f f f } }
} ;
M: postgresql-db compound ( str obj -- str' )
classes.singleton accessors quotations random ;
IN: db.types
-HOOK: modifier-table db ( -- hash )
+HOOK: persistent-table db ( -- hash )
HOOK: compound db ( str obj -- hash )
-HOOK: type-table db ( -- hash )
-HOOK: create-type-table db ( -- hash )
+
HOOK: random-id-quot db ( -- quot )
TUPLE: sql-spec class slot-name column-name type primary-key modifiers ;
] find nip [ system-random-generator ] unless* ;
: primary-key? ( spec -- ? )
- sql-spec-primary-key +primary-key+? ;
+ primary-key>> +primary-key+? ;
: native-id? ( spec -- ? )
- sql-spec-primary-key +native-id+? ;
+ primary-key>> +native-id+? ;
: nonnative-id? ( spec -- ? )
- sql-spec-primary-key +nonnative-id+? ;
+ primary-key>> +nonnative-id+? ;
: normalize-spec ( spec -- )
- dup sql-spec-type dup +primary-key+? [
- swap set-sql-spec-primary-key
+ dup type>> dup +primary-key+? [
+ >>primary-key drop
] [
- drop dup sql-spec-modifiers [
+ drop dup modifiers>> [
+primary-key+?
] deep-find
- [ swap set-sql-spec-primary-key ] [ drop ] if*
+ [ >>primary-key drop ] [ drop ] if*
] if ;
: find-primary-key ( specs -- obj )
- [ sql-spec-primary-key ] find nip ;
+ [ primary-key>> ] find nip ;
: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
[ relation? not ] subset ;
: remove-id ( specs -- obj )
- [ sql-spec-primary-key not ] subset ;
+ [ primary-key>> not ] subset ;
! SQLite Types: http://www.sqlite.org/datatype3.html
! NULL INTEGER REAL TEXT BLOB
: lookup-modifier ( obj -- str )
{
{ [ dup array? ] [ unclip lookup-modifier swap compound ] }
- [ modifier-table at* [ unknown-modifier ] unless ]
+ [ persistent-table at* [ unknown-modifier ] unless third ]
} cond ;
ERROR: no-sql-type ;
-: lookup-type* ( obj -- str )
+: (lookup-type) ( obj -- str )
+ persistent-table at* [ no-sql-type ] unless ;
+
+: lookup-type ( obj -- str )
dup array? [
- first lookup-type*
+ unclip (lookup-type) first nip
] [
- type-table at* [ no-sql-type ] unless
+ (lookup-type) first
] if ;
: lookup-create-type ( obj -- str )
dup array? [
- unclip lookup-create-type swap compound
+ unclip (lookup-type) second swap compound
] [
- dup create-type-table at*
- [ nip ] [ drop lookup-type* ] if
+ (lookup-type) second
] if ;
-: lookup-type ( obj create? -- str )
- [ lookup-create-type ] [ lookup-type* ] if ;
-
: single-quote ( str -- newstr )
"'" swap "'" 3append ;
" " swap 3append ;
: modifiers ( spec -- str )
- sql-spec-modifiers
- [ lookup-modifier ] map " " join
+ modifiers>> [ lookup-modifier ] map " " join
dup empty? [ " " prepend ] unless ;
HOOK: bind% db ( spec -- )
: tuple>params ( specs tuple -- obj )
[
- >r dup sql-spec-type swap sql-spec-slot-name r>
+ >r [ type>> ] [ slot-name>> ] bi r>
get-slot-named swap
] curry { } map>assoc ;