;;; -*- Mode: Lisp; Package: INSPECT -*-

(in-package "INSPECT")

(defgeneric set-cell (cell-item object-item)
  (:generic-function-class operation)
  (:documentation "Set this cell"))
  
(defgeneric modify-cell (cell-item)
  (:generic-function-class operation)
  (:documentation "Modify this cell, after accepting a value"))

(defgeneric show-object (object-item)
  (:generic-function-class operation)
  (:documentation "Show this object in context"))

(defgeneric show-object-in-the-next-less-specific-view-class (object-item)
  (:generic-function-class operation)
  (:documentation "Show a more general view"))

(defgeneric show-object-in-the-most-specific-view-class (object-item)
  (:generic-function-class operation)
  (:documentation "Show this object"))

#||
(defgeneric show-object-in-arbitrary-class (object-item)
  (:generic-function-class operation)
  (:documentation "Show this object, after accepting a view class"))
||#

(defclass object-item (text-item)
  ())

(defmethod item-object ((item object-item))
  (error "class ~s is an abstract class" 'object-item))

(defmethod item-object-class ((item object-item))
  (class-of (item-object item)))

(defmethod item-object-view ((item object-item))
  nil)

(defmethod item-object-view :around ((item object-item))
  (with-slots (object-view reader)
    item
    (or	(call-next-method)
	(object-view-for-view-class
	 (first (object-view-classes-for-object (item-object item)))))))

(defmethod item-read-only-p ((item object-item))
  t)

(defvar *packages-without-circle-structures*
  (mapcar #'find-package '(:lisp :pcl :xlib :inspect)))

(defun inspecter-print-object (object)
  (let ((*print-length* 5)
	(*print-level* 2)
	(*print-circle* 
	 (not (or (pcl::std-instance-p object)
		  (let ((type (type-of object)))
		    (when (consp type)
		      (setq type (car type)))
		    (and (symbolp type)
			 (member (symbol-package type)
				 *packages-without-circle-structures*))))))
	(*print-pretty* nil)
	;;(*print-structure* nil)
	(*print-array* nil))
    (format nil "~S" object)))

(defmethod compute-item-text ((item object-item))
  (let ((object (item-object item))
	(object-view (item-object-view item)))
    (inspecter-print-object
     (if (eq '$String (class-name (class-of object-view)))
	 (string object)
	 object))))

(defmethod show-object ((item object-item))
  (show-object-in-inspecter (item-inspecter item) (item-object item)
			  ':object-view (item-object-view item)))

(defmethod show-object-in-the-next-less-specific-view-class ((item object-item))
  (show-object-in-inspecter (item-inspecter item) (item-object item)
			  ':object-view (item-next-object-view item)))

(defmethod show-object-in-the-most-specific-view-class ((item object-item))
  (show-object-in-inspecter (item-inspecter item) (item-object item)))

#||
(defmethod show-object-in-arbitrary-class ((item object-item))
  (choose-value :documentation "Choose a view class"
		:list (object-view-classes-for-object (item-object item))
		:accept-function
		#'(lambda (class)
		    (show-object-in-inspecter (item-inspecter item)
					    (item-object item)
					    ':object-view-class class))))
||#

(defmethod item-next-object-view ((item object-item) &optional nil-is-ok-p)
  (or (next-object-view (item-object item) (item-object-view item))
      (unless nil-is-ok-p (item-object-view item))))

(defvar *the-class-t* (find-class 't))

(defun object-most-specific-view-class (object)
  (let ((class (first (object-view-classes-for-object object))))
    (if (eq class *the-class-t*)
	(class-of object)
	class)))

(defmethod item-most-specific-view-class ((item object-item))
  (object-most-specific-view-class (item-object item)))

(defmacro declare-next-view (object-class-name object-view-class-name)
  `(defmethod next-object-view ((object ,object-class-name)
				(object-view ,object-view-class-name)
				&optional this-class-p)
     (if this-class-p
	 (object-view-for-view-class (find-class ',object-view-class-name))
	 (call-next-method object object-view t))))

(defun view-classes-from-method (gf ocpl)
  (when (symbolp gf) (setq gf (symbol-function gf)))
  (let* ((methods (pcl::generic-function-methods gf))
	 (classes nil))
    (dolist (method methods classes)
      (let* ((specializers (pcl::method-specializers method))
	     (ospec (first specializers))
	     (vspec (second specializers)))
	(when (and (pcl::classp ospec)
		   (pcl::classp vspec)
		   (member ospec ocpl)
		   (member vspec ocpl))
	  (pushnew vspec classes))))))

(defun object-view-classes-for-object (object)
  (let ((classes (object-view-classes-for-class (class-of object))))
    (if (hash-table-p object)
	(cons (find-class 'hash-table-view) classes)
	classes)))

(defvar *ovcfc-table* (make-hash-table ':test 'eq))
(clrhash *ovcfc-table*)

(defun object-view-classes-for-class (oclass)
  (or (gethash oclass *ovcfc-table*)
      (setf (gethash oclass *ovcfc-table*)
	    (object-view-classes-for-class-internal oclass))))

(defun object-view-classes-for-class-internal (oclass)
  (let* ((ocpl (pcl::class-precedence-list oclass))
	 (classes (let ((pane-class (find-class 'pane)))
		    (when (member pane-class ocpl)
		      (list pane-class)))))
    (dolist (name '(make-title-item fixed-item-list
		    variable-items-count-function
		    variable-item-creator-function))
      (setq classes (union classes (view-classes-from-method name ocpl))))
    (let ((classes-in-cpl-order (mapcan #'(lambda (class)
					    (when (member class classes)
					      (list class)))
					ocpl)))
      (remove (find-class 'hash-table-view)
	      (append classes-in-cpl-order
		      (set-difference classes classes-in-cpl-order))))))

(defclass object-from-pane-item (object-item)
  ())

(defmethod item-object ((item object-from-pane-item))
  (pane-object (item-pane item)))

(defmethod item-object-view ((item object-from-pane-item))
  (pane-object-view (item-pane item)))

(defclass read-only-cell-item (object-item)
  ((object)
   (cell-description :reader cell-description :initarg :cell-description)
   (object-view :initform nil :initarg :object-view :reader item-object-view)
   (reader :reader cell-reader :initarg :cell-reader))
  (:default-initargs :size-within-parent :ask))

(defmethod initialize-instance :after ((item read-only-cell-item) &key)
  (revert-item item))

(defmethod revert-item :before ((item read-only-cell-item))
  (with-slots (object reader)
    item
    (setq object (funcall reader (cell-object item)))))

(defmethod item-documentation ((item read-only-cell-item))
  (cell-description item))

(defmethod item-desired-size ((item read-only-cell-item) direction)
  (case direction
    (:horizontal ':even)
    (:vertical (font-height item))))

(defmethod cell-object ((item read-only-cell-item))
  (pane-object (item-pane item)))

(defmethod rose-design-reference-p ((item read-only-cell-item))
  (with-slots (object-view)
    item
    (let ((design-class (find-class 'rs::|RoseDesign| nil)))
      (and design-class
	   (pcl::*typep object-view design-class)
	   (consp (item-object-internal item))))))

(defmethod item-object-internal ((item read-only-cell-item))
  (with-slots (object)
    item
    #-pcl object
    #+pcl
    (if (slot-boundp item 'object)
	object
	pcl::*slot-unbound*)))

(defmethod item-object ((item read-only-cell-item))
  (with-slots (object-view)
    item
    (let ((object (item-object-internal item)))
      (if (rose-design-reference-p item)
	  (setq object (rose::resolve-reference object))
	  object))))

(defmethod item-object-class ((item read-only-cell-item))
  (with-slots (object-view)
    item
    (if (rose-design-reference-p item)
	(class-of object-view)
	(class-of (item-object-internal item)))))

(defmethod item-next-object-view ((item read-only-cell-item) &optional nil-is-ok-p)
  (with-slots (object-view)
    item
    (let ((vobject (if (rose-design-reference-p item)
		       object-view
		       (item-object-internal item))))
      (or (next-object-view vobject (item-object-view item))
	  (unless nil-is-ok-p (item-object-view item))))))

(defmethod item-most-specific-view-class ((item read-only-cell-item))
  (with-slots (object-view)
    item
    (object-most-specific-view-class
      (if (rose-design-reference-p item)
	  object-view
	  (item-object-internal item)))))

(defmethod compute-item-text ((item read-only-cell-item))
  (with-slots (object object-view)
    item
    (if (rose-design-reference-p item)
	(multiple-value-bind (design design-name oid-or-nil)
	    (rose::decode-simple-reference object)
	  (declare (ignore design oid-or-nil))
	  (format nil "#<RoseDesign ~A>" design-name))
	(call-next-method))))

(defun never-ok-p (new-value object)
  (declare (ignore new-value object))
  "You can't set this")

(defun always-ok-p (new-value object)
  (declare (ignore new-value object))
  nil)

(defclass cell-item (read-only-cell-item)
  ((writer :reader cell-writer :initarg :cell-writer)
   (checker :reader value-checker :initarg :value-checker
	    :initform #'never-ok-p)))

(defmethod item-read-only-p ((item cell-item))
  (with-slots (pane)
    item
    (object-read-only-p (pane-object pane) (pane-object-view pane))))

(defmethod object-read-only-p (object object-view)
  nil)

(defmethod set-cell-internal ((item cell-item) new-value &optional read-function)
  (with-slots (inspecter xlib:display object-view checker writer)
    item
    (let ((object (cell-object item)) (state "") value error)
      (handler-case (progn
		      (if read-function
			  (progn
			    (setq state "reading value")
			    (setq value (with-input-from-string (in new-value)
					  (funcall read-function in))))
			  (setq value new-value))
		      (setq state "checking value")
		      (setq error (funcall checker value object))
		      (unless error
			(setq state "writing cell")
			(funcall writer value object)
			(setq state nil)))
         (error (condition)
	   (setq error (remove #\newline
			       (format nil "Error while ~A: ~A" state condition)))))
      (if error
	  (let ((di (inspecter-documentation-item inspecter)))
	    (setf (item-text di) error)
	    (refresh-window di)
	    (xlib:bell xlib:display)
	    nil)
	  (progn
	    (revert-item inspecter)
	    (display-item inspecter)
	    t)))))

(defmethod set-cell ((item cell-item) (new-value-item object-item))
  (set-cell-internal item (item-object new-value-item)))

(defmethod modify-cell ((item cell-item))
  (with-slots (inspecter object-view)
    item
    (let* ((object (cell-object item))
	   (stringp (eq '$String (class-name (class-of object-view))))
	   (read (if stringp #'read-line #'read)))
      (get-input (item-inspecter item)
		 ':documentation
		 (format nil "Modify ~A of object ~A"
			 (cell-description item)
			 (item-text (pane-title-item (item-pane item))))
		 ':initial-text (if stringp
				    (string (item-object item))
				    (inspecter-print-object (item-object item)))
		 ':accept-function #'(lambda (string)
				       (set-cell-internal item string read))))))

(defvar *button-list*
  '((1 0 "L")(2 0 "M")(3 0 "R")
    (1 1 "sh-L")(2 1 "sh-M")(3 1 "sh-R")))

(defun push-string (new-string string old-last-index)
  (dotimes (i (length new-string) old-last-index)
    (setf (aref string (incf old-last-index)) (aref new-string i))))

(defun build-entry (&rest operations)
  (setq operations (mapcar #'(lambda (op)
			       (when op
				 (if (atom op)
				     (cons op (operation-documentation op))
				     op)))
			   operations))
  (let ((sizes (list 0 0)) (pos (list -1 -1)) strings)
    (flet ((get-size (op b st)
	     (when op
	       (incf (nth st sizes) (+ (length (third b)) (length (cdr op)) 5))))
	   (build-list (op b st)
	     (when op
	       (let ((p (nth st pos))
		     (string (nth st strings)))
		 (setq p (push-string (third b) string p))
		 (setq p (push-string ": " string p))
		 (setq p (push-string (cdr op) string p))
		 (setq p (push-string "   " string p))
		 (setf (nth st pos) p))
	       (list (list (cons (first b) (second b)) (car op))))))
      (mapc #'get-size operations *button-list* '(0 0 0 1 1 1))
      (setq strings (mapcar #'make-string sizes))
      (let ((list (mapcan #'build-list operations *button-list* '(0 0 0 1 1 1))))
	(list list (first strings) (second strings))))))

(defmethod operation-entry ((item object-item) item-or-nil)
  (let* ((object-view (item-object-view item))
	 (most-specific-view-class (item-most-specific-view-class item))
	 (object-view-class (class-of object-view))
	 (first-p (or (eq 'rs::|RoseObject| (class-name object-view-class))
		      (member most-specific-view-class
			      (pcl::class-precedence-list object-view-class))))
	 (special-p (and (typep item 'read-only-cell-item)
			 (not (member object-view-class
				      (pcl::class-precedence-list
				       (item-object-class item))))))
	 (next-p (item-next-object-view item t))
	 (cell-p (not (item-read-only-p item))))
    (build-entry (if special-p
		     'show-object
		     'show-object-in-the-most-specific-view-class)
		 (unless (or first-p special-p) 'show-object)
		 (when next-p 'show-object-in-the-next-less-specific-view-class)
		 'select-item
		 (when (and cell-p item-or-nil)
		   `(set-cell .
		     ,(format nil "Set this slot to ~S" (item-object item-or-nil))))
		 (when cell-p 'modify-cell))))

(defclass property-value-item (item)
  ()
  (:default-initargs :size-within-parent :ask
                     :direction-of-children :horizontal
		     :border-width 0))

(defmethod item-desired-size ((item property-value-item) direction)
  (case direction
    (:horizontal ':even)
    (:vertical (font-height item))))

(defmethod initialize-instance :after ((item property-value-item) &key
				       slot-object object-view 
				       reader writer checker description)
  (when reader
    (make-internal-items item slot-object object-view 
			 reader writer checker description)))

(defgeneric slot-item-class (object pvi)
  (:argument-precedence-order pvi object))

(defmethod make-internal-items ((item property-value-item) slot-object object-view
				reader writer checker description)
  (with-slots (pane item-list)
    item
    (unless checker (setq checker #'always-ok-p))
    (setq item-list (list* (make-instance (slot-item-class slot-object item)
					  ':parent item ':pane pane
					  ':object slot-object)
			   (cond (writer
				  (list
				   (make-instance 'cell-item
						  ':parent item ':pane pane
						  ':object-view object-view
						  ':cell-description description
						  ':cell-reader reader
						  ':cell-writer writer
						  ':value-checker checker)))
				 (reader
				  (list
				   (make-instance 'read-only-cell-item
						  ':parent item ':pane pane
						  ':object-view object-view
						  ':cell-description description
						  ':cell-reader reader))))))))

(defmethod print-object ((instance property-value-item) stream)
  (with-slots (item-list)
    instance
    (if (and (slot-boundp instance 'inspecter) item-list)
	(let ((*print-pretty* nil))
	  (pcl::printing-random-thing (instance stream)
             (format stream "~A ~S"
		     (class-name (class-of instance))
		     (item-documentation (second item-list)))))
	(call-next-method))))

(defclass pv-operation-item (operation-item)
  ()
  (:default-initargs :border-width 0))

(defclass simple-slot-item (text-item)
  ((object :initform nil :initarg :object :accessor item-object))
  (:default-initargs :size-within-parent :ask))

(defmethod slot-item-class ((object string) (pvi property-value-item))
  'simple-slot-item)

(defvar *slot-item-width* '(17 #\o))

(defmethod item-desired-size ((item simple-slot-item) direction)
  (case direction
    (:horizontal (etypecase *slot-item-width*
		   (integer *slot-item-width*)
		   (string (string-width item *slot-item-width*))
		   (cons (let* ((count (car *slot-item-width*))
				(wspec (or (cadr *slot-item-width*) #\o))
				(w (etypecase wspec
				     (character (char-width item wspec))
				     (string (string-width item wspec)))))
			   (* count w)))))
    (:vertical (font-height item))))

(defmethod compute-item-text ((item simple-slot-item))
  (let ((object (item-object item)))
    (if (stringp object)
	object
	(inspecter-print-object object))))

(defmethod item-documentation ((item simple-slot-item))
  (let ((object (item-object item)))
    (if (stringp object)
	object
	(inspecter-print-object object))))

(defclass item-containing-object (object-item)
  ((object :initform nil :initarg :object :reader item-object)
   (object-view :initform nil :initarg :object-view :reader item-object-view)))

(defmethod initialize-instance :after ((item item-containing-object) &key)
  (with-slots (object object-view)
    item
    (unless object-view
      (setq object-view object))))

(defclass slot-item (simple-slot-item item-containing-object)
  ())

(defmethod object-view-for-view-class (object-view-class)
  (pcl::class-prototype object-view-class))

(defmethod next-object-view (object object-view &optional this-class-p)
  (and this-class-p object))

(defun make-reader-pvi (parent so view reader desc &rest format-args)
  (when (and view (symbolp view) (not (eq view 's)))
    (setq view (object-view-for-view-class (find-class view))))
  (make-instance 'property-value-item
		 ':parent parent ':pane (item-pane parent)
		 ':slot-object so ':object-view view
		 ':reader reader
		 ':description (let ((*print-pretty* nil))
				 (apply #'format nil desc format-args))))

(defun make-writer-pvi (parent so view reader writer checker desc &rest format-args)
  (when (and view (symbolp view) (not (eq view 's)))
    (setq view (object-view-for-view-class (find-class view))))
  (make-instance 'property-value-item
		 ':parent parent ':pane (item-pane parent)
		 ':slot-object so ':object-view view
		 ':reader reader ':writer writer ':checker checker
		 ':description (let ((*print-pretty* nil))
				 (apply #'format nil desc format-args))))

(defun vf (value)
  #'(lambda (object)
      (declare (ignore object))
      value))

#+cmu
(defun get-closure-env (obj &optional fin-p)
  (flet ((closure-env-value (i)
	   (let ((v (kernel:%closure-index-ref obj i)))
	     (if (di::indirect-value-cell-p v)
		 (system:%primitive c::value-cell-ref v)
		 v))))
    (let* ((len (if fin-p
		    (let ((len pcl::fin-name-slot))
		      (loop (when (or (zerop len)
				      (not (null (closure-env-value (1- len)))))
			      (return len))
			    (decf len)))
		    (- (kernel:get-closure-length obj) (1- vm:closure-info-offset))))
	   (list (make-list len)))
      (dotimes (i len list)
	(setf (nth i list) (closure-env-value i))))))

#+cmu
(defun get-closure-item-list (object parent &optional fin-p)
  (let ((type (kernel:get-type object)))
    (when (or (= type vm:closure-header-type)
	      (= type vm:funcallable-instance-header-type))
      (list (make-reader-pvi parent "Function" nil #'kernel:%closure-function
			     "Function of function ~S" object)
	    (make-reader-pvi parent "Environment" nil 
			     #'(lambda (obj)
				 (get-closure-env obj fin-p))
			     "Environment of function ~S" object)))))

(defmethod fixed-item-list (object object-view parent)
  (declare (ignore object-view))
  (typecase object
    #+cmu
    (function
     (nconc (when (= (kernel:get-type object) vm:function-header-type)
	      (list (make-reader-pvi parent "Arglist" nil 
				     #'kernel:%function-header-arglist
				     "Arglist of function ~S" object)
		    (make-reader-pvi parent "Header" nil #'di::function-code-header
				     "Header of function ~S" object)))
	    (get-closure-item-list object parent)))
    #+cmu
    (lisp::code-component
     (list (make-reader-pvi parent "Debug Info" nil 
			    #'(lambda (obj) (di::code-debug-info obj))
			    "Debugging Information")))
    (t (cond #+akcl
	     ((pcl::cclosurep object)
	      (list (make-reader-pvi parent "Environment" nil
				     #'pcl::%cclosure-env
				     "Environment of function ~S" object)))))))

(defmethod variable-items-count-function (object object-view)
  (declare (ignore object object-view))
  nil)

(defmethod fixed-item-list ((object symbol) (object-view symbol) parent)
  #+lucid (declare (special lucid::*defstructs*))
  (let ((class (find-class object nil))
	(setf (when (and object (not (keywordp object)))
		(or (let ((name `(setf ,object)))
		      (and (pcl::gboundp name)
			   (pcl::gdefinition name)))
		    (pcl::setfboundp object))))
	(struct-def #-(or cmu lucid) nil 
		    #+lucid (gethash object lucid::*defstructs*)
		    #+cmu (ext:info type defined-structure-info object)))
    (nconc (list (make-reader-pvi parent "Name" nil #'symbol-name 
				  "Name of symbol ~S" object)
		 (make-writer-pvi parent "Value" nil 
				  #'(lambda (symbol)
				      (if (boundp symbol)
					  (symbol-value symbol)
					  "***UNBOUND***"))
				  #'(lambda (new-value symbol)
				      (setf (symbol-value symbol) new-value))
				  #'always-ok-p
				  "Value of symbol ~S" object)
		 (make-reader-pvi parent "Function" nil
				  #'(lambda (symbol)
				      (if (fboundp symbol)
					  (symbol-function symbol)
					  "***UNBOUND***"))
				  "Function binding of symbol ~S" object)
		 (make-reader-pvi parent "Plist" nil
				  #'symbol-plist
				  "Property list of symbol ~S" object)
		 (make-reader-pvi parent "Package" nil
				  #'symbol-package
				  "Package of symbol ~S" object))
	   (when (or class (and setf (functionp setf)) struct-def)
	     (list (make-instance 'property-value-item 
				  ':parent parent ':pane (item-pane parent))))
	   (when class
	     (list (make-reader-pvi parent "Class" nil (vf class)
				    "Class named ~S" object)))
	   (when (and setf (functionp setf))
	     (list (make-reader-pvi parent "Setf" nil (vf setf)
				    "Setf Function for ~S" object)))
	   (when struct-def
	     (list (make-reader-pvi parent "Structure Definition" nil (vf struct-def)
				    "Information about Defstruct ~S" object))))))

(defun list-length* (list)
  (do ((n 0 (+ n 2))
       (y list (cddr y))
       (z list (cdr z)))
      (())
    (declare (fixnum n) (list y z))
    (when (atom y) (return (values n y)))
    (when (atom (cdr y)) (return (values (+ n 1) (cdr y))))
    (when (and (eq y z) (> n 0)) (return (values (ash n -1) z)))))

(defun length* (seq)
  (if (listp seq)
      (list-length* seq)
      (values (length seq) nil)))

(defmethod fixed-item-list ((object sequence) (object-view sequence) parent)
  (list (make-reader-pvi parent "Length" nil #'length* 
			 "Length of sequence ~S" object)))

(defmethod variable-items-count-function ((object sequence) (object-view sequence))
  #'(lambda () 
      (multiple-value-bind (len last-cdr)
	  (length* object)
	(if last-cdr (1+ len) len))))

(defmethod variable-item-creator-function ((object sequence) (object-view sequence)
					   parent)
  #'(lambda (index)
      (multiple-value-bind (len last-cdr)
	  (length* object)
	(let ((last-p (= index len)))
	  (make-writer-pvi parent 
			   (if last-p
			       (format nil "~D cdr" index)
			       (format nil "~D" index))
			   nil
			   #'(lambda (object)
			       (if (listp object)
				   (let* ((n (if last-p (1- index) index))
					  (cons (nthcdr n object)))
				     (if last-p
					 (cdr cons)
					 (car cons)))
				   (aref object index)))
			   #'(lambda (new-value object)
			       (if (listp object)
				   (let* ((n (if last-p (1- index) index))
					  (cons (nthcdr n object)))
				     (if last-p
					 (setf (cdr cons) new-value)
					 (setf (car cons) new-value)))
				   (setf (aref object index) new-value)))
			   #'always-ok-p
			   (let ((*print-pretty* nil))
			     (format nil "Index ~D of ~A ~S" index 
				     (if (vectorp object) "vector" "list")
				     object)))))))

(defclass slotd-item (slot-item)
  ())

(defmethod compute-item-text ((item slotd-item))
  (symbol-name (pcl::slot-definition-name (item-object item))))

(defclass object-slot-item (property-value-item)
  ((slot-definition :initarg :slot-definition)))

(defmethod slot-item-class ((object pcl::slot-definition) (pvi object-slot-item))
  'slotd-item)

(defmethod initialize-instance :after ((item object-slot-item) &key)
  (with-slots (pane slot-definition)
    item
    (let* ((reader 
	    #'(lambda (object)
		(let ((class (class-of object)))
		  (if (pcl::slot-boundp-using-class class object slot-definition)
		      (pcl::slot-value-using-class class object slot-definition)
		      '***UNBOUND***))))
	   (writer
	    #'(lambda (new-value object)
		(setf (pcl::slot-value-using-class
		       (class-of object) object slot-definition)
		      new-value)))
	   (*print-pretty* nil)
	   (description (format nil "Slot ~S of object ~S"
				(pcl::slot-definition-name slot-definition)
				(pane-object pane))))
      (make-internal-items item slot-definition nil 
			   reader writer #'always-ok-p description))))

(defmethod object-view-for-view-class ((object-view-class pcl::slot-class))
  (pcl::class-prototype object-view-class))

(defmethod next-object-view (object (object-view pcl::slot-object)
				    &optional this-class-p)
  (and this-class-p (pcl::class-prototype (find-class 'pcl::slot-object))))

(defmethod fixed-item-list ((object pcl::slot-object) (object-view pcl::slot-object)
			    parent)
  (nconc (list (make-reader-pvi parent "Class" nil #'class-of "Class of object ~S"
				object))
	 #+cmu
	 (when (pcl::funcallable-instance-p object)
	   (list* (make-reader-pvi parent "Name" nil #'pcl::funcallable-instance-name
				   "Name of funcallable-instance ~S" object)
		  (get-closure-item-list object parent t)))))  

(defmethod variable-items-count-function ((object pcl::slot-object)
					  (object-view pcl::slot-object))
  #'(lambda ()
      (length (pcl::class-slots (class-of object)))))

(defmethod variable-item-creator-function ((object pcl::slot-object)
					    (object-view pcl::slot-object) parent)
  #'(lambda (index)
      (let ((slotd (elt (pcl::class-slots (class-of object)) index)))
	(make-instance 'object-slot-item
		       ':parent parent ':pane (item-pane parent)
		       ':slot-definition slotd))))

(defclass hash-table-view ()
  ((keys :initform (make-array 0 :fill-pointer 0 :adjustable t))
   (values :initform (make-array 0 :fill-pointer 0 :adjustable t))))

(defmethod object-view-for-view-class ((class (eql (find-class 'hash-table-view))))
  (make-instance 'hash-table-view))

(declare-next-view t hash-table-view)

(defclass hash-table-entry-item (property-value-item)
  ((index :initarg :index)))

(defmethod slot-item-class ((object t) (pvi hash-table-entry-item))
  'slot-item)

(defmethod initialize-instance :after ((item hash-table-entry-item) &key)
  (with-slots (pane index)
    item
    (let* ((view (pane-object-view pane))
	   (keys (slot-value view 'keys))
	   (values (slot-value view 'values))
	   (reader 
	    #'(lambda (object)
		(aref values index)))
	   (writer
	    #'(lambda (new-value object)
		(setf (gethash object (aref keys index)) new-value)
		(setf (aref values index) new-value)))
	   (*print-pretty* nil)
	   (description (format nil "Value of key ~S in hash-table ~S"
				(aref keys index) (pane-object pane))))
      (make-internal-items item (aref keys index) nil 
			   reader writer #'always-ok-p description))))


(defmethod fixed-item-list ((object t) (object-view hash-table-view)
			    parent)
  (nconc (call-next-method)
	 (list (make-reader-pvi parent "Count" nil #'hash-table-count
				"The number of entries in ~S" object))))

(defmethod variable-items-count-function ((object t)
					  (object-view hash-table-view))
  (with-slots (keys values)
    object-view
    #'(lambda ()
	(let ((count (hash-table-count object)))
	  (if (> count (array-dimension keys 0))
	      (setq keys (adjust-array keys count :fill-pointer 0)
		    values (adjust-array values count :fill-pointer 0))
	      (setf (fill-pointer keys) 0
		    (fill-pointer values) 0))
	  (let ((list nil))
	    (maphash #'(lambda (key value)
			 (push (list (inspecter-print-object key) key value) list))
		     object)
	    (setq list (sort list #'string< :key #'car))
	    (dolist (e list)
	      (vector-push (second e) keys)
	      (vector-push (third e) values)))
	  (fill-pointer keys)))))

(defmethod variable-item-creator-function ((object t)
					   (object-view hash-table-view)
					   parent)
  (with-slots (keys values)
    object-view
    #'(lambda (index)
	(make-instance 'hash-table-entry-item 
		       ':parent parent ':pane (item-pane parent)
		       :index index))))
