clos-browser.lisp

(defpackage :clos-browser
  (:use :clim-lisp :clim)
  (:export
   #:main))
(in-package :clos-browser)

(define-application-frame class-browser ()
  ((classes :initarg :classes :reader classes)
   (visible-classes :initform nil :accessor visible-classes)
   (current-class :initform nil :accessor current-class))
  (:panes (classes :application
                   :incremental-redisplay t
                   :display-function 'display-classes
                   :double-buffering t)
          (methods :application
                   :incremental-redisplay t
                   :display-function 'display-current-class
                   :scroll-bars :both)
          (int :interactor
               :scroll-bars :both))
  (:pointer-documentation t)
  (:layouts (default (vertically ()
                       (horizontally ()
                         classes methods)
                       int))
            (maximize-int (vertically ()
                            int)))
  (:default-initargs
      :classes (let ((classes ()))
                 (do-all-symbols (s (sort (remove-duplicates classes)
                                          #'string<
                                          :key #'class-name))
                   (alexandria:when-let ((class (find-class s nil)))
                     (push class classes))))))

(defun reset-application-frame ()
  (setf (visible-classes clim:*application-frame*) nil
        (current-class clim:*application-frame*) nil
        (slot-value clim:*application-frame* 'classes)
        (let ((classes ()))
          (do-all-symbols (s (sort (remove-duplicates classes)
                                   #'string<
                                   :key #'class-name))
            (alexandria:when-let ((class (find-class s nil)))
              (push class classes))))))

(define-presentation-type clos-class ())
(define-presentation-method present (object (type clos-class) stream view &key)
  (declare (ignore view))
  (format stream "#<CLOS Class: ~a>"
          (class-name object)))

(defun display-classes (frame pane)
  (updating-output (pane :unique-id (or (visible-classes frame)
                                        (classes frame))
                         :id-test 'eq)
    (loop for class in (or (visible-classes frame)
                           (classes frame))
       do (updating-output (pane :unique-id (sxhash class)
                                 :id-test 'eql
                                 :cache-value class
                                 :cache-test 'eql)
            (with-output-as-presentation (pane class 'clos-class)
              (format pane "~&~a~%" (class-name class)))))))

(defun display-current-class (frame pane)
  (updating-output (pane :unique-id (current-class frame)
                         :id-test 'eq)
    (when (current-class frame)
      (format-graph-from-roots (list (current-class frame))
                               (lambda (c stream)
                                 (present c 'clos-class :stream stream))
                               (lambda (c)
                                 (closer-mop:class-direct-superclasses c))
                               :stream pane
                               :duplicate-test 'eq
                               :graph-type :tree
                               :merge-duplicates t
                               :arc-drawer (lambda (stream foo bar x1 y1 x2 y2)
                                             (declare (ignore foo bar))
                                             (draw-arrow* stream x1 y1 x2 y2
                                                          :ink clim:+green+))))))

(define-class-browser-command (com-pick-class :name t :menu t) ((the-class clos-class :gesture :select))
  (setf (current-class *application-frame*) the-class))

(define-class-browser-command (com-current-class :name t) ()
  (let ((current-class (current-class clim:*application-frame*)))
    (with-output-as-presentation (*query-io* current-class 'clos-class :single-box t)
      (format t "~&#<CLOS Class: ~s>~%" (class-name current-class)))))


(define-class-browser-command (com-refresh-classes :name t :menu t) ()
  (reset-application-frame))

(define-class-browser-command (com-filter-classes :name t :menu t) ((pattern string))
  (let ((scanner (cl-ppcre:create-scanner pattern :case-insensitive-mode t)))
    (setf (visible-classes *application-frame*)
          (remove-if-not (lambda (_)
                           (cl-ppcre:scan scanner
                                          (princ-to-string _)))
                         (classes *application-frame*)
                         :key 'class-name))))

(define-class-browser-command (com-show-hierarchy :name t) ((the-class clos-class))
  (format-graph-from-roots (list the-class)
                           (lambda (c stream)
                             (present c 'clos-class :stream stream))
                           (lambda (c)
                             (closer-mop:class-direct-superclasses c))
                           :stream *query-io*
                           :duplicate-test 'eq
                           :graph-type :tree
                           :merge-duplicates t
                           :arc-drawer (lambda (stream foo bar x1 y1 x2 y2)
                                         (declare (ignore foo bar))
                                         (draw-arrow* stream x1 y1 x2 y2
                                                      :ink clim:+green+))))

(define-class-browser-command (com-show-subclasses :name t) ((the-class clos-class))
  (format-graph-from-roots (list the-class)
                           (lambda (c stream)
                             (present c 'clos-class :stream stream))
                           (lambda (c)
                             (closer-mop:class-direct-subclasses c))
                           :stream *query-io*
                           :duplicate-test 'eq
                           :graph-type :tree
                           :merge-duplicates t
                           :arc-drawer (lambda (stream foo bar x1 y1 x2 y2)
                                         (declare (ignore foo bar))
                                         (draw-arrow* stream x1 y1 x2 y2
                                                      :ink clim:+green+))))

(define-class-browser-command (com-maximize-int :name t) ()
  (let ((old-view (clim:frame-current-layout clim:*application-frame*)))
    (setf (clim:frame-current-layout clim:*application-frame*)
          (case old-view
            ('default  'maximize-int)
            (t 'default)))))

(define-class-browser-command (com-exit :name "Quit"
			                                  :command-table application-commands
                                        :menu t
			                                  :provide-output-destination-keyword nil)
    ()
  (frame-exit *application-frame*))

(defvar *proc*)
(defun %main ()
  (clim:run-frame-top-level
   (clim:make-application-frame 'class-browser)))

(defun main ()
  (setf *proc* (bt:make-thread (lambda () (%main)))))