;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*-
;;;
;;;  Touched: <2007-08-02 12:09:56 +0530> Madhu <enometh@net.meer>
;;;  Bugs-To: enometh@net.meer
;;;  Status: Experimental. Do not redistribute.
;;;  Copyright (C) 2007 Madhu.  All Rights Reserved.
;;;
;;; Simple example for viewing tables in an already open
;;; SQL:*DEFAULT-DATABASE* using CAPI:MULTI-COLUMN-LIST-PANELs.
;;; Inspired by Dmitry's explotab program from lisp.ystok.ru.
;;;
;;; Define SQL package appropriately for YSQL/CLSQL.  Lightly tested
;;; with an ODBC backend.  Extend functions where SQL-TYPE1 is used to
;;; teach it other database types.
;;;
(defpackage "EXPLOTAB"
  (:use "CL")
  (:export "INITIALIZE-INTERFACE"))
(in-package "EXPLOTAB")

;;;
;;;     *ALL-TABLES* = (QUOTE-CHAR . ((TABLE-NAME . PLIST) ...))
;;; PLIST INDICATORS = :COLUMN-NAMES :COLUMN-TYPES :COLUMNS ...
;;;
(defvar *all-tables* nil)

(defun %close-database ()
  (setq *all-tables* nil))

(defun %open-database ()
  (when sql:*default-database*
    (let ((table-names (sql:list-tables :database sql:*default-database*))
	  (quote-char
	   (or				;XXX
	    #+ysql
	    (odbc:db-get-info sql:*default-database*
			      ystok.odbc::SQL_IDENTIFIER_QUOTE_CHAR)
	    #\`)))
      (setq *all-tables*
	    (cons quote-char (mapcar 'list table-names))))))

(defun %close-table (table-name)
  (destructuring-bind (quote-char . alist) *all-tables*
    (declare (ignore quote-char))
    (loop for x in alist for (string . plist) = x
	  when (string-equal table-name string) do
	  (return-from %close-table
	    (when plist
	      (setf (cdr x) nil)
	      T)))))

(defun %open-table (table-name)
  "Returns (table-name . plist) on NIL."
  (destructuring-bind (quote-char . alist) *all-tables*
    (loop for x in alist for (string . plist) = x
	  when (string-equal table-name string) return
	  (cond (plist x)
		(t (multiple-value-bind (columns column-names)
		       (SQL:QUERY
			(format nil "SELECT * FROM ~A~A~A;"
				quote-char table-name quote-char))
		     (setf (cdr x)
			   (list :column-names column-names
				 :column-types
				 (mapcar (lambda (x)
					   (sql:attribute-type x table-name))
					 column-names)
				 :columns columns))) x)))))


;;; ----------------------------------------------------------------------
;;;
;;; LOOSE
;;;
(defun sql-type1 (column-type)
  "Returns a keyword denoting a type. COLUMN-TYPE is what
SQL:ATTRIBUTE-TYPE would return."
  (if (atom column-type) column-type (car column-type)))

(defun sql-op< (x y)
  (cond ((null x) (not (null y)))
	((null y) nil)
	(t (etypecase x
	     (string
	      (etypecase y
		(string (string< x y))))
	     (number
	      (etypecase y
		(number (< x y))))))))

(defun sql-op> (x y)
  (cond ((null x) (not (null y)))
	((null y) nil)
	(t (etypecase x
	     (string
	      (etypecase y
		(string (string> x y))))
	     (number
	      (etypecase y
		(number (> x y))))))))

(defun sort-table-on-column (table-name column-name)
  (let ((x (%open-table table-name)))
    (assert x nil  "Table: ~A not found among open tables." table-name)
    (destructuring-bind (string . plist) x
      (assert (equal string table-name) nil "Sanity on ~S." string)
      (when plist
	(destructuring-bind (&key column-names columns &allow-other-keys)
	    plist
	  (let ((n (loop for string in column-names for i from 0
			 when (string-equal column-name string)
			 return i)))
	    (unless n
	      (error "Unknown column: ~S, in Table: ~S."
		     column-name table-name))
	    (let (first second)
	      (loop for row in columns for x = (elt row n) do
		    (cond ((null first) (setq first x))
			  ((null second)
			   (unless (and (not (sql-op< first x))
					(not (sql-op> first x)))
			     (setq second x)))
			  (t (return))))
	      (when (and first second)
		(setf (getf plist :columns)
		      (sort columns
			    (if (sql-op< first second)
				#'sql-op>
				#'sql-op<)
			    :key (lambda (x) (elt x n))))))))))))


;;; ----------------------------------------------------------------------
;;;
;;;
(defvar *file-menu*
  (make-instance 'capi:menu
		 :title "File"
		 :items '("Open" "Close")
		 :callback 'file-menu-callback))


;;; ----------------------------------------------------------------------
;;;
;;; TABLES-LIST-PANEL: LIST TABLE NAMES
;;;
;;; Use a multi-column-list panel so you can sort on table name
;;;
(defvar *tables-list-panel1*
  (make-instance
   'capi:multi-column-list-panel
   :items nil
   :auto-reset-column-widths nil
   :columns '((:title "Tables"))
   :visible-min-height '(character 20)
   :visible-min-width '(character 20)
   :header-args
   (list :selection-callback 'tables-list-panel1-header-selection-callback)
   :interaction :single-selection
   :selection-callback 'tables-list-panel1-selection-callback))

(defun tables-list-panel1-header-selection-callback (interface data)
  "Toggle sort order."
  (declare (ignore interface))
  (assert (equalp data "Tables") nil "Sanity on ~S." data)
  (let* ((tables-list-panel *tables-list-panel1*)
	 (items (capi:collection-items tables-list-panel))
	 (length (length items)))
    (unless (or (zerop length) (= length 1))
      (setf (capi:collection-items *tables-list-panel1*)
	    (sort items
		  (if (string< (car (elt items 0)) (car (elt items 1)))
		      #'string>
		      #'string<)
		  :key #'car)))))

(defun %update-tables-list-panel1 ()
  (setf (capi:collection-items *tables-list-panel1*)
	(if *all-tables*
	    (mapcar 'list (mapcar 'car (cdr *all-tables*)))
	    nil)))


;;; ----------------------------------------------------------------------
;;;
;;;
;;;
(defvar +right-alignment-gap+ 10)	;DIY

(defun %get-mclp-columns (column-names column-types)
  "Returns a list of elememts [each of which is] suitable as a
:header-arg in creating a multi-column-list-panel."
  (loop for column-name in column-names
	for column-type in column-types
	collect
	(case (sql-type1 column-type)
	  ((:CURRENCY :DOUBLE :INTEGER)
	   (list :title column-name
		 :adjust :right
		 :gap +right-alignment-gap+))
	  (otherwise
	   (list :title column-name)))))

(defun %get-mclp-item-print-functions (column-types)
  (flet ((sql-print-datetime (x)
	   (etypecase x
	     (null "NIL")
	     (number
	      (multiple-value-bind (seconds minutes hours day month year)
		  (decode-universal-time x)
		(format nil "~D-~2,'0D-~2,'0D ~D:~2,'0D:~2,'0D"
			year month day hours minutes seconds)))
	     (string x)))
	 (sql-print-currency (x)
	   (etypecase x
	     (null "NIL")
	     (number (format nil "~$" x))
	     (string x)))
	 (sql-print-general (x)
	   (etypecase x
	     (null "NIL")
	     (string x)
	     (integer (format nil "~D" x))
	     (float (format nil "~F" x)))))
    (loop for column-type in column-types
	  collect
	  (case (sql-type1 column-type)
	    (:CURRENCY #'sql-print-currency)
	    (:DATETIME #'sql-print-datetime)
	    (otherwise #'sql-print-general)))))

(defun get-mclp (table-name &optional multi-column-list-panel)
  (let ((x (%open-table table-name)))
    (assert x nil "table ~A not found in open tables." table-name)
    (destructuring-bind (table . plist) x
      (assert (string-equal table table-name) nil "Sanity on ~S." table-name)
      (destructuring-bind (&key column-names mclp column-types columns
				&allow-other-keys)
	  plist
	(let ((mclp-columns (%get-mclp-columns column-names column-types))
	      (printfns (%get-mclp-item-print-functions column-types)))
	  (etypecase multi-column-list-panel
	    (null
	     (setq multi-column-list-panel
		   (or mclp
		       (setf (getf (cdr x) :mclp)
			     (make-instance 'capi:multi-column-list-panel
					    :columns mclp-columns
					    :auto-reset-column-widths nil
					    :item-print-functions printfns
					    :items columns
					    :header-args
					    (list
					     :selection-callback
					     (lambda (intf data)
					       (check-type intf
							   capi:interface)
					       (when
						   (sort-table-on-column
						    table data)
						 (let ((mclp
							(get-mclp table)))
						   (setf
						    (capi::collection-items
						     mclp)
						    columns)
						   (%set-simple-layout mclp))
						 ))))))))
	    (capi:multi-column-list-panel
	     (setf (capi::list-panel-columns multi-column-list-panel) columns)
	     mclp-columns))
	  multi-column-list-panel)))))

;;; ----------------------------------------------------------------------
;;;
;;; TOP LEVEL
;;;

(defvar *interface1*
  (make-instance 'capi:interface
		 :title "Table Explorer"))

(defmacro with-*interface1* ((function &rest args))
  `(capi:apply-in-pane-process
    *interface1*
    #',function
    ,@args))

(defvar *simple-layout1*
  (make-instance 'capi:simple-layout
		 :visible-min-width '(character 60)
		 :visible-min-height '(character 20)))

(defvar *row-layout1* (make-instance 'capi:row-layout))

;;;
;;;  STASH HEADER WIDTHS INFO AND RESTORE
;;;
(defun %header (lp)
  "Return the  CAPI:HEADER-CONTROL of list panel."
  (check-type lp capi::list-panel)
  (capi::generic-titled-list-panel-header
   (capi:element-parent
    (capi:element-parent lp))))

(defun %set-simple-layout (mclp)
  (declare (special *simple-layout1*))	; defined below
  (capi::set-layout-description *simple-layout1*
				(if mclp
				    (list mclp)
				    nil))
  (when mclp				; stash headers and restore
    (let ((x (find-if (lambda (x) (eq (getf (cdr x) :mclp) mclp))
		      (cdr *all-tables*))))
      (when x
	(let ((header-widths (getf (cdr x) :header-widths)))
	  (cond (header-widths
		 (capi::multi-column-list-panel-set-widths
		  mclp header-widths))
		(t (setf (getf (cdr x) :header-widths)
			 (capi::header-control-widths
			  (%header mclp))))))))))

(defmethod capi::header-control-width-change :after (self widths)
  (let ((x (find-if (lambda (x)
		      (let ((lp (getf (cdr x) :mclp)))
			(when lp
			  (eq (%header lp) self))))
		    (cdr *all-tables*))))
    (when x
      (setf (getf (cdr x) :header-widths) widths))))


;;; ----------------------------------------------------------------------
;;;
;;;
;;;
(defun tables-list-panel1-selection-callback (data intf)
  (declare (ignore intf))
  (let* ((table (car data))
	 (mclp (get-mclp table)))
    (%set-simple-layout mclp)))

(defun file-menu-callback (data intf)
  (cond ((string-equal data "Open")
	 (%open-database)
	 (%update-tables-list-panel1))
	((string-equal data "Close")
	 (%close-database)
	 (%set-simple-layout nil)
	 (%update-tables-list-panel1))
	(t (error "File Menu: Unexpected Data: ~S, Intf ~S."
		  data intf))))

(defun initialize-interface ()
  (setf (capi:interface-menu-bar-items *interface1*)
	(list *file-menu*))
  (%set-simple-layout nil)
  (capi::set-layout-description *row-layout1*
				(list *tables-list-panel1*
				      :divider
				      *simple-layout1*))
  (setf (slot-value *interface1* 'capi::layouts) (list *row-layout1*))
  (%update-tables-list-panel1)
  (capi:display *interface1*))

#+nil
(initialize-interface)

'#:EOF

;;; ----------------------------------------------------------------------
;;; TODO
;;;
;;; Use define-interface instead of linking up global variables
;;;
;;; header widths elements
;;;
;;; Use column-function and item-print-function for
;;; multi-column-list-panel on items of view-class objects
;;;