Browse code
Simple CLIM browser for CLOS classes
Ed Langley authored on 28/01/2019 11:03:05Showing 1 changed files
| 1 | 1 |
new file mode 100644 |
| ... | ... |
@@ -0,0 +1,157 @@ |
| 1 |
+(defpackage :clos-browser |
|
| 2 |
+ (:use :clim-lisp :clim) |
|
| 3 |
+ (:export |
|
| 4 |
+ #:main)) |
|
| 5 |
+(in-package :clos-browser) |
|
| 6 |
+ |
|
| 7 |
+(define-application-frame class-browser () |
|
| 8 |
+ ((classes :initarg :classes :reader classes) |
|
| 9 |
+ (visible-classes :initform nil :accessor visible-classes) |
|
| 10 |
+ (current-class :initform nil :accessor current-class)) |
|
| 11 |
+ (:panes (classes :application |
|
| 12 |
+ :incremental-redisplay t |
|
| 13 |
+ :display-function 'display-classes |
|
| 14 |
+ :double-buffering t) |
|
| 15 |
+ (methods :application |
|
| 16 |
+ :incremental-redisplay t |
|
| 17 |
+ :display-function 'display-current-class |
|
| 18 |
+ :scroll-bars :both) |
|
| 19 |
+ (int :interactor |
|
| 20 |
+ :scroll-bars :both)) |
|
| 21 |
+ (:pointer-documentation t) |
|
| 22 |
+ (:layouts (default (vertically () |
|
| 23 |
+ (horizontally () |
|
| 24 |
+ classes methods) |
|
| 25 |
+ int)) |
|
| 26 |
+ (maximize-int (vertically () |
|
| 27 |
+ int))) |
|
| 28 |
+ (:default-initargs |
|
| 29 |
+ :classes (let ((classes ())) |
|
| 30 |
+ (do-all-symbols (s (sort (remove-duplicates classes) |
|
| 31 |
+ #'string< |
|
| 32 |
+ :key #'class-name)) |
|
| 33 |
+ (alexandria:when-let ((class (find-class s nil))) |
|
| 34 |
+ (push class classes)))))) |
|
| 35 |
+ |
|
| 36 |
+(defun reset-application-frame () |
|
| 37 |
+ (setf (visible-classes clim:*application-frame*) nil |
|
| 38 |
+ (current-class clim:*application-frame*) nil |
|
| 39 |
+ (slot-value clim:*application-frame* 'classes) |
|
| 40 |
+ (let ((classes ())) |
|
| 41 |
+ (do-all-symbols (s (sort (remove-duplicates classes) |
|
| 42 |
+ #'string< |
|
| 43 |
+ :key #'class-name)) |
|
| 44 |
+ (alexandria:when-let ((class (find-class s nil))) |
|
| 45 |
+ (push class classes)))))) |
|
| 46 |
+ |
|
| 47 |
+(define-presentation-type clos-class ()) |
|
| 48 |
+(define-presentation-method present (object (type clos-class) stream view &key) |
|
| 49 |
+ (declare (ignore view)) |
|
| 50 |
+ (format stream "#<CLOS Class: ~a>" |
|
| 51 |
+ (class-name object))) |
|
| 52 |
+ |
|
| 53 |
+(defun display-classes (frame pane) |
|
| 54 |
+ (updating-output (pane :unique-id (or (visible-classes frame) |
|
| 55 |
+ (classes frame)) |
|
| 56 |
+ :id-test 'eq) |
|
| 57 |
+ (loop for class in (or (visible-classes frame) |
|
| 58 |
+ (classes frame)) |
|
| 59 |
+ do (updating-output (pane :unique-id (sxhash class) |
|
| 60 |
+ :id-test 'eql |
|
| 61 |
+ :cache-value class |
|
| 62 |
+ :cache-test 'eql) |
|
| 63 |
+ (with-output-as-presentation (pane class 'clos-class) |
|
| 64 |
+ (format pane "~&~a~%" (class-name class))))))) |
|
| 65 |
+ |
|
| 66 |
+(defun display-current-class (frame pane) |
|
| 67 |
+ (updating-output (pane :unique-id (current-class frame) |
|
| 68 |
+ :id-test 'eq) |
|
| 69 |
+ (when (current-class frame) |
|
| 70 |
+ (format-graph-from-roots (list (current-class frame)) |
|
| 71 |
+ (lambda (c stream) |
|
| 72 |
+ (present c 'clos-class :stream stream)) |
|
| 73 |
+ (lambda (c) |
|
| 74 |
+ (closer-mop:class-direct-superclasses c)) |
|
| 75 |
+ :stream pane |
|
| 76 |
+ :duplicate-test 'eq |
|
| 77 |
+ :graph-type :dag |
|
| 78 |
+ :orientation :vertical |
|
| 79 |
+ :merge-duplicates t |
|
| 80 |
+ :arc-drawer (lambda (stream foo bar x1 y1 x2 y2) |
|
| 81 |
+ (updating-output (pane :unique-id (list foo bar) |
|
| 82 |
+ :id-test 'equal) |
|
| 83 |
+ (draw-arrow* stream x1 y1 x2 y2 |
|
| 84 |
+ :ink (make-contrasting-inks 1 0)))))))) |
|
| 85 |
+ |
|
| 86 |
+(define-class-browser-command (com-pick-class :name t :menu t) ((the-class clos-class :gesture :select)) |
|
| 87 |
+ (setf (current-class *application-frame*) the-class)) |
|
| 88 |
+ |
|
| 89 |
+(define-class-browser-command (com-current-class :name t) () |
|
| 90 |
+ (let ((current-class (current-class clim:*application-frame*))) |
|
| 91 |
+ (with-output-as-presentation (*query-io* current-class 'clos-class :single-box t) |
|
| 92 |
+ (format t "~&#<CLOS Class: ~s>~%" (class-name current-class))))) |
|
| 93 |
+ |
|
| 94 |
+ |
|
| 95 |
+(define-class-browser-command (com-refresh-classes :name t :menu t) () |
|
| 96 |
+ (reset-application-frame)) |
|
| 97 |
+ |
|
| 98 |
+(define-class-browser-command (com-filter-classes :name t :menu t) ((pattern string)) |
|
| 99 |
+ (let ((scanner (cl-ppcre:create-scanner pattern :case-insensitive-mode t))) |
|
| 100 |
+ (setf (visible-classes *application-frame*) |
|
| 101 |
+ (remove-if-not (lambda (_) |
|
| 102 |
+ (cl-ppcre:scan scanner |
|
| 103 |
+ (princ-to-string _))) |
|
| 104 |
+ (classes *application-frame*) |
|
| 105 |
+ :key 'class-name)))) |
|
| 106 |
+ |
|
| 107 |
+(define-class-browser-command (com-show-hierarchy :name t) ((the-class clos-class)) |
|
| 108 |
+ (format-graph-from-roots (list the-class) |
|
| 109 |
+ (lambda (c stream) |
|
| 110 |
+ (present c 'clos-class :stream stream)) |
|
| 111 |
+ (lambda (c) |
|
| 112 |
+ (closer-mop:class-direct-superclasses c)) |
|
| 113 |
+ :stream *query-io* |
|
| 114 |
+ :duplicate-test 'eq |
|
| 115 |
+ :graph-type :tree |
|
| 116 |
+ :merge-duplicates t |
|
| 117 |
+ :arc-drawer (lambda (stream foo bar x1 y1 x2 y2) |
|
| 118 |
+ (declare (ignore foo bar)) |
|
| 119 |
+ (draw-arrow* stream x1 y1 x2 y2 |
|
| 120 |
+ :ink (make-contrasting-inks 1 0))))) |
|
| 121 |
+ |
|
| 122 |
+(define-class-browser-command (com-show-subclasses :name t) ((the-class clos-class)) |
|
| 123 |
+ (format-graph-from-roots (list the-class) |
|
| 124 |
+ (lambda (c stream) |
|
| 125 |
+ (present c 'clos-class :stream stream)) |
|
| 126 |
+ (lambda (c) |
|
| 127 |
+ (closer-mop:class-direct-subclasses c)) |
|
| 128 |
+ :stream *query-io* |
|
| 129 |
+ :duplicate-test 'eq |
|
| 130 |
+ :graph-type :tree |
|
| 131 |
+ :merge-duplicates t |
|
| 132 |
+ :arc-drawer (lambda (stream foo bar x1 y1 x2 y2) |
|
| 133 |
+ (declare (ignore foo bar)) |
|
| 134 |
+ (draw-arrow* stream x1 y1 x2 y2 |
|
| 135 |
+ :ink (make-contrasting-inks 1 0))))) |
|
| 136 |
+ |
|
| 137 |
+(define-class-browser-command (com-maximize-int :name t) () |
|
| 138 |
+ (let ((old-view (clim:frame-current-layout clim:*application-frame*))) |
|
| 139 |
+ (setf (clim:frame-current-layout clim:*application-frame*) |
|
| 140 |
+ (case old-view |
|
| 141 |
+ ('default 'maximize-int)
|
|
| 142 |
+ (t 'default))))) |
|
| 143 |
+ |
|
| 144 |
+(define-class-browser-command (com-exit :name "Quit" |
|
| 145 |
+ :command-table application-commands |
|
| 146 |
+ :menu t |
|
| 147 |
+ :provide-output-destination-keyword nil) |
|
| 148 |
+ () |
|
| 149 |
+ (frame-exit *application-frame*)) |
|
| 150 |
+ |
|
| 151 |
+(defvar *proc*) |
|
| 152 |
+(defun %main () |
|
| 153 |
+ (clim:run-frame-top-level |
|
| 154 |
+ (clim:make-application-frame 'class-browser))) |
|
| 155 |
+ |
|
| 156 |
+(defun main () |
|
| 157 |
+ (setf *proc* (bt:make-thread (lambda () (%main))))) |