From f3695923058ef5d253fc00844caa4df850641ace Mon Sep 17 00:00:00 2001 From: David Botton Date: Mon, 3 Jun 2024 20:03:30 -0400 Subject: [PATCH] Working CLOG Object Scope --- tools/clog-builder-probe.lisp | 21 ----------- tools/clog-builder-scope.lisp | 68 ++++++++++++++++++++++++++++++----- 2 files changed, 60 insertions(+), 29 deletions(-) diff --git a/tools/clog-builder-probe.lisp b/tools/clog-builder-probe.lisp index 3f8c0ce..4e1bcaa 100644 --- a/tools/clog-builder-probe.lisp +++ b/tools/clog-builder-probe.lisp @@ -30,27 +30,6 @@ (SWANK::*BUFFER-READTABLE* *READTABLE*)) (swank:inspect-in-emacs object)))))) -(defun inspect-class (symbol title value clog-obj) - (declare (ignore clog-obj)) - (let ((class (class-of symbol))) - (format t "~%Inspecting ~A = ~A~%" title value) - (format t "Class of : ~A~%" class) - (format t "Class Name : ~A~%" (class-name class)) - (format t "Class Precedence List : ~A~%" (closer-mop:class-precedence-list class)) - (format t "Class Slots : ~A~%" (mapcar (lambda (obj) - (closer-mop:slot-definition-name obj)) - (closer-mop:class-slots class))) - (format t "Direct Generic Functions : ~A~%" (mapcar (lambda (obj) - (list obj - (closer-mop:generic-function-name obj) - (closer-mop:generic-function-lambda-list obj) - )) - (closer-mop:specializer-direct-generic-functions class))) - (format t "Direct Methods : ~A~%" (closer-mop:specializer-direct-methods class)) - )) - -(add-inspector "Class Inspector" 'inspect-class) - (defun on-probe-panel (obj) (let ((app (connection-data-item obj "builder-app-data"))) (if (probe-win app) diff --git a/tools/clog-builder-scope.lisp b/tools/clog-builder-scope.lisp index 667c4bd..fac154d 100644 --- a/tools/clog-builder-scope.lisp +++ b/tools/clog-builder-scope.lisp @@ -5,6 +5,7 @@ (*default-border-class* *builder-border-class*) (win (create-gui-window obj :title "CLOG Object Scope" :width 640 + :height 480 :has-pinner t :keep-on-top t :client-movement *client-side-movement*)) @@ -38,19 +39,70 @@ (setf value (ppcre:regex-replace-all "<" value "<")) (setf value (ppcre:regex-replace-all ">" value ">")))) (add-class (node class object) - (let* ((class-tree (create-clog-tree node - :indent-level (if (typep node 'clog-panel) + (let* ((is-root (typep node 'clog-panel)) + (class-tree (create-clog-tree (if is-root + node + (tree-root node)) + :visible is-root + :indent-level (if is-root 0 (1+ (indent-level node))) - :content (format nil "Class Name: ~A : Object Value ~A" - (escape-lisp class) (escape-lisp object))))) + :content (format nil "Class: ~A : Object Value ~A" + (escape-lisp (class-name class)) (escape-lisp object))))) + (create-clog-tree (tree-root class-tree) + :node-html "👪" + :content "Precedence List" + :visible is-root + :indent-level (1+ (indent-level class-tree)) + :fill-function (lambda (obj) + (on-precedences obj class object))) (create-clog-tree (tree-root class-tree) :node-html "🕮" :content "Slots" - :visible nil + :visible is-root :indent-level (1+ (indent-level class-tree)) :fill-function (lambda (obj) - (on-slots obj class object))))) + (on-slots obj class object))) + (create-clog-tree (tree-root class-tree) + :node-html "🔨" + :content "Direct Generic Functions" + :visible is-root + :indent-level (1+ (indent-level class-tree)) + :fill-function (lambda (obj) + (on-generic obj class))) + (create-clog-tree (tree-root class-tree) + :node-html "👞" + :content "Direct Methods" + :visible is-root + :indent-level (1+ (indent-level class-tree)) + :fill-function (lambda (obj) + (on-method obj class))) + )) + (on-generic (obj class) + (mapcar (lambda (item) + (create-clog-tree (tree-root obj) + :indent-level (1+ (indent-level obj)) + :node-html "🔧" + :visible nil + :content (format nil "~A ~A" + (escape-lisp (closer-mop:generic-function-name item)) + (escape-lisp (closer-mop:generic-function-lambda-list item))))) + (closer-mop:specializer-direct-generic-functions class))) + (on-method (obj class) + (mapcar (lambda (item) + (create-clog-tree (tree-root obj) + :indent-level (1+ (indent-level obj)) + :node-html "👟" + :visible nil + :content (format nil "~A ~A" + (escape-lisp (closer-mop:generic-function-name (closer-mop:method-generic-function item))) + (escape-lisp (closer-mop:method-lambda-list item))))) + (closer-mop:specializer-direct-methods class))) + (on-precedences (obj class object) + (mapcar (lambda (item) + (unless (eq item class) + (add-class obj item object))) + (closer-mop:class-precedence-list class))) (on-slots (obj class object) (mapcar (lambda (slot) (create-clog-tree (tree-root obj) @@ -61,8 +113,8 @@ (let* ((object (slot-value object (closer-mop:slot-definition-name slot))) (class (class-of object))) (add-class obj class object))) - :content (format nil "Slot Name ~A : Slot Value = ~A" - (closer-mop:slot-definition-name slot) + :content (format nil "~A Object Value = ~A" + (escape-lisp (closer-mop:slot-definition-name slot)) (escape-lisp (slot-value object (closer-mop:slot-definition-name slot)))))) (closer-mop:class-slots class))) (on-change (object)