;;; inspector.lisp
;;;
;;; Copyright (C) 2008-2009 Alessio Stalla
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
;;;
;;; As a special exception, the copyright holders of this library give you
;;; permission to link this library with independent modules to produce an
;;; executable, regardless of the license terms of these independent
;;; modules, and to copy and distribute the resulting executable under
;;; terms of your choice, provided that you also meet, for each linked
;;; independent module, the terms and conditions of the license of that
;;; module.  An independent module is a module which is not derived from
;;; or based on this library.  If you modify this library, you may extend
;;; this exception to your version of the library, but you are not
;;; obligated to do so.  If you do not wish to do so, delete this
;;; exception statement from your version.

(in-package :snow)

(defclass object-descriptor ()
  ((object :initarg :object :reader described-object)
   (description :initarg :description :accessor object-description)
   (type :initarg :type :accessor object-type)
   (class :initarg :class :accessor object-class)))

(defgeneric object-parts (descriptor))

(defmethod object-parts ((descriptor object-descriptor))
  (describe-parts (described-object descriptor)))

(defgeneric refreshed-descriptor (obj))

(defmethod refreshed-descriptor ((obj object-descriptor))
  (object-descriptor (described-object obj)))

#|
(defgeneric inspector-actions (obj))

(defmethod inspector-actions ((obj object-descriptor))
  (cond
    ((jinstance-of-p (described-object obj)
		     "org.armedbear.lisp.JavaObject.FieldRef")
     )))|#

(defun make-object-descriptor (obj description)
  (make-instance 'object-descriptor
		 :object obj
		 :description description
		 :type (type-of obj)
		 :class (class-of obj)))

(defgeneric object-descriptor (obj))

(defmethod object-descriptor (obj)
  (make-object-descriptor obj (sys::inspected-description obj)))

(defgeneric describe-parts (obj))

(defmethod describe-parts (obj)
  (mapcar (lambda (pair)
	    (cons (car pair) (object-descriptor (cdr pair))))
	  (sys:inspected-parts obj)))

(defmethod describe-parts ((obj package))
  `(("symbols" . ,(object-descriptor
		   (loop :for x :being :the :present-symbols :of obj
		         :collect x)))))

(defmethod describe-parts ((obj cons))
  (if (listp (cdr obj))
      (loop
	 :for i :from 0
	 :for x :in obj
	 :collect (cons (princ-to-string i)
			(object-descriptor x)))
      `(("car" . ,(object-descriptor (car obj)))
	("cdr" . ,(object-descriptor (cdr obj))))))

(defun part-name (part)
  (car part))

(defun part-descriptor (part)
  (cdr part))

(defmacro with-parent-widget (parent &body body)
  `(let ((*parent* ,parent))
     ,@body))

(defun inspector-panel (stack container &optional window)
  (let ((descr (refreshed-descriptor (car stack))))
    (panel (:id panel
	    :layout-manager '(:box :y))
      (scroll (:layout "grow, wrap")
	(with-widget ((text-area :text (object-description descr))
		                 :id txt :layout "grow")
	  (setf (widget-property txt :line-wrap) (jbool t))));Swing specific!!!
      (bwhen (parts (object-parts descr))
	(with-parent-widget panel
	  (tabs (:layout "grow, wrap" :wrap nil :tab-placement :left)
	    (dolist (part parts)
	      (let ((part part))
		(tab (part-name part)
		  (panel ()
		    (text-area
		     :text (object-description (part-descriptor part))
		     :layout "grow, wrap, span 2")
		    (button
		     :text "Inspect"
		     :layout "wrap"
		     :on-action (lambda ()
				  (update-inspector 
				   panel
				   (inspector-panel (cons (part-descriptor part)
							  stack)
						    container window)
				   container)))
		    (button :text "Inspect (new window)"
			    :on-action (lambda ()
					 (inspect-object (part-descriptor part)))))))))))
      (scroll (:layout "grow, wrap")
        (gui-repl :dispose-on-close window))
      (panel ()
	(button :text "Back" :enabled-p (cdr stack)
		:on-action (lambda ()
			     (update-inspector 
			      panel
			      (inspector-panel (cdr stack) container window)
			      container)))))))

(defun update-inspector (old-panel new-panel container)
  (invoke "remove" container old-panel);Swing specific!!!
  (add-child new-panel container)
  (invoke "validate" container);Swing specific!!!
  (pack container))

(defun ensure-object-descriptor (obj)
  (if (typep obj 'object-descriptor)
      obj
      (object-descriptor obj)))

(defun inspect-object (obj)
  (let ((stack (list (ensure-object-descriptor obj))))
    (with-gui ()
      (frame (:id frame :layout-manager :border)
	(child (inspector-panel stack frame frame))
	(pack frame)
	(show frame)))))

(defun install-graphical-inspector ()
  (let ((old-inspector-hook ext:*inspector-hook*))
    (setq ext:*inspector-hook* #'inspect-object)
    (values ext:*inspector-hook* old-inspector-hook)))

#||
(inspect-object 3)
(inspect-object 'inspect-object)
(inspect-object *package*)
(inspect-object *standard-output*)
(inspect-object (new "java.util.ArrayList"))
(inspect-object (new "javax.swing.JButton"))
(inspect-object (inspect-object 3))
||#