clim-objc-browser.lisp

(defpackage :clim-objc-browser
  (:use :clim-lisp :clim))
(in-package :clim-objc-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
                   #+nil(:double-buffering t)
                   )
          (methods :application
                   :incremental-redisplay t
                   :display-function 'display-methods)
          (int :interactor))
  (:pointer-documentation t)
  (:layouts (default (vertically ()
                       (horizontally ()
                         classes methods)
                       int)))
  (:default-initargs
      :classes (sort (remove-if (serapeum:op
                                  (alexandria:starts-with #\_
                                                          (objc-runtime::objc-class-get-name _)))
                                (objc-runtime::get-classes))
                     #'string-lessp
                     :key 'objc-runtime::objc-class-get-name)))

(defun reset-application-frame ()
  (setf (visible-classes clim:*application-frame*) nil
        (current-class clim:*application-frame*) nil
        (slot-value clim:*application-frame* 'classes)
        (sort (remove-if (serapeum:op (alexandria:starts-with #\_
                                                              (objc-runtime::objc-class-get-name _)))
                         (objc-runtime::get-classes))
              #'string-lessp
              :key 'objc-runtime::objc-class-get-name)))

(define-presentation-type objc-class ())
(define-presentation-method present (object (type objc-class) stream view &key)
  (declare (ignore view))
  (format stream "#[OBJC Class: ~a]"
          (objc-runtime::objc-class-get-name object)))

(define-presentation-type objc-method ())
(define-presentation-method present (object (type objc-method) stream view &key)
  (declare (ignore view))
  (format stream "@(~a)"
          (objc-runtime::get-method-name object)))

(define-presentation-translator string-to-objc-class (string objc-class class-browser
                                                             :tester ((inp) (objc-runtime:ensure-class inp))
                                                             :tester-definitive t)
    (inp)
  (format *terminal-io* "~&translating ~s to an objc-class" inp)
  (objc-runtime:ensure-class inp))

(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 (cffi:pointer-address class)
                                :id-test 'eql
                                :cache-value class
                                :cache-test 'eql)
           (with-output-as-presentation (pane class 'objc-class)
             (format pane "~&   ~a~%" (objc-runtime::objc-class-get-name class)))))))

(defun display-methods (frame pane)
  (updating-output (pane :unique-id (current-class frame)
                         :id-test 'eq)
    (when (current-class frame)
      (loop for method in (sort (objc-runtime::get-methods (current-class frame))
                                'string<
                                :key 'objc-runtime::get-method-name)
         do
           (with-output-as-presentation (pane method 'objc-method)
             (format pane "   Method: ~a~%" (objc-runtime::get-method-name method)))))))

(define-class-browser-command (com-get-methods :name t :menu t) ((the-class objc-class :gesture :select))
  (if (cffi:pointerp the-class)
      (setf (current-class *application-frame*) the-class)
      (format *terminal-io* "~&The value ~s is not a pointer to a class, but a ~s" the-class (type-of the-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) ((prefix string))
  (setf (visible-classes *application-frame*)
        (remove-if-not (serapeum:op
                         (alexandria:starts-with-subseq prefix _ :test #'char-equal))
                       (classes *application-frame*)
                       :key 'objc-runtime::objc-class-get-name)))

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