clouseau: specialized places for packages

1 files changed, 109 insertions, 4 deletions

diff --git a/Apps/Clouseau/src/objects/package.lisp b/Apps/Clouseau/src/objects/package.lisp
index d8fc41f4..e9bd1912 100644
--- a/Apps/Clouseau/src/objects/package.lisp
+++ b/Apps/Clouseau/src/objects/package.lisp
@@ -10,6 +10,101 @@
 
 (cl:in-package #:clouseau)
 
+;;; Places
+
+;;; `package-data-place-mixin'
+
+(defclass package-data-place-mixin ()
+  ())
+
+(defmethod supportsp :around ((place     package-data-place-mixin)
+                              (operation (eql 'setf)))
+  (and (not (package-locked-p (container place)))
+       (call-next-method)))
+
+;;; `package-name-place'
+
+(defclass package-name-place (package-data-place-mixin
+                              basic-place)
+  ())
+
+(defmethod accepts-value-p ((place package-name-place) (value t))
+  (typep value '(or character string symbol)))
+
+(defmethod value ((place package-name-place))
+  (package-name (container place)))
+
+(defmethod (setf value) ((new-value t) (place package-name-place))
+  (let ((package (container place)))
+    (rename-package package new-value (package-nicknames package))))
+
+;;; `package-nicknames-place'
+
+(defclass package-nicknames-place (package-data-place-mixin
+                                   basic-place)
+  ())
+
+(defmethod accepts-value-p ((place package-nicknames-place) (value t))
+  (and (alexandria:proper-list-p value)
+       (every (alexandria:of-type '(or character string symbol)) value)))
+
+(defmethod value ((place package-nicknames-place))
+  (package-nicknames (container place)))
+
+(defmethod (setf value) ((new-value t) (place package-nicknames-place))
+  (let ((package (container place)))
+    (rename-package package (package-name package) new-value)))
+
+(defmethod object-state-class ((object null) (place package-nicknames-place))
+  'inspected-symbol-list)
+
+(defmethod object-state-class ((object cons) (place package-nicknames-place))
+  'inspected-symbol-list)
+
+;;; `package-list-place-mixin'
+
+(defclass package-list-place-mixin ()
+  ())
+
+(defmethod object-state-class ((object null) (place package-list-place-mixin))
+  'inspected-package-list)
+
+(defmethod object-state-class ((object cons) (place package-list-place-mixin))
+  'inspected-package-list)
+
+;;; `package-use-list-place'
+
+(defclass package-use-list-place (package-data-place-mixin
+                                  package-list-place-mixin
+                                  basic-place)
+  ())
+
+(defmethod accepts-value-p ((place package-use-list-place)
+                            (value t))
+  (and (alexandria:proper-list-p value)
+       (every (alexandria:of-type 'package) value)))
+
+(defmethod value ((place package-use-list-place))
+  (package-use-list (container place)))
+
+(defmethod (setf value) ((new-value list) (place package-use-list-place))
+  (let* ((package   (container place))
+         (old-value (value place))
+         (added     (set-difference new-value old-value :test #'eq))
+         (removed   (set-difference old-value new-value :test #'eq)))
+    (use-package added package)
+    (unuse-package removed package)))
+
+;;; `package-used-by-list-place'
+
+(defclass package-used-by-list-place (package-data-place-mixin
+                                      package-list-place-mixin
+                                      read-only-place)
+  ())
+
+(defmethod value ((place package-used-by-list-place))
+  (package-used-by-list (container place)))
+
 ;;; Object states
 
 ;;; `inspected-package'
@@ -28,6 +123,16 @@
 (defmethod object-state-class ((object package) (place t))
   'inspected-package)
 
+;;; `inspected-package-list'
+
+(defclass inspected-package-list (inspected-proper-list)
+  ())
+
+;;; `inspected-symbol-list'
+
+(defclass inspected-symbol-list (inspected-proper-list)
+  ())
+
 ;;; Object inspection methods
 
 (defun package-symbols (package &key filter)
@@ -55,16 +160,16 @@
   (with-preserved-cursor-x (stream)
     (formatting-table (stream)
       (formatting-row (stream)
-        (format-place-cells stream object 'reader-place 'package-name
+        (format-place-cells stream object 'package-name-place nil
                             :label "Name")
-        (format-place-cells stream object 'reader-place 'package-nicknames
+        (format-place-cells stream object 'package-nicknames-place nil
                             :label "Nicknames")
         #+sbcl (format-place-cells stream object 'reader-place 'package-locked-p
                                    :label "Locked"))
       (formatting-row (stream)
-        (format-place-cells stream object 'reader-place 'package-use-list
+        (format-place-cells stream object 'package-use-list-place nil
                             :label "Uses")
-        (format-place-cells stream object 'reader-place 'package-used-by-list
+        (format-place-cells stream object 'package-used-by-list-place nil
                             :label "Used by"))
       #+sbcl (format-place-row stream object 'reader-place 'sb-ext:package-local-nicknames
                                :label "Local nicknames")))