sql/sql.lisp

   1 (in-package :bioinfo)
   2
   3 (defvar *compiled-classes* (make-hash-table))
   4
   5 (defvar *invalid-column-names* nil)
   6 (defparameter *psql-invalid-col-names* '(end))
   7
   8 (defun change-invalid-column-names (name)
   9   (declare (special *invalid-column-names*))
  10   #+foo(format t "> ~a~%" name)
  11   (if (member name *invalid-column-names*)
  12       (intern (concatenate 'string (symbol-name name) "0"))
  13       name))
  14
  15 ;; preliminary sql parser
  16 ;;
  17 ;;
  18 (defparameter keywords '(create drop if exists table index primary key not null default unique auto_increment enum set))
  19 (defparameter types '(int unsigned longtext float double decimal varchar smallint char text blob longblob tinyint))
  20
  21 (defun string->symbol (str &optional (pkg *package*))
  22   (intern (string-upcase str) pkg))
  23
  24 (declaim (special *sql-lexer-line*))
  25
  26 (deflexer make-sql-lexer
  27     ("[0-9]+([.][0-9]+([Ee][0-9]+)?)"
  28      (return (values 'float-number (num %0))))
  29   ("[0-9]+"
  30    (return (values 'fixnum (int %0))))
  31   ("[:alpha:][a-zA-Z0-9_]*"
  32    (return (let ((symb (string->symbol %0)))
  33              (cond
  34                ((member symb keywords) (values symb symb))
  35                ((member symb types) (values 'type symb))
  36                (t (values 'name %0))))))
  37   ("`.*?`"
  38    (return (values 'name (string-trim "`" %0))))
  39   ("'.*?'"
  40    (return (values 'string (string-trim "'" %0))))
  41   ("--.*")
  42   ("/\*.*?\*/")
  43   ("[;=,\\\(\\\)]"
  44    (return (let ((symb (intern %0)))
  45              (values symb symb))))
  46   ("[:space:]+"
  47    (when (eq (elt %0 0) #\Newline)
  48      (incf *sql-lexer-line*))))
  49
  50
  51 (define-parser *sql-parser*
  52   (:start-symbol stmts)
  53   (:terminals (fixnum auto_increment enum  set float-number engine charset string
  54                       name type not null default create drop if exists table index view primary key unique
  55                       |(| |)| |,| |;| |=|))
  56
  57   (stmts
  58    (stmt)
  59    (stmt stmts #'(lambda (a b)
  60                    (cons a b))))
  61
  62   (stmt
  63    (expr |;|  #'(lambda (a b) (car a)))
  64    (|;| #'(lambda (x) nil)))
  65
  66   (expr
  67    (create-table)
  68    (ignore #'(lambda (x) nil)))
  69
  70   (symb
  71    (default #'(lambda (x) "default"))
  72    (name #'(lambda (x) x)))
  73
  74   (create-table
  75    (create table name |(| defs |)| props #'(lambda (&rest lst)
  76                                          (list 'create-table
  77                                                :name (third lst)
  78                                                :components (fifth lst)))))
  79
  80
  81   (props
  82    ()
  83    (prop props))
  84
  85   (prop
  86    (symb |=| symb)
  87    (auto_increment |=| number)
  88    (symb symb |=| symb))
  89
  90   (defs
  91       (def #'(lambda (a) a))
  92       (def |,| defs #'(lambda (a b c)
  93                         (cons (car a) c))))
  94
  95   (def
  96       (field-def)
  97       (key-def))
  98
  99   (key-def
 100    (key-def1 #'(lambda (x) x))
 101    (primary key-def1 #'(lambda (a b) b))
 102    (unique key-def1 #'(lambda (a b)
 103                        (cons b '(:unique t) ))))
 104
 105   (key-def1
 106    (key |(| idx-fields |)| #'(lambda (&rest lst)
 107                                (list 'key
 108                                      :name nil
 109                                      :fields (third lst))))
 110    (key symb |(| idx-fields |)| #'(lambda (&rest lst)
 111                                      (list 'key
 112                                            :name (second lst)
 113                                            :fields (fourth lst)))))
 114
 115   (idx-fields
 116    (idx-field #'(lambda (a) a))
 117    (idx-field |,| idx-fields #'(lambda (a b c) (cons a  c))))
 118
 119   (idx-field
 120    (symb)
 121    (symb |(| number |)| #'(lambda (a b c d) (list a c))))
 122
 123   (field-def
 124    (symb type-def #'(lambda (a b) (list
 125                                    'field
 126                                    :name a :type b)))
 127    (symb type-def opts #'(lambda (a b c) (list
 128                                           'field
 129                                           :name a
 130                                           :type b
 131                                           :options c))))
 132
 133   (opts
 134    (opt)
 135    (opt opts #'(lambda (a b) (cons a b))))
 136
 137   (opt
 138    (default value)
 139    (not null)
 140    (auto_increment)
 141    (primary key))
 142
 143   (value
 144    (NULL)
 145    (string)
 146    (number))
 147
 148   (number
 149    (fixnum)
 150    (float-number))
 151
 152   (type-def
 153    (type-expr)
 154    (type-expr type-expr))
 155
 156   (type-expr
 157    (type #'(lambda (a) a))
 158    (enum-set |(| strings |)| #'(lambda (a b c d)
 159                            (list a c)))
 160    (type |(| fixnum |)| #'(lambda (a b c d)
 161                             (list  a c))))
 162
 163   (enum-set
 164    (enum)
 165    (set))
 166   (strings
 167    (string)
 168    (string |,| strings #'(lambda (a b c) (cons a c))))
 169
 170   ;; Ignore other statments
 171   (ignore
 172    (term)
 173    (term ignore))
 174
 175   (term
 176    (if)  (name)
 177    (|,|)  (|(|)  (|)|)
 178    (exists)   (drop)
 179    (not)  (create)
 180    (name)   (table)
 181    (index)  (view)   (as))
 182 )
 183
 184 (defun lispname (str)
 185   (cl-ppcre:regex-replace-all "[ _]"
 186                               (cl-ppcre:regex-replace-all "([a-z])([A-Z])" str "\\1-\\2")
 187                               "-"))
 188
 189
 190 (defun test-parser ()
 191   (parse-with-lexer (make-sql-lexer "drop table foo; create table foo (bar unsigned int not null, type varchar(30)); ;") *sql-parser*))
 192
 193 (defun convert-type (node)
 194   (cond
 195     ;; Integer
 196     ((rfind-if #'(lambda (x)
 197                 (member x '(int smallint)))  node) 'integer)
 198
 199     ;; float
 200     ((rfind-if #'(lambda (x)
 201                 (member x '(float double)))  node) 'float)
 202
 203     ;; char and varchar
 204     ((rfind-if  #'(lambda (x)
 205                 (member x '(char varchar)))  node)  (list 'string (second (car node))))
 206     (t 'string)))
 207
 208 (defun compile-field (node)
 209   (let* ((name (lispname (getf node :name)))
 210          (options (getf node :options))
 211          (field-def (list
 212                      (string->symbol name)
 213                      :type (convert-type (getf node :type))
 214                      :column (change-invalid-column-names (string->symbol (getf node :name)))
 215                      :initarg (intern (string-upcase name) :keyword))))
 216
 217     (when (member '(primary key) options :test #'equal)
 218       (setf field-def
 219             (nconc field-def '(:db-kind :key))))
 220     field-def))
 221
 222 (defun compile-create-table (node)
 223   (let ((class-name (string->symbol (lispname (getf node :name)))))
 224     (declare (special *compiled-classes))
 225     (setf (gethash class-name *compiled-classes*) (getf node :name))
 226     `(clsql:def-view-class ,class-name ()
 227        ,(let ((fields (list-partition
 228                        #'(lambda (x) (eq (car x) 'field))
 229                        (getf node :components))))
 230              (remove nil (mapcar #'(lambda (node)
 231                                      (compile-field (cdr node)))
 232                                  fields)))
 233        (:base-table ,(getf node :name)))))
 234
 235 (defun compile-sql1 (tree)
 236   `(progn
 237      ,@(loop for node in tree
 238         collect
 239         (case (car node)
 240           ('create-table
 241            (compile-create-table (cdr node)))))))
 242
 243
 244 (defun ensure-name (x)
 245   (typecase x
 246     (string x)
 247     (pathname (namestring x))
 248     (otherwise "<undefined source>")))
 249
 250 (defun parse-sql (stream)
 251   (let ((*sql-lexer-line* 1))
 252     (handler-case
 253         (remove nil (parse-with-lexer (make-sql-lexer (slurp stream)) *sql-parser*))
 254       (error (c) (progn
 255                   (format t "Error at '~a':~a~%~a"  (ensure-name stream) *sql-lexer-line* c)
 256                   nil)))))
 257
 258 (defun compile-sql (stream)
 259   (let ((root (parse-sql stream)))
 260     (compile-sql1 root)))
 261