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 prettyprint
   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 SINGLETONS: +db-assigned-id+ +user-assigned-id+ +random-id+ ;
  26 UNION: +primary-key+ +db-assigned-id+ +user-assigned-id+ +random-id+ ;
  27
  28 SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
  29 +foreign-id+ +has-many+ +on-delete+ +restrict+ +cascade+ +set-null+
  30 +set-default+ ;
  31
  32 : offset-of-slot ( string tuple -- n )
  33     class superclasses [ "slots" word-prop ] map concat
  34     slot-named offset>> ;
  35
  36 : get-slot-named ( name tuple -- value )
  37     tuck offset-of-slot slot ;
  38
  39 : set-slot-named ( value name obj -- )
  40     tuck offset-of-slot set-slot ;
  41
  42 ERROR: not-persistent class ;
  43
  44 : db-table ( class -- object )
  45     dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
  46
  47 : db-columns ( class -- object )
  48     superclasses [ "db-columns" word-prop ] map concat ;
  49
  50 : db-relations ( class -- object )
  51     "db-relations" word-prop ;
  52
  53 : find-primary-key ( specs -- seq )
  54     [ primary-key>> ] filter ;
  55
  56 : set-primary-key ( value tuple -- )
  57     [
  58         class db-columns
  59         find-primary-key first slot-name>>
  60     ] keep set-slot-named ;
  61
  62 : primary-key? ( spec -- ? )
  63     primary-key>> +primary-key+? ;
  64
  65 : db-assigned-id-spec? ( specs -- ? )
  66     [ primary-key>> +db-assigned-id+? ] contains? ;
  67
  68 : user-assigned-id-spec? ( specs -- ? )
  69     [ primary-key>> +user-assigned-id+? ] contains? ;
  70
  71 : normalize-spec ( spec -- )
  72     dup type>> dup +primary-key+? [
  73         >>primary-key drop
  74     ] [
  75         drop dup modifiers>> [
  76             +primary-key+?
  77         ] deep-find
  78         [ >>primary-key drop ] [ drop ] if*
  79     ] if ;
  80
  81 : db-assigned? ( class -- ? )
  82     db-columns find-primary-key db-assigned-id-spec? ;
  83
  84 : relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
  85
  86 SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
  87 DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB
  88 FACTOR-BLOB NULL URL ;
  89
  90 : <sql-spec> ( class slot-name column-name type modifiers -- sql-spec )
  91     sql-spec new
  92         swap >>modifiers
  93         swap >>type
  94         swap >>column-name
  95         swap >>slot-name
  96         swap >>class
  97         dup normalize-spec ;
  98
  99 : spec>tuple ( class spec -- tuple )
 100     3 f pad-right [ first3 ] keep 3 tail <sql-spec> ;
 101
 102 : number>string* ( n/string -- string )
 103     dup number? [ number>string ] when ;
 104
 105 : remove-db-assigned-id ( specs -- obj )
 106     [ +db-assigned-id+? not ] filter ;
 107
 108 : remove-relations ( specs -- newcolumns )
 109     [ relation? not ] filter ;
 110
 111 : remove-id ( specs -- obj )
 112     [ primary-key>> not ] filter ;
 113
 114 ! SQLite Types: http://www.sqlite.org/datatype3.html
 115 ! NULL INTEGER REAL TEXT BLOB
 116 ! PostgreSQL Types:
 117 ! http://developer.postgresql.org/pgdocs/postgres/datatype.html
 118
 119 : ?at ( obj assoc -- value/obj ? )
 120     dupd at* [ [ nip ] [ drop ] if ] keep ;
 121
 122 ERROR: unknown-modifier modifier ;
 123
 124 : lookup-modifier ( obj -- string )
 125     {
 126         { [ dup array? ] [ unclip lookup-modifier swap compound ] }
 127         [ persistent-table ?at [ unknown-modifier ] unless third ]
 128     } cond ;
 129
 130 ERROR: no-sql-type type ;
 131
 132 : (lookup-type) ( obj -- string )
 133     persistent-table ?at [ no-sql-type ] unless ;
 134
 135 : lookup-type ( obj -- string )
 136     dup array? [
 137         unclip (lookup-type) first nip
 138     ] [
 139         (lookup-type) first
 140     ] if ;
 141
 142 : lookup-create-type ( obj -- string )
 143     dup array? [
 144         unclip (lookup-type) second swap compound
 145     ] [
 146         (lookup-type) second
 147     ] if ;
 148
 149 : modifiers ( spec -- string )
 150     modifiers>> [ lookup-modifier ] map " " join
 151     [ "" ] [ " " prepend ] if-empty ;
 152
 153 : join-space ( string1 string2 -- new-string )
 154     " " swap 3append ;
 155
 156 : paren ( string -- new-string )
 157     "(" swap ")" 3append ;
 158
 159 HOOK: bind% db ( spec -- )
 160 HOOK: bind# db ( spec obj -- )
 161
 162 ERROR: no-column column ;
 163
 164 : >reference-string ( string pair -- string )
 165     first2
 166     [ [ unparse join-space ] [ db-columns ] bi ] dip
 167     swap [ column-name>> = ] with find nip
 168     [ no-column ] unless*
 169     column-name>> paren append ;