;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:          sql.lisp
;;;; Purpose:       SQL Generation functions for Hyperobject
;;;; Programmer:    Kevin M. Rosenberg
;;;; Date Started:  Apr 2000
;;;;
;;;; $Id$
;;;;
;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
;;;; *************************************************************************

(in-package #:hyperobject)

;;;; Metaclass initialization commands

(defun finalize-sql (cl)
  (setf (slot-value cl 'drop-table-cmd) (generate-drop-table-cmd
                                         (slot-value cl 'sql-name)))
  (let ((esds (class-slots cl)))
    (setf (slot-value cl 'create-table-cmd)
      (generate-create-table-cmd
       cl
       (remove-if #'(lambda (esd) (null (esd-stored esd))) esds)))
    (setf (slot-value cl 'create-indices-cmds)
      (generate-create-indices-cmds (sql-name cl) esds))
    (dolist (esd esds)
      (when (slot-value esd 'inverse)
        (define-inverse cl esd))))
  )


(defun define-inverse (class esd)
  "Define an inverse function for a slot"
  (let ((inverse (slot-value esd 'inverse)))
    (when inverse
      (eval
       `(defun ,inverse (obj)
          (format t "~&Finding key: ~S for class ~S ~%" obj ,class)
          ;; create inverse function
          ))
      ))
  )

(defun generate-create-table-cmd (cl esds)
  (with-output-to-string (s)
    (format s "CREATE TABLE ~A (~{~A~^, ~})"
            (slot-value cl 'sql-name)
            (loop for esd in esds
                collect
                  (concatenate
                      'string
                    (slot-value esd 'sql-name)
                    " "
                    (sql-type-to-field-string (slot-value esd 'sql-type)
                                              (slot-value esd 'sql-length)))))))

(defun sql-type-to-field-string (type length)
  (ecase type
    (:string
     (cond
      ((null length)
       "LONGTEXT")
      ((< length 8)
       (format nil "CHAR(~d)" length))
      (t
       (format nil "VARCHAR(~d)" length))))
    (:varchar
     (cond
      ((null length)
       "LONGTEXT")
      (t
       (format nil "VARCHAR(~d)" length))))
    (:text
     "LONGTEXT")
    (:datetime
     "VARCHAR(20)")
    (:char
     (unless length
       (setq length 1))
     (format nil "CHAR(~D)" length))
    ((or :fixnum :integer)
     "INTEGER")
    (:boolean
     "CHAR(1)")
    (:long-integer
     "BIGINT")
    ((or :short-float :float)
     "SINGLE")
    (:long-float
     "DOUBLE")))

(defun generate-drop-table-cmd (table-name)
  (format nil "DROP TABLE ~a" table-name))

(defun generate-create-indices-cmds (table-name slots)
  (let (indices)
    (dolist (slot slots)
      (when (slot-value slot 'indexed)
        (let ((sql-name (slot-value slot 'sql-name)))
          (push (sql-cmd-index table-name sql-name (slot-value slot 'unique))
                indices))))
    indices))

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

(defun sql-index-name (table field)
  (format nil "~A_~A" table field))

;;;; Runtime Commands

(defgeneric sql-create (cl))
(defmethod sql-create (cl)
 (with-sql-connection (conn)
    (sql-execute (slot-value cl 'create-table-cmd) conn)
    (dolist (cmd (slot-value cl 'create-indices-cmds))
      (sql-execute cmd conn))
    (values)))

(defgeneric sql-drop (cl))
(defmethod sql-drop (cl)
  (mutex-sql-execute (slot-value cl 'drop-table-cmd))
  (values))

#|
(defmethod sql-insert (obj)
  (mutex-sql-execute
   (format nil "INSERT INTO ~a (~a) VALUES (~a)"
           (sql-name self) (sql-cmd-field-names self) (format-values self))))

(defmethod sql-select (obj lisp-name key)
  (let ((tuple
         (car
          (mutex-sql-query
           (format nil "SELECT ~a FROM ~a WHERE ~a=~a"
                   (sql-cmd-field-names self) (sql-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))

(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 row-field-string (fields)
  (let ((names ""))
    (dolist (field fields)
      (unless (eq field (car fields))
        (string-append names ","))
      (string-append names (lisp-name-to-sql-name (car field))))
    names))


(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)
                                          (:long-integer
                                           '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))

||#