(in-package :cl-user)

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

 Read-eval-inspect

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.

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

This does two things:  

1) results from the Listener get brought into a special inspector window (you
can control what classes of objects get this treatment). 

2) The variable % will always be equal to the object in the topmost inspector.

Interface:
- There is a checked menu item, Auto Inspect, added to the Eval menu.
- see the variables  *readloop-inspector-yes-classes* and *readloop-inspector-no-classes*
to control what types of object get displayed.

Todo:

- if item is already in an inspect window, just update it and bring it front
- turn off during buffer evals

History:
7/6/97 12:42   added *resample-on-select* variable

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

(defmethod inspect-new-thing ((w inspector::inspector-window) thing)
  (catch :cancel
    (inspector::install-new-inspector (view-container (inspector::inspector-view w) )
                                      (inspector::make-inspector thing))
    (set-window-layer w (1+ *windoid-count*))))
   
(defvar *readloop-inspector* nil)

;;; Access through this function to ensure the inspect window remains valid
(defun readloop-inspector ()
  (if (and *readloop-inspector*
           (slot-value *readloop-inspector* 'wptr))
    *readloop-inspector*
    (multiple-value-bind (pos size) (inspector-position-and-size)
      (setq *readloop-inspector* 
            (make-instance 'inspector::inspector-window 
                           :inspector (make-instance 'inspector::usual-inspector
                                                     :object "Welcome to read-eval-inspect")
                           :view-position pos
                           :view-size size))
      ;; Init arg doesn't work.
      (set-view-size *readloop-inspector* size)
      *readloop-inspector*)))

(defun inspector-position-and-size ()
  (let* ((l-position (view-position *top-listener*))
         (l-size (view-size *top-listener*)))
    (values (+ l-position (point-h l-size))
            (make-point (- *screen-width* (+ (point-h l-position) (point-h l-size)))
                        (point-v l-size)))))

;;; Refinement - only inspect some classes

;;; To be displayed, an object must be a subclass of some yes class, and also not be
;;; a subclass of all no classes.  Got that?  If the yes-class list is nil all checks
;;; are skipped.

;;; The theory behind these values is we want to see anything with structure not obvious from 
;;; its printed representation, but not every method definition because there are a lot of them and 
;;; they usually aren't interesting.
(defparameter *readloop-inspector-yes-classes* '(standard-object structure macptr cons array))
(defparameter *readloop-inspector-no-classes* '(standard-method string))

;;; Menu control

(defvar *readloop-inspector-on* t)

(defvar *readloop-inspect-menu-item* 
  (let ((it (make-instance 'menu-item
                           :menu-item-title "Auto Inspect"
                           :menu-item-action 'readloop-inspect-toggle)))
    (add-menu-items *eval-menu*
                    (make-instance 'menu-item :menu-item-title "-" :disabled t) 
                    it)
    (set-menu-item-check-mark it *readloop-inspector-on*)
    it))

(defun readloop-inspect-toggle ()
  (setq *readloop-inspector-on* (not *readloop-inspector-on*))
  (set-menu-item-check-mark *readloop-inspect-menu-item* *readloop-inspector-on*))


(defun maybe-inspect-new-thing (thing)
  (when (and *readloop-inspector-on*
             (and (or (null *readloop-inspector-yes-classes*)
                      ;; I wonder if this is actually guaranteed valid in CL...
                      (find thing *readloop-inspector-yes-classes* :test #'typep))
                  (or (null *readloop-inspector-no-classes*)
                      (not (find thing *readloop-inspector-no-classes* :test #'typep)))))
    (inspect-new-thing (readloop-inspector) thing)))

;;; Perhaps this could use evalhook instead of relying on an unadvertised function.
(ccl:advise ccl::toplevel-eval
             (progn
               (without-interrupts
                (maybe-inspect-new-thing (caar values))))
             :when :after :name :read-eval-inspect)

;;; % feature
;;; separable from read-eval-inspect, actually
(defvar ccl::% nil "The value in the top inspect window.")

(export 'ccl::% :ccl)

(defvar *resample-on-select* t)

(defmethod window-select :after ((w inspector::inspector-window))
  (when *resample-on-select*
    (inspector::resample w))
  (setq ccl::% (inspector::inspector-object w)))

(advise inspector::push-inspector-history 
        (setq ccl::% (top-inspect-form))
        :when :after :name set-%)

;;; First impressions are so important
(eval-when (eval load)
  (setq ccl::% (top-inspect-form)))

;;; new:  update inspect history automatically
(advise inspector::push-inspector-history 
        (let ((ihw (find-window "inspector history")))
          (when ihw
            (inspector::resample ihw)))
        :when :after :name update-history-window)

;;; just like the system definition, except we return nil instead of the new window (original
;;; behavior is confusing).  The only time this ought to be used is for objects that don't usually
;;; autoinspect.
(defun inspector::inspect (object)
  (inspector::inspect-object object)
  nil)

(provide :read-eval-inspect)