From a49833e116456fcbf9d67f9b24fd28b138fe91cb Mon Sep 17 00:00:00 2001
From: Leonardo Varuzza <varuzza@gmail.com>
Date: Thu, 31 Jan 2008 21:35:12 -0200
Subject: [PATCH] create sql module.

---
 bioinfo.asd                                  |  11 +-
 sql/sql.lisp                                 | 261 +++++++++++++++++++++++++++
 ucsc-compiler.lisp => sql/ucsc-compiler.lisp |   0
 ucsc.lisp => sql/ucsc.lisp                   |   0
 4 files changed, 268 insertions(+), 4 deletions(-)
 create mode 100644 sql/sql.lisp
 rename ucsc-compiler.lisp => sql/ucsc-compiler.lisp (100%)
 rename ucsc.lisp => sql/ucsc.lisp (100%)

diff --git a/bioinfo.asd b/bioinfo.asd
index 8bb680e..9039642 100644
--- a/bioinfo.asd
+++ b/bioinfo.asd
@@ -17,10 +17,13 @@
 	       (:module "sage"
 			:components ((:file "sage")))
 	       (:file "feature")
-	       (:file "sql")
-	       (:file "ucsc-compiler")
-	       (:file "ucsc-gen")
-	       (:file "ucsc-sql")))
+
+;; 	       (:module "sql"
+;; 			:components 
+;; 			((:file "sql")
+;; 			 (:file "ucsc-compiler")
+;; 			 (:file "ucsc-gen")
+;; 			 (:file "ucsc-sql")))
 
 ;; 	       (:module "graphics"
 ;; 			:components ((:file "packages")
diff --git a/sql/sql.lisp b/sql/sql.lisp
new file mode 100644
index 0000000..a17f387
--- /dev/null
+++ b/sql/sql.lisp
@@ -0,0 +1,261 @@
+(in-package :bioinfo)
+
+(defvar *compiled-classes* (make-hash-table))
+
+(defvar *invalid-column-names* nil)
+(defparameter *psql-invalid-col-names* '(end))
+ 
+(defun change-invalid-column-names (name)
+  (declare (special *invalid-column-names*))
+  #+foo(format t "> ~a~%" name)
+  (if (member name *invalid-column-names*)
+      (intern (concatenate 'string (symbol-name name) "0"))
+      name))
+
+;; preliminary sql parser
+;; 
+;; 
+(defparameter keywords '(create drop if exists table index primary key not null default unique auto_increment enum set))
+(defparameter types '(int unsigned longtext float double decimal varchar smallint char text blob longblob tinyint))
+
+(defun string->symbol (str &optional (pkg *package*))
+  (intern (string-upcase str) pkg))
+
+(declaim (special *sql-lexer-line*))
+
+(deflexer make-sql-lexer
+    ("[0-9]+([.][0-9]+([Ee][0-9]+)?)"
+     (return (values 'float-number (num %0))))
+  ("[0-9]+"
+   (return (values 'fixnum (int %0))))
+  ("[:alpha:][a-zA-Z0-9_]*"
+   (return (let ((symb (string->symbol %0)))
+	     (cond
+	       ((member symb keywords) (values symb symb))
+	       ((member symb types) (values 'type symb))
+	       (t (values 'name %0))))))
+  ("`.*?`"
+   (return (values 'name (string-trim "`" %0))))
+  ("'.*?'"
+   (return (values 'string (string-trim "'" %0))))
+  ("--.*")
+  ("/\*.*?\*/")
+  ("[;=,\\\(\\\)]"
+   (return (let ((symb (intern %0)))
+	     (values symb symb))))
+  ("[:space:]+"
+   (when (eq (elt %0 0) #\Newline)
+     (incf *sql-lexer-line*))))
+
+
+(define-parser *sql-parser*
+  (:start-symbol stmts)
+  (:terminals (fixnum auto_increment enum  set float-number engine charset string
+		      name type not null default create drop if exists table index view primary key unique
+		      |(| |)| |,| |;| |=|))
+
+  (stmts
+   (stmt)
+   (stmt stmts #'(lambda (a b)
+		   (cons a b))))
+    
+  (stmt
+   (expr |;|  #'(lambda (a b) (car a)))
+   (|;| #'(lambda (x) nil)))
+  
+  (expr
+   (create-table)
+   (ignore #'(lambda (x) nil)))
+
+  (symb
+   (default #'(lambda (x) "default"))
+   (name #'(lambda (x) x)))
+	   
+  (create-table
+   (create table name |(| defs |)| props #'(lambda (&rest lst)
+					 (list 'create-table
+					       :name (third lst)
+					       :components (fifth lst)))))
+
+
+  (props   
+   ()
+   (prop props))
+
+  (prop
+   (symb |=| symb)
+   (auto_increment |=| number)
+   (symb symb |=| symb))
+    
+  (defs
+      (def #'(lambda (a) a))
+      (def |,| defs #'(lambda (a b c)
+			(cons (car a) c))))
+
+  (def
+      (field-def)
+      (key-def))
+
+  (key-def
+   (key-def1 #'(lambda (x) x))
+   (primary key-def1 #'(lambda (a b) b))
+   (unique key-def1 #'(lambda (a b)
+		       (cons b '(:unique t) ))))
+  
+  (key-def1
+   (key |(| idx-fields |)| #'(lambda (&rest lst)
+			       (list 'key
+				     :name nil
+				     :fields (third lst))))  
+   (key symb |(| idx-fields |)| #'(lambda (&rest lst)
+				     (list 'key
+					   :name (second lst)
+					   :fields (fourth lst)))))
+
+  (idx-fields
+   (idx-field #'(lambda (a) a))
+   (idx-field |,| idx-fields #'(lambda (a b c) (cons a  c))))
+
+  (idx-field
+   (symb)
+   (symb |(| number |)| #'(lambda (a b c d) (list a c))))
+  
+  (field-def
+   (symb type-def #'(lambda (a b) (list
+				   'field
+				   :name a :type b)))
+   (symb type-def opts #'(lambda (a b c) (list
+					  'field
+					  :name a
+					  :type b
+					  :options c))))
+
+  (opts
+   (opt)
+   (opt opts #'(lambda (a b) (cons a b))))
+
+  (opt
+   (default value)
+   (not null)
+   (auto_increment)
+   (primary key))
+
+  (value
+   (NULL)
+   (string)
+   (number))
+
+  (number
+   (fixnum)
+   (float-number))
+  
+  (type-def
+   (type-expr)
+   (type-expr type-expr))
+  
+  (type-expr
+   (type #'(lambda (a) a))
+   (enum-set |(| strings |)| #'(lambda (a b c d)
+			   (list a c)))
+   (type |(| fixnum |)| #'(lambda (a b c d)
+			    (list  a c))))
+
+  (enum-set
+   (enum)
+   (set))
+  (strings
+   (string)
+   (string |,| strings #'(lambda (a b c) (cons a c))))
+  
+  ;; Ignore other statments
+  (ignore
+   (term)
+   (term ignore))
+  
+  (term
+   (if)  (name)
+   (|,|)  (|(|)  (|)|)
+   (exists)   (drop)
+   (not)  (create)
+   (name)   (table)
+   (index)  (view)   (as))
+)
+
+(defun lispname (str)
+  (cl-ppcre:regex-replace-all "[ _]" 
+			      (cl-ppcre:regex-replace-all "([a-z])([A-Z])" str "\\1-\\2")
+			      "-"))
+
+
+(defun test-parser ()
+  (parse-with-lexer (make-sql-lexer "drop table foo; create table foo (bar unsigned int not null, type varchar(30)); ;") *sql-parser*))
+
+(defun convert-type (node)
+  (cond
+    ;; Integer
+    ((rfind-if #'(lambda (x)
+		(member x '(int smallint)))  node) 'integer)
+
+    ;; float
+    ((rfind-if #'(lambda (x)
+		(member x '(float double)))  node) 'float)
+
+    ;; char and varchar
+    ((rfind-if  #'(lambda (x)
+		(member x '(char varchar)))  node)  (list 'string (second (car node))))
+    (t 'string)))
+
+(defun compile-field (node)
+  (let* ((name (lispname (getf node :name)))
+	 (options (getf node :options))
+	 (field-def (list
+		     (string->symbol name)
+		     :type (convert-type (getf node :type))
+		     :column (change-invalid-column-names (string->symbol (getf node :name)))
+		     :initarg (intern (string-upcase name) :keyword))))
+
+    (when (member '(primary key) options :test #'equal)
+      (setf field-def
+	    (nconc field-def '(:db-kind :key))))
+    field-def))
+
+(defun compile-create-table (node)
+  (let ((class-name (string->symbol (lispname (getf node :name)))))
+    (declare (special *compiled-classes))
+    (setf (gethash class-name *compiled-classes*) (getf node :name))
+    `(clsql:def-view-class ,class-name ()
+       ,(let ((fields (list-partition
+		       #'(lambda (x) (eq (car x) 'field))
+		       (getf node :components))))
+	     (remove nil (mapcar #'(lambda (node)
+				     (compile-field (cdr node)))
+				 fields)))
+       (:base-table ,(getf node :name)))))
+
+(defun compile-sql1 (tree)
+  `(progn
+     ,@(loop for node in tree
+	collect 
+	(case (car node)
+	  ('create-table
+	   (compile-create-table (cdr node)))))))
+
+
+(defun ensure-name (x)
+  (typecase x
+    (string x)
+    (pathname (namestring x))
+    (otherwise "<undefined source>")))
+
+(defun parse-sql (stream)
+  (let ((*sql-lexer-line* 1))
+    (handler-case 
+	(remove nil (parse-with-lexer (make-sql-lexer (slurp stream)) *sql-parser*))
+      (error (c) (progn
+		  (format t "Error at '~a':~a~%~a"  (ensure-name stream) *sql-lexer-line* c)
+		  nil)))))
+
+(defun compile-sql (stream)
+  (let ((root (parse-sql stream)))
+    (compile-sql1 root)))
+
diff --git a/ucsc-compiler.lisp b/sql/ucsc-compiler.lisp
similarity index 100%
rename from ucsc-compiler.lisp
rename to sql/ucsc-compiler.lisp
diff --git a/ucsc.lisp b/sql/ucsc.lisp
similarity index 100%
rename from ucsc.lisp
rename to sql/ucsc.lisp
-- 
2.11.4.GIT