;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:          sqlgen.lisp
;;;; Purpose:       SQL Generation functions for Hyperobject
;;;; Programmer:    Kevin M. Rosenberg
;;;; Date Started:  Apr 2000
;;;;
;;;; $Id: sqlgen.lisp,v 1.1 2002/12/01 21:07:28 kevin Exp $
;;;;
;;;; This file, part of Hyperobject-SQL, is
;;;;    Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
;;;; *************************************************************************

(in-package :hyperobject)
(declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))


;;;; Metaclass initialization commands
(defun process-sql (cl)
  (let ((esds (class-slots cl)))
    (let* ((table-name-slot (slot-value cl 'sql-name))
           (generate-table-cmd (generate-create-table-string 
                                (if (consp table-name-slot)
                                    (car table-name-slot)
                                  table-name-slot)
                                dsds)))
      (setf (slot-value cl 'create-table-cmd) generate-table-cmd))

    (dolist (dsd dsds)
      (when (dsd-inverse dsd)
	(define-inverse cl dsd))))
  )

(defun define-inverse (class dsd)
  (let ((inverse (dsd-inverse dsd)))
    (when inverse
      (eval
       `(defun ,inverse (key)
	  (format t "~&Finding key: ~a~%" key)
	  (make-instance 'st)
	  ))
	   
      ;; create inverse function
      ))
  )

(defun generate-create-table-string (table-name dsds)
  (let ((cmd (format nil "CREATE TABLE ~A (" 
		     (slot-name-to-sql-name table-name))))
    (dolist (dsd dsds)
      (unless (eq dsd (car dsds))
	(string-append cmd ", "))
      (string-append cmd (slot-name-to-sql-name 
                             #+allegro (clos:slot-definition-name dsd)
                             #+lispworks (clos:slot-definition-name dsd)
                             ) " ")
      (let ((length (dsd-length dsd))
	    (sql-type (dsd-sql-type dsd)))
	(string-append cmd (sql-field-cmd sql-type length))))
    (string-append cmd ")")))


;;;; Runtime Commands

(defclass sqltable ()
  ()
  )

(defmethod sql-create ((self sqltable))
  (sql (sql-cmd-create-table self))
  (dolist (cmd (sql-cmd-create-indices self))
    (sql cmd))
  (values))

(defmethod sql-drop ((self sqltable))
  (sql (sql-cmd-drop-table self))
  (values))

(defmethod sql-insert ((self sqltable))
  (sql
   (format nil "INSERT INTO ~a (~a) VALUES (~a)"
	   (table-name self) (sql-cmd-field-names self) (format-values self))))

(defmethod sql-select ((self sqltable) key)
  (let ((tuple 
	 (car 
	  (sql
	   (format nil "SELECT ~a FROM ~a WHERE ~a=~a"
		   (sql-cmd-field-names self) (table-name self)
		   (inverse-field-name self) key)))))
    (when tuple
      (format t "process returned fields"))))


(defun format-values (self)
  (let ((values "")
	(fields (fields self)))
    (dolist (field fields)
      (unless (eq field (car fields))
	(string-append values ","))
      (let ((name (car field)))
	(with-key-value-list (key value (rest field))
	  (when (eq key :type)
	    (string-append values
			      (ecase value
				((:fixnum :bigint :short-float :double-float)
				 (write-to-string 
				  (slot-value self name)))
				((:string :text)
				 (format nil "'~a'" 
					 (add-sql-quotes 
					  (slot-value self name))))))))))
    values))

(defmacro defsqltable (tname &key fields)
  `(progn
     (defclass ,tname (sqltable)
       ,(parse-fields tname fields)
       ,(default-initargs fields))
     
     (defmethod table-name ((self ,tname))
       ,(substitute #\_ #\- (write-to-string tname)))

     (defmethod fields ((self ,tname))
       (quote ,fields))
     
     (defmethod sql-cmd-create-table ((self ,tname))
       ,(create-table-string tname fields))

     (defmethod sql-cmd-create-indices ((self ,tname))
       "Return a list of index cmds"
       (quote ,(create-indices-string tname fields)))

     (defmethod sql-cmd-drop-table ((self ,tname))
       ,(format nil "DROP TABLE ~a" tname))
     
     (defmethod sql-cmd-field-names ((self ,tname))
       ,(row-field-string fields))

     (defmethod inverse-field-name ((self ,tname))
       ,(inverse-field-string fields))
     ))

(defun create-indices-string (table-name fields)
  (let (indices)
    (dolist (field fields)
      (let ((name-string (write-to-string (car field))))
	(with-key-value-list (key value (rest field))
	  (when (eq key :unique)
	    (case value
	      (nil
	       (push (sql-cmd-index table-name name-string nil) indices))
	      (t
	       (push (sql-cmd-index table-name name-string t) indices)))))))
    indices))

(defun inverse-field-string (fields)
  (let (inverse)
    (dolist (field fields)
      (let ((name-string (write-to-string (car field))))
	(with-key-value-list (key value (rest field))
	  (when (eq key :inverse)
	    (setq inverse value)))))
    (when inverse
      (write-to-string inverse))))

(defun sql-cmd-index (table field unique)
  (let ((*print-circle* nil))
    (format nil "CREATE ~A INDEX ~A_~A ON ~A(~A)"
	    (if unique "UNIQUE" "")
	    (slot-name-to-sql-name table) 
	    (slot-name-to-sql-name field)
	    (slot-name-to-sql-name table)
	    (slot-name-to-sql-name field))))

(defun row-field-string (fields)
  (let ((names ""))
    (dolist (field fields)
      (unless (eq field (car fields))
	(string-append names ","))
      (string-append names (slot-name-to-sql-name (car field))))
    names))
	  
(defun slot-name-to-sql-name (name)
  (substitute #\_ #\- (format nil "~a" name)))

(defun create-table-string (table-name fields)
  (let ((cmd (format nil "CREATE TABLE ~A (" (slot-name-to-sql-name table-name))))
    (dolist (field fields)
      (unless (eq field (car fields))
	(string-append cmd ", "))
      (string-append cmd (slot-name-to-sql-name (car field)) " ")
      (let (length type)
	(with-key-value-list (key value (rest field))
	  (case key
	    (:length
	     (setq length value))
	    (:type
	     (setq type value))))
	(string-append cmd (sql-field-cmd type length))))
    (string-append cmd ")")))
  

(defun sql-field-cmd (type length)
  (ecase type
    (:string
     (if (< length 8)
	 (format nil "CHAR(~d)" length)
       (format nil "VARCHAR(~d)" length)))
    (:text
     "LONGTEXT")
    (:fixnum
     "INTEGER")
    (:bigint
     "BIGINT")
    (:short-float
     "SINGLE")
    (:long-float
     "DOUBLE")))
      
(defmacro with-key-value-list ((key value list) form)
  (let ((i (gensym)))
    `(loop for ,i from 0 to (1- (length ,list)) by 2 do
	   (let ((,key (nth ,i ,list))
		 (,value (nth (1+ ,i) ,list)))
	     ,form))))
						   
(defun parse-fields (table-name fields)
  (let (class-fields)
    (dolist (field fields)
      (let* ((fname (car field))
	     (name-string (write-to-string fname))
	     (initarg (intern name-string :keyword))concat-symbol
	     (def (list fname))
	     (options (rest field)))
	(with-key-value-list (key value options)
	  (case key
	    (:type
	     (setq def (nconc def (list :type 
					(ecase value
					  (:string
					   'string)
					  (:fixnum
					   'fixnum)
					  (:bigint
					   'integer)
					  (:short-float
					   'short-float)
					  (:long
					   'long-float)
					  (:text
					   'string))))))))
	(setq def (nconc def (list 
			      :initarg initarg
			      :accessor (concat-symbol 
					 (write-to-string table-name) "-"
					 (write-to-string fname)))))
	(push def class-fields)))
    class-fields))

(defun default-initargs (fields)
  (let ((initargs (list :default-initargs)))
    (dolist (field fields)
      (let* ((fname (car field))
	     (name-string (write-to-string fname))
	     (initarg (intern name-string :keyword)))
	(setq initargs (nconc initargs (list initarg nil)))))
    initargs))