;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
  "$Header: /home/pvaneynd/fakeroot/cvs2.cons.org/src/code/tty-inspect.lisp,v 1.15 1994/10/31 04:11:27 ram Exp $")
;;;
;;; **********************************************************************
;;;
;;; TK interface for INSPECT.
;;;
;;; Written by Peter Van Eynde, base on the tty inspector of Blaine Burks

;;;
(in-package "INSPECT")
;(in-package "TK")

;(defun inspect (object)
;  (tk-inspect object))

(defun get-unique-name (beginning)
  (do* ((n (random most-positive-fixnum))
	(name (tk::conc beginning n)))
       ((not (string= "1"
		      (tk::winfo :exists name)))
	name)))


(defun tk-inspect (object)
  (let ((name (get-unique-name '.inspector)))
    (tk::toplevel name
		  :relief 'groove)
    (tk::frame (tk::conc name '.commands)
	       :relief 'sunken)
    (tk::pack  (tk::conc name '.commands)
	       :side 'top
	       :expand 1
	       :fill 'x)
    (tk::button (tk::conc name '.commands.close)
		:text "Close"
		:cursor 'gumby
		:command `(tk::destroy ',name))
    (tk::button (tk::conc name '.commands.return)
		:text "Return object"
		:command '())
    (tk::button (tk::conc name '.commands.update)
		:text "Update"
		:command `(progn
			   (tk::destroy (tk::conc ',name '.subwin))
			   (tk::destroy (tk::conc ',name '.name-label))
			   (tk-inspect-fill ',name ',object)))
    (tk::pack  (tk::conc name '.commands.close)
	       (tk::conc name '.commands.return)
	       (tk::conc name '.commands.update)
	       :side 'left
	       :expand 1
	       :fill 'x)
    (tk-inspect-fill name object)))

;;; copied from tty-inspector
(defun index-string (index rev-dimensions)
  (if (null rev-dimensions)
      "[]"
      (let ((list nil))
	(dolist (dim rev-dimensions)
	  (multiple-value-bind (q r)
			       (floor index dim)
	    (setq index q)
	    (push r list)))
	(format nil "[~D~{,~D~}]" (car list) (cdr list)))))

(defun tk-inspect-fill (name object)
  (let ((inspect-length 20) ; maximal length of inspector
	(%illegal-object% (cons nil nil)))
  (macrolet ((do-it (type &rest code)
	       `(progn
		 (let ((*print-length* inspect-length))
		   (tk::wm :title name
			   (format nil "inspector for the ~A ~A"
				   ,type object)))
		 (let ((frame (tk::conc name '.subwin))
		       (label (tk::conc name '.name-label)))
		   (let ((*print-length* inspect-length))
		     (tk::label label
				:text (format nil "~A ~A" ,type object)))
		   (tk::pack label
			     :side 'top
			     :expand t
			     :fill 'both)
		   (tk::frame frame
			      :relief 'raised)
		   (tk::pack frame
			     :side 'bottom
			     :expand 1
			     :fill 'x)
		   ,@code))))

    (typecase object
    ;;; for pcl:
    ;;; typecase
    ;;;   standard-object: (type-of object)
    ;;; (defun is-traced (function)
    ;;;   (let ((fun (debug::trace-fdefinition function)))
    ;;;     (if (gethash fun debug::*traced-functions*) t)))
    ;;; dd-slots
    ;;; dsd-%name
    ;;; dsd-accessor
    ;;;
    ;;; boundp fboundp
    ;;;
    ;;; kernel:layout-info
    ;;; kernel:%instance-layout
    ;;;
    ;;; slot->pcl::name
    ;;; alloc -> pcl::allocation
    ;;; -> :instance of :class of other
    ;;;
    ;;; slot-boundp object slot
    ;;; slot-value object slot
    ;;;
    ;;; function-lambda-expression
    ;;;
    ;;; slotds pcl:slots-to-inspect
    (standard-object
     (do-it
	 (format nil "Object: ~A ~A" object (type-of object)) 
       (let* ((class (pcl::class-of object))
	      (slotds (pcl::slots-to-inspect class object)))
	 (dolist(slotd slotds)
	   (let* ((sframe (get-unique-name (tk::conc frame '.sframe)))
		  (sname (get-unique-name (tk::conc sframe '.name)))
		  (svalue (get-unique-name (tk::conc sframe '.value))))
	     (tk::frame sframe
			:relief 'groove)
	     (tk::pack sframe
		       :side 'top
		       :expand t
		       :fill 'x)
	     (with-slots ((slot pcl::name) (allocation pcl::allocation))
	       slotd
	       (case allocation
		 (:instance
		  (tk::label sname
			     :text (format nil "Instance allocation slot: ~A"
					   slot))
		  (if (slot-boundp object slot)
		      (tk::button svalue
				  :text (format nil "~A" (slot-value object slot))
				  :command `(tk-inspect ',(slot-value object slot)))
		      (tk::label svalue
				 :text "Unbound")))
		 
		 (:class 
		  (tk::label sname
			     :text (format nil "Class allocation slot: ~A"
					   slot))
		  (if (slot-boundp object slot)
		      (tk::button svalue
				  :text (format nil "~A" (slot-value object slot))
				  :command `(tk-inspect ',(slot-value object slot)))
		      (tk::label svalue
				 :text "Unbound")))
		  (otherwise 
	           (tk::label sname
			      :text (format nil "Other allocation slot: ~A [~A]"
					    slot allocation))
		   (if (slot-boundp object slot)
		       (tk::button svalue
				   :text (format nil "~A" (slot-value object slot))
				   :command `(tk-inspect ',(slot-value object slot)))
		       (tk::label svalue
				  :text "Unbound")))))
	     (tk::pack  sname
			svalue
			:side 'left
			:expand t
			:fill 'x))))))
    (symbol
     (do-it "Symbol"
       (flet ((mitem (name value)
		    (let* ((sframe (get-unique-name (tk::conc frame '.frvalue)))
			    (sname (get-unique-name (tk::conc sframe '.name)))
			    (svalue (get-unique-name (tk::conc sframe '.value))))
		      (tk::frame sframe
		       :relief 'groove)
		      (tk::pack sframe
		       :side 'top
		       :expand t
		       :fill 'x)
		      (tk::label sname
		       :text name)
		      (tk::button svalue
		       :text (format nil "~A" value)
		       :command `(tk-inspect ,value))
		      (tk::pack  sname
				 svalue
		       :side 'left
		       :expand t
		       :fill 'x))))

	 (mitem "Bound" (boundp object))
	 (mitem "FBound" (fboundp object))
	 (mitem "Value" (if (boundp object)
			    (symbol-value object)
			    %illegal-object%))
	 (mitem "Function" (if (fboundp object)
			      (symbol-function object)
			      %illegal-object%))
	 (mitem "Plist" (symbol-plist object))
	 (mitem "Package" (symbol-package object)))))
    (vector
     (do-it (format nil "~:[~;displaced ~]vector of length ~d"
		    (and (lisp::array-header-p object)
			 (lisp::%array-displaced-p object))
		    (length object))
       (let* ((length (min (array-total-size object) inspect-length))
	      (reference-array (make-array length :displaced-to object)))
	 (dotimes (i length)
	   (let* ((sframe (get-unique-name (tk::conc frame '.sframe)))
		  (sname (get-unique-name (tk::conc sframe '.name)))
		  (svalue (get-unique-name (tk::conc sframe '.value))))
	     (tk::frame sframe
			:relief 'groove)
	     (tk::pack sframe
		       :side 'top
		       :expand t
		       :fill 'x)
	     (tk::label sname
			:text (format nil "~A" i))
	     (tk::button svalue
			 :text (format nil "~A" (aref reference-array i))
			 :command `(tk-inspect ',(aref reference-array i)))
	     (tk::pack  sname
			svalue
			:side 'left
			:expand t
			:fill 'x))))))
    (array
     (let* ((length (min (array-total-size object) inspect-length))
	    (reference-array (make-array length :displaced-to object))
	    (dimensions (array-dimensions object)))
     (do-it
	 (format nil "~:[a displaced~;an~] array of ~a, of length ~s"
		 (and (lisp::array-header-p object)
		      (lisp::%array-displaced-p object))
		 (array-element-type object)
		 dimensions)
       (dotimes (i length)
	 (let* ((sframe (get-unique-name (tk::conc frame '.sframe)))
		(sname (get-unique-name (tk::conc sframe '.name)))
		(svalue (get-unique-name (tk::conc sframe '.value))))
	   (tk::frame sframe
		      :relief 'groove)
	   (tk::pack sframe
		     :side 'top
		     :expand t
		     :fill 'x)
	   (tk::label sname
		      :text (format nil "~A" (index-string i (reverse dimensions))))
	   (tk::button svalue
		       :text (format nil "~A" (aref reference-array i))
		       :command `(tk-inspect ',(aref reference-array i)))
	   (tk::pack  sname
		      svalue
		      :side 'left
		      :expand t
		      :fill 'x))))))
    (cons
     (do-it
	 (format nil "List of length ~d" (length object))
       (dotimes (i (length object))
	 (let* ((sframe (get-unique-name (tk::conc frame '.sframe)))
		(sname (get-unique-name (tk::conc sframe '.name)))
		(svalue (get-unique-name (tk::conc sframe '.value))))
	   (tk::frame sframe
		      :relief 'groove)
	   (tk::pack sframe
		     :side 'top
		     :expand t
		     :fill 'x)
	   (tk::label sname
		      :text (format nil "~A" i))
	   (tk::button svalue
		       :text (format nil "~A" (nth i object))
		       :command `(tk-inspect ',(nth i object)))
	   (tk::pack  sname
		      svalue
		      :side 'left
		      :expand t
		      :fill 'x)))))
    (instance
     (tk-describe-instance-parts object name inspect-length :structure))
    (function
     (if (kernel:funcallable-instance-p object)
	 (tk-describe-instance-parts object name inspect-length :funcallabe-instance)
	 (tk-describe-function-parts object name inspect-length)))
    (t
     (do-it "Atom"
       (let* ((sframe (get-unique-name (tk::conc frame '.frvalue)))
	      (sname (get-unique-name (tk::conc sframe '.name)))
	      (svalue (get-unique-name (tk::conc sframe '.value))))
	 (tk::frame sframe
		    :relief 'groove)
	 (tk::pack sframe
		   :side 'top
		   :expand t
		   :fill 'x)
	 (tk::label sname
		    :text "Atom")
	 (tk::button svalue
		     :text (format nil "~A" object)
		     :command `(tk-inspect ,object))
	 (tk::pack  sname
		    svalue
		    :side 'left
		    :expand t
		    :fill 'x))))
    ))))

(defun tk-describe-instance-parts (object name inspect-length kind)
  (let ((type (format nil "~s is a ~(~A~).~%" object kind)))
    (let ((*print-length* inspect-length))
      (tk::wm :title name
	      (format nil "inspector for the ~A" type)))
    (let ((frame (tk::conc name '.subwin))
	  (label (tk::conc name '.name-label)))
      (let ((*print-length* inspect-length))
	(tk::label label
		   :text (format nil "~A ~A" type object)))
      (tk::pack label
		:side 'top
		:expand t
		:fill 'both)
      (tk::frame frame
		 :relief 'raised)
      (tk::pack frame
		:side 'bottom
		:expand 1
		:fill 'x)

      (let ((info (kernel:layout-info (kernel:layout-of object))))
	(when (kernel::defstruct-description-p info)
	  (dolist (dd-slot (kernel:dd-slots info))
	    (let* ((sframe (get-unique-name (tk::conc frame '.sframe)))
		   (sname (get-unique-name (tk::conc sframe '.name)))
		   (svalue (get-unique-name (tk::conc sframe '.value))))
	      (tk::frame sframe
			 :relief 'groove)
	      (tk::pack sframe
			:side 'top
			:expand t
			:fill 'x)
	      (tk::label sname
			 :text (format nil "~A" (kernel:dsd-%name dd-slot)))
	      (tk::button svalue
			  :text (format nil "~A" (funcall (kernel:dsd-accessor dd-slot)
							  object))	   
			  :command `(tk-inspect ',(funcall (kernel:dsd-accessor dd-slot)
							   object)))
	      (tk::pack  sname
			 svalue
			 :side 'left
			 :expand t
			 :fill 'x))))))))

(defun tk-describe-function-parts (object name inspect-length)
  (let* ((type (kernel:get-type object))
	 (object (if (= type vm:closure-header-type)
		     (kernel:%closure-function object)
		     object)))
    (let ((type (format nil "~s is a Function.~%" object)))
      (let ((*print-length* inspect-length))
	(tk::wm :title name
		(format nil "inspector for the ~A ~A" type object)))
      (let ((frame (tk::conc name '.subwin))
	    (label (tk::conc name '.name-label)))
	(let ((*print-length* inspect-length))
	  (tk::label label
		     :text (format nil "~A ~A" type object)))
	(tk::pack label
		  :side 'top
		  :expand t
		  :fill 'both)
	(tk::frame frame
		   :relief 'raised)
	(tk::pack frame
		  :side 'bottom
		  :expand 1
		  :fill 'x)

	(macrolet ((it (name what)
		     `(let* ((sframe (get-unique-name (tk::conc frame '.bound)))
			    (sname (get-unique-name (tk::conc sframe '.name)))
			    (svalue (get-unique-name (tk::conc sframe '.value))))
		       (tk::frame sframe
				  :relief 'groove)
		       (tk::pack sframe
				 :side 'top
				 :expand t
				 :fill 'x)
		       (tk::label sname
				  :text ,name)
		       (tk::label svalue
				  :text (format nil "~A" ,what))
		       (tk::pack  sname
				  svalue
				  :side 'left
				  :expand t
				  :fill 'x))))
	  (it "Bound:" (fboundp object))
	  (multiple-value-bind (a b c)
	      (function-lambda-expression object_)
	    (it (format nil "Source of ~a ~:[(in null env.)~]" c b)
		a))
	  (it "Argument-list:" (kernel:%function-arglist object)))))))



