basis/db/types/types.factor

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