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