(in-package :inspector)

#| ######################################################################

 MCL Inspector extensions

Copyright © 1994-97 Michael Travers 

Permission is given to use and modify this code
as long as the copyright notice is preserved.

Send questions, comments, and fixes to mt@media.mit.edu.

-------------------------------------------------------------------------

 Extends the inspector to provide display of hash tables, class properties,
 pixmaps, adds a few commands for strings and pathnames.

 Requires: pixmap-utils (loaded on demand), mt-utils

 See also: read-eval-inspect

Todos:
- hash table inspector: sorting, and it would be nice if there was a way
  to inspect the keys as well as the values.
- display methods for slots of structures and objects (ie, control base
  of numbers)
- see file inspector todos below

History:  
6/24/95 14:51  Backtrace windows include process name 
7/10/95 22:02  Fix problem with inspecting a wildcarded pathname
8/22/95 23:32  leave out some stuff for MCL2
9/13/95 16:14  file info inspector
10/14/95 18:28 region inspect
11/7/95 12:45  pict inspect
5/13/97 17:23  inspect key command for ht inspector
7/6/97 11:06   cleanup for release
###################################################################### |#

;;; Fonts 

;(based on alanr's inspector-defaults.lisp)

(defvar *inspector-default-font-spec* '("geneva" 9))

(defclass inspector-window (undo-view-mixin window)
  ((selected-pane :initform nil :accessor selected-pane)
   (user-title :accessor user-title))
  (:default-initargs :window-title nil :view-font *inspector-default-font-spec*))

(defclass backtrace-view (view)
  ((info :initarg :info :accessor info))
  (:default-initargs :view-font *inspector-default-font-spec*))

;;; we have to reverse the font change for the process inspector, since it
;;; expects a fixed-width font. 
#+CCL-3
(defun ccl::inspect-processes ()
  (let* ((title "Processes")
         (w (find-window title 'inspector-window)))
    (flet ((get-process-list (&optional ignore)
             (declare (ignore ignore))
             (cons #.(format nil "Name~30tState~50tPriority~60tIdle~67t% Utilization")
                   (copy-list ccl::*all-processes*))))
      (if w
        (progn (window-select w) (resample w))
        (make-instance 'inspector-window
          :edit-value-button nil
          :view-font '("Monaco" 9)
          :inspector (make-instance 'processes-inspector
                       :window-title title
                       :object (get-process-list)
                       :print-function 'inspect-processes-print-function
                       :line-n-function #'(lambda (i n)
                                            (let ((o (inspector-object i)))
                                              (if (eql n 0)
                                                (values nil (elt o 0) '(:comment (:underline)))
                                                (values (elt o n) nil :static))))
                       :resample-function #'get-process-list
                       :replace-object-p nil
                       :setf-line-n-p nil))))))

;;; Pixmaps

;;; include a hook to RECORD-SPECIFIC-COMMANDS
(defmethod inspector-commands ((i record-inspector))
  (let ((macptr (inspector-object i)))
    `(("Choose different record type"
       ,#'(lambda ()
            (let ((record-type (choose-record-type macptr t)))
              (make-inspector-window
               (if record-type
                 (make-instance 'record-inspector 
                                :object macptr :record-type record-type)
                 (make-instance 'uvector-inspector :object macptr))))))
      ,@(record-specific-commands macptr (record-type i))
      ,@(macptr-commands macptr)
      ("Inspect as a MACPTR"
       ,#'(lambda () (make-inspector-window
                      (make-instance 'uvector-inspector :object macptr)))))))

;;; Just handles pixmaps now, but there is room for more.
;;; +++ yes, this should be data driven.
(defun record-specific-commands (record type)
  (case type
    (:pixmap `(("View the Pixmap" ,#'(lambda () 
                                       (require :pixmap-utils)
                                       (funcall 'inspect-pm record)))))
    (:picture `(("View the PICT" ,#'(lambda () 
                                       (require :pixmap-utils)
                                       (funcall 'inspect-pict record)))))
    (:region `(("View the Region" ,#'(lambda () 
                                       (inspect-region record)))))
    (t nil)))

(defclass region-inspect-window (window)
  ((region :initarg :region))
  )

(defmethod view-draw-contents ((w region-inspect-window))
  (with-slots (region) w
    (#_PaintRgn region)))

(defun inspect-region (region)
  (let* ((w (max 50 (mt:rref* region :region.rgnbbox.right)))
         (h (max 50 (mt:rref* region :region.rgnbbox.bottom))))
    (make-instance 'region-inspect-window
      :region region :view-size (make-point w h) :window-title (princ-to-string region))))


;;; Hash tables

;;; we have to copy the contents to avoid the table getting rearranged out from
;;; under us.

;;; sorting might be nice...

(defclass hash-table-inspector (inspector)
  ((ht-contents)))

(defmethod compute-line-count ((i hash-table-inspector))
  (with-slots (ht-contents object) i
    (setf ht-contents (ht-contents object))
    (+ 4 (length ht-contents))))

(defun ht-contents (ht)
  (let ((result nil))
    (maphash #'(lambda (key value)
                 (push (cons key value) result))
           ht)
    result))

#|
;;; Sorted output, experimental 
(defun universal-< (a b)
  (cond ((and (numberp a) (numberp b))
         (< a b))
        ((and (string a) (string b))
         (string-lessp (string a) (string b)))
        ((eq (type-of a) (type-of b))
         (< (sxhash a) (sxhash b)))
        (t (string-lessp (string (type-of a)) (string (type-of b))))))
             
(defun ht-contents (ht)
  (let ((result nil))
    (maphash #'(lambda (key value)
                 (push (cons key value) result))
           ht)
    (sort result #'universal-< :key #'car)))
|#

(defmethod line-n ((i hash-table-inspector) n)
  (let* ((hash-table (inspector-object i)))
    (cond ((eql 0 n) (values hash-table))
          ((eql 1 n) (values (hash-table-test hash-table) "Test: " :static))
          ((eql 2 n) (values (hash-table-count hash-table) "Count: " :static))
          ((eql 3 n) (values  (hash-table-size hash-table) "Size: " :static))
          (t (let ((item (nth (- n 4) (slot-value i 'ht-contents))))
               (values (cdr item) (car item) :colon))))))

(defmethod (setf line-n) (new-value (i hash-table-inspector) n)
  (with-slots (ht-contents object) i
    (if (eql n 0)
      (replace-object i new-value)
      (if (< n 4)
        (setf-line-n-out-of-range i n)
        (let ((item (nth (- n 4) ht-contents)))
          (setf (cdr item) new-value)
          (setf (gethash (car item) object) new-value)
          (resample-it))))))

(defmethod inspector-class ((obj hash-table))
  'hash-table-inspector)

(defmethod inspector-commands ((ht hash-table-inspector))
  (with-slots (ht-contents object) ht
    (let* ((view (inspector-view ht))
           (selection (selection view))
           (item (and selection
                      (>= selection 4)
                      (elt ht-contents (- selection 4)))))
      (when item
        `(("Inspect Key"
           ,#'(lambda () 
                (inspect (car item)))))))))


;;; CLOS class inspector and misc 

(require :clos-hacks)

(defmethod inspector-commands ((c class))
  `(("All Method Names"
     ,#'(lambda () (inspect (ccl::class-generic-function-names c))))
    ("All Methods"
     ,#'(lambda () (inspect (ccl::class-methods c))))
    ("Direct Methods"
     ,#'(lambda () (inspect (ccl::class-direct-methods c))))
    ("Superclasses"
     ,#'(lambda () (inspect (mt:superclasses c))))
    ("Direct Superclasses"
     ,#'(lambda () (inspect (class-direct-superclasses c))))
    ("Subclasses"
     ,#'(lambda () (inspect (mt:subclasses c))))
    ("Direct Subclasses"
     ,#'(lambda () (inspect (ccl::class-direct-subclasses c))))
    ("Initargs"
     ,#'(lambda () (inspect (ccl::class-make-instance-initargs c))))))

(defmethod inspector-commands ((m standard-method))
  `(,@(if (edit-definition-p m)
        `(("Edit Definition"
           ,#'(lambda () (edit-definition m)))))))

;;; Needed for the above to work
(defmethod inspector-commands ((i standard-object-inspector))
  (let ((*inspector* i))
    (inspector-commands (inspector-object i))))


;;; the following functions used to be in clos-hacks.lisp; I moved
;;; them here to make public release easier.

;;; This magic variable must be on to record class -> method relations (it's
;;; not retroactive).
(setq ccl::*maintain-class-direct-methods* t)

(defmethod ccl::class-methods ((c standard-class))
  (mt:mapappend #'ccl::class-direct-methods (mt:superclasses c)))

(defmethod ccl::class-generic-function-names ((c standard-class))
  (remove-duplicates (mapcar #'method-name (ccl::class-methods c))))

;;; this is a MOP function (missing in MCL right now)
(defmethod ccl::class-direct-methods ((c class))
  (mt:mapappend #'(lambda (x) (ccl::population-data x))
                (ccl::%class-direct-methods c)))

(defmethod ccl::class-direct-methods ((c (eql (find-class t))))
  nil)

;;; Strings and Pathnames

(defmethod inspector-commands ((s string))
  `(("Display in a Fred Window"
     ,#'(lambda () (let ((w (make-instance 'fred-window
                              :window-show nil
                              :wrap-p t
                              :scratch-p t)))
                     (stream-write-string w s 0 (length s))
                     (window-select w))))
    ("Open named file in Fred"
     ,#'(lambda () 
          (let ((file (ccl::find-file-methods s)))
            (if file 
              (ed file)
              (beep)))))
    ("File Info"
     ,#'(lambda () (inspect-file-info s)))
    ))

(defmethod inspector-commands ((s pathname))
  (if (ignore-errors (probe-file s))
    `(("Open named file in Fred"
       ,#'(lambda () (ed s)))
      ("File Info"
       ,#'(lambda () (inspect-file-info s)))
    )))


;;; File inspector (unfinished)

(defclass file-inspector (inspector)
  ())

(defmethod line-n ((i file-inspector) n)
  (let* ((f (inspector-object i))
         (directory? (directory-pathname-p f)))
    (case n
      (0 f)
      (1 (values (mt:date-time-string (file-create-date f)) "Created" :colon))
      (2 (values (mt:date-time-string (file-write-date f)) "Written" :colon))
      (3 (if directory?
           (values :n/a "Creator: " :static)
           (values (mac-file-creator f) "Creator" :colon)))
      (4 (if directory?
           (values :n/a "Type: " :static)
           (values (mac-file-type f) "Type" :colon)))
      (5 (values (make-pathname :directory
                                (if directory?
                                  (butlast (pathname-directory f))
                                  (pathname-directory f)))
                 "Directory: " :static)))))

(defmethod compute-line-count ((i file-inspector))
  6)

(defmethod (setf line-n) (new-value (i file-inspector) n)
  (with-slots (object) i
    (case n
      (0 (replace-object i new-value))
      (3 (set-mac-file-creator object new-value))
      (4 (set-mac-file-type object new-value)))))


(defun inspect-file-info (f)
  (if (ignore-errors (probe-file f))
    (make-inspector-window (make-instance 'file-inspector :object f))
    (error "~A is not a real file" f)))

(defvar *file-info-menu-item* (make-instance 'window-menu-item
                                :menu-item-title "File Info"
                                :menu-item-action 'window-file-info
                                :update-function 'file-info-item-update))

(defmethod window-file-info ((w fred-window))
  (inspect-file-info (window-filename w)))

(defun file-info-item-update (item)
  (let ((front-window (front-window)))
    (if (and front-window
             (method-exists-p 'window-file-info front-window)
             (window-filename front-window))
      (menu-item-enable item)
      (menu-item-disable item))))

(mt:add-menu-item-at *file-menu* *file-info-menu-item* 9)       

#|
More info
- files sizes (data and resource fork)
- version
- directory
  DONE (but goes through pathname...have to fix that up)
- locked bit etc

Hooks:
- pathname/string inspector

Commands: 
- delete
- rename
- edit in Fred
- directory (ie list files)
|#