clouseau: new state mixin CONTEXT-CLASS-MIXIN

Allows storing a "context class" in the state in order to print symbol
names "relative to" the name of the context class.

3 files changed, 28 insertions, 17 deletions

diff --git a/Apps/Clouseau/src/objects/class.lisp b/Apps/Clouseau/src/objects/class.lisp
index c7d6567e..6884df42 100644
--- a/Apps/Clouseau/src/objects/class.lisp
+++ b/Apps/Clouseau/src/objects/class.lisp
@@ -35,9 +35,10 @@
   (error "not implemented"))
 
 (defmethod make-object-state ((object t) (place slot-definition-place))
-  (make-instance (object-state-class object place) :place place
-                                                   :class (container place)
-                                                   :style :name-only))
+  (make-instance (object-state-class object place)
+                 :place         place
+                 :context-class (container place)
+                 :style         :name-only))
 
 ;;; `class-list-place'
 ;;;
@@ -76,9 +77,9 @@
 ;;; `inspected-slot-definition'
 
 (defclass inspected-slot-definition (inspected-instance
-                                     remembered-collapsed-style-mixin)
-  ((%context-class :initarg :class
-                   :reader  context-class)))
+                                     remembered-collapsed-style-mixin
+                                     context-class-mixin)
+  ())
 
 (defmethod object-state-class ((object c2mop:slot-definition) (place t))
   'inspected-slot-definition)
@@ -92,9 +93,8 @@
 
 (defmethod initialize-instance :after
     ((instance inspected-class-list)
-     &key
-     place
-     (class-list-style (default-class-list-style place)))
+     &key place
+          (class-list-style (default-class-list-style place)))
   (setf (class-list-style instance) class-list-style))
 
 (defmethod object-state-class ((object cons)
@@ -121,9 +121,8 @@
                                        (state  inspected-slot-definition)
                                        (style  (eql :name-only))
                                        (stream t))
-  (let ((class-name (class-name (context-class state)))
-        (slot-name  (c2mop:slot-definition-name object)))
-    (print-symbol-in-context slot-name (symbol-package class-name) stream)))
+  (let ((slot-name (c2mop:slot-definition-name object)))
+    (print-symbol-in-context slot-name (context-package state) stream)))
 
 ;;; `inspected-class-list'
 
diff --git a/Apps/Clouseau/src/objects/generic.lisp b/Apps/Clouseau/src/objects/generic.lisp
index 4af34a2a..43d30539 100644
--- a/Apps/Clouseau/src/objects/generic.lisp
+++ b/Apps/Clouseau/src/objects/generic.lisp
@@ -120,3 +120,15 @@
     (if (eq new-value collapsed-style)
         (call-next-method)
         (setf (style object) collapsed-style))))
+
+;;; Context class mixin
+
+(defclass context-class-mixin ()
+  ((%context-class :initarg  :context-class
+                   :reader   context-class
+                   :initform nil)))
+
+(defun context-package (state)
+  (when-let* ((context-class (context-class state))
+              (class-name    (class-name context-class)))
+    (symbol-package class-name)))
diff --git a/Apps/Clouseau/src/objects/instance.lisp b/Apps/Clouseau/src/objects/instance.lisp
index 9b98a2a7..36878e41 100644
--- a/Apps/Clouseau/src/objects/instance.lisp
+++ b/Apps/Clouseau/src/objects/instance.lisp
@@ -90,16 +90,16 @@
 
 (defmethod make-object-state ((object t) (place slot-definition-of-place))
   (make-instance (object-state-class object place)
-                 :place place
-                 :class (class-of (container place))
-                 :style :name-only))
+                 :place         place
+                 :context-class (class-of (container place))
+                 :style         :name-only))
 
 (defun inspect-as-slot-name (instance slot-definition stream)
   ;; This presents the name of SLOT-DEFINITION as a collapsed
   ;; inspectable object that expands into SLOT-DEFINITION.
   (formatting-place
-      (instance 'slot-definition-of-place slot-definition nil inspect)
-    (inspect stream)))
+      (instance 'slot-definition-of-place slot-definition nil present-value)
+    (present-value stream)))
 
 
 ;;;; Object states