extra/db/queries/queries.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors kernel math namespaces sequences random
   4 strings math.parser math.intervals combinators
   5 math.bitfields.lib namespaces.lib db db.tuples db.types
   6 sequences.lib db.sql classes words shuffle arrays ;
   7 IN: db.queries
   8
   9 GENERIC: where ( specs obj -- )
  10
  11 : maybe-make-retryable ( statement -- statement )
  12     dup in-params>> [ generator-bind? ] contains?
  13     [ make-retryable ] when ;
  14
  15 : query-make ( class quot -- )
  16     >r sql-props r>
  17     [ 0 sql-counter rot with-variable ] { "" { } { } } nmake
  18     <simple-statement> maybe-make-retryable ; inline
  19
  20 M: db begin-transaction ( -- ) "BEGIN" sql-command ;
  21 M: db commit-transaction ( -- ) "COMMIT" sql-command ;
  22 M: db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
  23
  24 : where-primary-key% ( specs -- )
  25     " where " 0%
  26     find-primary-key dup column-name>> 0% " = " 0% bind% ;
  27
  28 M: db <update-tuple-statement> ( class -- statement )
  29     [
  30         "update " 0% 0%
  31         " set " 0%
  32         dup remove-id
  33         [ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave
  34         where-primary-key%
  35     ] query-make ;
  36
  37 M: random-id-generator eval-generator ( singleton -- obj )
  38     drop
  39     system-random-generator get [
  40         63 [ 2^ random ] keep 1 - set-bit
  41     ] with-random ;
  42
  43 : interval-comparison ( ? str -- str )
  44     "from" = " >" " <" ? swap [ "= " append ] when ;
  45
  46 : fp-infinity? ( float -- ? )
  47     dup float? [
  48         double>bits -52 shift 11 2^ 1- [ bitand ] keep =
  49     ] [
  50         drop f
  51     ] if ;
  52
  53 : (infinite-interval?) ( interval -- ?1 ?2 )
  54     [ from>> ] [ to>> ] bi
  55     [ first fp-infinity? ] bi@ ;
  56
  57 : double-infinite-interval? ( obj -- ? )
  58     dup interval? [ (infinite-interval?) and ] [ drop f ] if ;
  59
  60 : infinite-interval? ( obj -- ? )
  61     dup interval? [ (infinite-interval?) or ] [ drop f ] if ;
  62
  63 : where-interval ( spec obj from/to -- )
  64     over first fp-infinity? [
  65         3drop
  66     ] [
  67         pick column-name>> 0%
  68         >r first2 r> interval-comparison 0%
  69         bind#
  70     ] if ;
  71
  72 : in-parens ( quot -- )
  73     "(" 0% call ")" 0% ; inline
  74
  75 M: interval where ( spec obj -- )
  76     [
  77         [ from>> "from" where-interval ] [
  78             nip infinite-interval? [ " and " 0% ] unless
  79         ] [ to>> "to" where-interval ] 2tri
  80     ] in-parens ;
  81
  82 M: sequence where ( spec obj -- )
  83     [
  84         [ " or " 0% ] [ dupd where ] interleave drop
  85     ] in-parens ;
  86
  87 : object-where ( spec obj -- )
  88     over column-name>> 0% " = " 0% bind# ;
  89
  90 M: object where ( spec obj -- ) object-where ;
  91
  92 M: integer where ( spec obj -- ) object-where ;
  93
  94 M: string where ( spec obj -- ) object-where ;
  95
  96 : filter-slots ( tuple specs -- specs' )
  97     [
  98         slot-name>> swap get-slot-named
  99         dup double-infinite-interval? [ drop f ] when
 100     ] with filter ;
 101
 102 : where-clause ( tuple specs -- )
 103     dupd filter-slots [
 104         drop
 105     ] [
 106         " where " 0% [
 107             " and " 0%
 108         ] [
 109             2dup slot-name>> swap get-slot-named where
 110         ] interleave drop
 111     ] if-empty ;
 112
 113 M: db <delete-tuples-statement> ( tuple table -- sql )
 114     [
 115         "delete from " 0% 0%
 116         where-clause
 117     ] query-make ;
 118
 119 M: db <select-by-slots-statement> ( tuple class -- statement )
 120     [
 121         "select " 0%
 122         over [ ", " 0% ]
 123         [ dup column-name>> 0% 2, ] interleave
 124
 125         " from " 0% 0%
 126         where-clause
 127     ] query-make ;
 128
 129 : do-group ( tuple groups -- )
 130     [
 131         ", " join " group by " prepend append
 132     ] curry change-sql drop ;
 133
 134 : do-order ( tuple order -- )
 135     [
 136         ", " join " order by " prepend append
 137     ] curry change-sql drop ;
 138
 139 : do-offset ( tuple n -- )
 140     [
 141         number>string " offset " prepend append
 142     ] curry change-sql drop ;
 143
 144 : do-limit ( tuple n -- )
 145     [
 146         number>string " limit " prepend append
 147     ] curry change-sql drop ;
 148
 149 : make-query ( tuple query -- tuple' )
 150     dupd
 151     {
 152         [ group>> [ do-group ] [ drop ] if-seq ]
 153         [ order>> [ do-order ] [ drop ] if-seq ]
 154         [ limit>> [ do-limit ] [ drop ] if* ]
 155         [ offset>> [ do-offset ] [ drop ] if* ]
 156     } 2cleave ;
 157
 158 M: db <query> ( tuple class query -- tuple )
 159     [ <select-by-slots-statement> ] dip make-query ;
 160
 161 ! select ID, NAME, SCORE from EXAM limit 1 offset 3
 162
 163 : select-tuples* ( tuple -- statement )
 164     dup
 165     [
 166         select 0,
 167         dup class db-columns [ ", " 0, ]
 168         [ dup column-name>> 0, 2, ] interleave
 169         from 0,
 170         class word-name 0,
 171     ] { { } { } { } } nmake
 172     >r >r parse-sql 4drop r> r>
 173     <simple-statement> maybe-make-retryable do-select ;
 174
 175 M: db <count-statement> ( tuple class groups -- statement )
 176     \ query new
 177         swap >>group
 178     [ [ "select count(*) from " 0% 0% where-clause ] query-make ]
 179     dip make-query ;
 180
 181 : where-clause* ( tuple specs -- )
 182     dupd filter-slots [
 183         drop
 184     ] [
 185         \ where 0,
 186         [ 2dup slot-name>> swap get-slot-named where ] map 2array 0,
 187         drop
 188     ] if-empty ;
 189
 190 : delete-tuple* ( tuple -- sql )
 191     dup
 192     [
 193         delete 0, from 0, dup class db-table 0,
 194         dup class db-columns where-clause*
 195     ] { { } { } { } } nmake
 196     >r >r parse-sql 4drop r> r>
 197     <simple-statement> maybe-make-retryable do-select ;
 198
 199 : create-index ( index-name table-name columns -- )
 200     [
 201         >r >r "create index " % % r> " on " % % r> "(" %
 202         "," join % ")" %
 203     ] "" make sql-command ;
 204
 205 : drop-index ( index-name -- )
 206     [ "drop index " % % ] "" make sql-command ;