basis/db/types/types.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays assocs db kernel math math.parser
   4 sequences continuations sequences.deep
   5 words namespaces slots slots.private classes mirrors
   6 classes.tuple combinators calendar.format symbols
   7 classes.singleton accessors quotations random ;
   8 IN: db.types
   9
  10 HOOK: persistent-table db ( -- hash )
  11 HOOK: compound db ( string obj -- hash )
  12
  13 TUPLE: sql-spec class slot-name column-name type primary-key modifiers ;
  14
  15 TUPLE: literal-bind key type value ;
  16 C: <literal-bind> literal-bind
  17
  18 TUPLE: generator-bind slot-name key generator-singleton type ;
  19 C: <generator-bind> generator-bind
  20 SINGLETON: random-id-generator
  21
  22 TUPLE: low-level-binding value ;
  23 C: <low-level-binding> low-level-binding
  24
  25 SINGLETON: +db-assigned-id+
  26 SINGLETON: +user-assigned-id+
  27 SINGLETON: +random-id+
  28 UNION: +primary-key+ +db-assigned-id+ +user-assigned-id+ +random-id+ ;
  29
  30 SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
  31 +foreign-id+ +has-many+ ;
  32
  33 : find-random-generator ( seq -- obj )
  34     [
  35         {
  36             random-generator
  37             system-random-generator
  38             secure-random-generator
  39         } member?
  40     ] find nip [ system-random-generator ] unless* ;
  41
  42 : primary-key? ( spec -- ? )
  43     primary-key>> +primary-key+? ;
  44
  45 : db-assigned-id-spec? ( spec -- ? )
  46     primary-key>> +db-assigned-id+? ;
  47
  48 : assigned-id-spec? ( spec -- ? )
  49     primary-key>> +user-assigned-id+? ;
  50
  51 : normalize-spec ( spec -- )
  52     dup type>> dup +primary-key+? [
  53         >>primary-key drop
  54     ] [
  55         drop dup modifiers>> [
  56             +primary-key+?
  57         ] deep-find
  58         [ >>primary-key drop ] [ drop ] if*
  59     ] if ;
  60
  61 : find-primary-key ( specs -- obj )
  62     [ primary-key>> ] find nip ;
  63
  64 : relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
  65
  66 SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
  67 DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB
  68 FACTOR-BLOB NULL URL ;
  69
  70 : spec>tuple ( class spec -- tuple )
  71     3 f pad-right
  72     [ first3 ] keep 3 tail
  73     sql-spec new
  74         swap >>modifiers
  75         swap >>type
  76         swap >>column-name
  77         swap >>slot-name
  78         swap >>class
  79     dup normalize-spec ;
  80
  81 : number>string* ( n/string -- string )
  82     dup number? [ number>string ] when ;
  83
  84 : remove-db-assigned-id ( specs -- obj )
  85     [ +db-assigned-id+? not ] filter ;
  86
  87 : remove-relations ( specs -- newcolumns )
  88     [ relation? not ] filter ;
  89
  90 : remove-id ( specs -- obj )
  91     [ primary-key>> not ] filter ;
  92
  93 ! SQLite Types: http://www.sqlite.org/datatype3.html
  94 ! NULL INTEGER REAL TEXT BLOB
  95 ! PostgreSQL Types:
  96 ! http://developer.postgresql.org/pgdocs/postgres/datatype.html
  97
  98 ERROR: unknown-modifier ;
  99
 100 : lookup-modifier ( obj -- string )
 101     {
 102         { [ dup array? ] [ unclip lookup-modifier swap compound ] }
 103         [ persistent-table at* [ unknown-modifier ] unless third ]
 104     } cond ;
 105
 106 ERROR: no-sql-type ;
 107
 108 : (lookup-type) ( obj -- string )
 109     persistent-table at* [ no-sql-type ] unless ;
 110
 111 : lookup-type ( obj -- string )
 112     dup array? [
 113         unclip (lookup-type) first nip
 114     ] [
 115         (lookup-type) first
 116     ] if ;
 117
 118 : lookup-create-type ( obj -- string )
 119     dup array? [
 120         unclip (lookup-type) second swap compound
 121     ] [
 122         (lookup-type) second
 123     ] if ;
 124
 125 : single-quote ( string -- new-string )
 126     "'" swap "'" 3append ;
 127
 128 : double-quote ( string -- new-string )
 129     "\"" swap "\"" 3append ;
 130
 131 : paren ( string -- new-string )
 132     "(" swap ")" 3append ;
 133
 134 : join-space ( string1 string2 -- new-string )
 135     " " swap 3append ;
 136
 137 : modifiers ( spec -- string )
 138     modifiers>> [ lookup-modifier ] map " " join
 139     dup empty? [ " " prepend ] unless ;
 140
 141 HOOK: bind% db ( spec -- )
 142 HOOK: bind# db ( spec obj -- )
 143
 144 : offset-of-slot ( string obj -- n )
 145     class superclasses [ "slots" word-prop ] map concat
 146     slot-named offset>> ;
 147
 148 : get-slot-named ( name obj -- value )
 149     tuck offset-of-slot slot ;
 150
 151 : set-slot-named ( value name obj -- )
 152     tuck offset-of-slot set-slot ;
 153
 154 : tuple>filled-slots ( tuple -- alist )
 155     <mirror> [ nip ] assoc-filter ;
 156
 157 : tuple>params ( specs tuple -- obj )
 158     [
 159         >r [ type>> ] [ slot-name>> ] bi r>
 160         get-slot-named swap
 161     ] curry { } map>assoc ;