clouseau: idea for restricting place modification

7 files changed, 60 insertions, 14 deletions

diff --git a/Apps/Clouseau/src/objects/array.lisp b/Apps/Clouseau/src/objects/array.lisp
index a7f52ccc..830fd896 100644
--- a/Apps/Clouseau/src/objects/array.lisp
+++ b/Apps/Clouseau/src/objects/array.lisp
@@ -2,7 +2,7 @@
 ;;;   License: LGPL-2.1+ (See file 'Copyright' for details).
 ;;; ---------------------------------------------------------------------------
 ;;;
-;;;  (c) copyright 2018-2020 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+;;;  (c) copyright 2018-2021 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
 ;;;
 ;;; ---------------------------------------------------------------------------
 ;;;
@@ -214,7 +214,7 @@
                        :do (formatting-row (stream)
                              (formatting-place
                                  (object place-class i present inspect)
-                               (formatting-cell (stream :align-x :right)
+                               (formatting-cell (stream :align-x :right) ; TODO not yellow when read-only
                                  (present stream))
                                (formatting-cell (stream)
                                  (if (and fill-pointer (>= i fill-pointer))
diff --git a/Apps/Clouseau/src/objects/class.lisp b/Apps/Clouseau/src/objects/class.lisp
index 8457cfdc..f5d57c3e 100644
--- a/Apps/Clouseau/src/objects/class.lisp
+++ b/Apps/Clouseau/src/objects/class.lisp
@@ -2,7 +2,7 @@
 ;;;   License: LGPL-2.1+ (See file 'Copyright' for details).
 ;;; ---------------------------------------------------------------------------
 ;;;
-;;;  (c) copyright 2018-2020 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+;;;  (c) copyright 2018-2021 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
 ;;;
 ;;; ---------------------------------------------------------------------------
 ;;;
@@ -47,7 +47,7 @@
 ;;; interest. As a result, such lists can be shown as a list or as the
 ;;; graph induced by the relation.
 
-(defclass class-list-place (read-only-place)
+(defclass class-list-place (deep-read-only-place)
   ())
 
 (macrolet
diff --git a/Apps/Clouseau/src/objects/function.lisp b/Apps/Clouseau/src/objects/function.lisp
index acaf0cca..1df7e64f 100644
--- a/Apps/Clouseau/src/objects/function.lisp
+++ b/Apps/Clouseau/src/objects/function.lisp
@@ -2,7 +2,7 @@
 ;;;   License: LGPL-2.1+ (See file 'Copyright' for details).
 ;;; ---------------------------------------------------------------------------
 ;;;
-;;;  (c) copyright 2018-2020 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+;;;  (c) copyright 2018-2021 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
 ;;;
 ;;; ---------------------------------------------------------------------------
 ;;;
@@ -177,7 +177,7 @@
                             :label "Name")
           ;; Lambda list
           (formatting-row (stream)
-            (formatting-place (object 'pseudo-place lambda-list present inspect)
+            (formatting-place (object 'deep-pseudo-place lambda-list present inspect)
               (with-style (stream :slot-like)
                 (formatting-cell (stream) (write-string "Lambda list" stream))
                 (formatting-cell (stream) (present stream)))
@@ -189,7 +189,7 @@
                    (inspect stream)))))))
         ;; Type
         #+sbcl
-        (format-place-row stream object 'reader-place 'sb-introspect:function-type
+        (format-place-row stream object 'deep-reader-place 'sb-introspect:function-type
                           :label "Type")))
     ;; Documentation
     (print-documentation object stream)
diff --git a/Apps/Clouseau/src/objects/list.lisp b/Apps/Clouseau/src/objects/list.lisp
index 66238378..3cdc7847 100644
--- a/Apps/Clouseau/src/objects/list.lisp
+++ b/Apps/Clouseau/src/objects/list.lisp
@@ -2,7 +2,7 @@
 ;;;   License: LGPL-2.1+ (See file 'Copyright' for details).
 ;;; ---------------------------------------------------------------------------
 ;;;
-;;;  (c) copyright 2018-2020 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+;;;  (c) copyright 2018-2021 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
 ;;;
 ;;; ---------------------------------------------------------------------------
 ;;;
diff --git a/Apps/Clouseau/src/objects/package.lisp b/Apps/Clouseau/src/objects/package.lisp
index e9bd1912..5069c344 100644
--- a/Apps/Clouseau/src/objects/package.lisp
+++ b/Apps/Clouseau/src/objects/package.lisp
@@ -17,6 +17,10 @@
 (defclass package-data-place-mixin ()
   ())
 
+(defmethod supportsp ((place     package-data-place-mixin)
+                      (operation (eql 'modify-descendants)))
+  nil)
+
 (defmethod supportsp :around ((place     package-data-place-mixin)
                               (operation (eql 'setf)))
   (and (not (package-locked-p (container place)))
diff --git a/Apps/Clouseau/src/objects/symbol.lisp b/Apps/Clouseau/src/objects/symbol.lisp
index b7baa505..3404df74 100644
--- a/Apps/Clouseau/src/objects/symbol.lisp
+++ b/Apps/Clouseau/src/objects/symbol.lisp
@@ -165,7 +165,7 @@
                                        (stream t))
   (formatting-table (stream)
     (formatting-row (stream)
-      (format-place-cells stream object 'reader-place 'symbol-name
+      (format-place-cells stream object 'deep-reader-place 'symbol-name
                           :label "Name")
       (format-place-cells stream object 'symbol-package-place nil
                           :label "Package"))
diff --git a/Apps/Clouseau/src/place.lisp b/Apps/Clouseau/src/place.lisp
index 4c3bb17c..40328d59 100644
--- a/Apps/Clouseau/src/place.lisp
+++ b/Apps/Clouseau/src/place.lisp
@@ -2,7 +2,7 @@
 ;;;   License: LGPL-2.1+ (See file 'Copyright' for details).
 ;;; ---------------------------------------------------------------------------
 ;;;
-;;;  (c) copyright 2018-2020 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+;;;  (c) copyright 2018-2021 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
 ;;;
 ;;; ---------------------------------------------------------------------------
 ;;;
@@ -62,8 +62,29 @@
         existing
         (setf (state place) (funcall thunk)))))
 
+(defmethod supportsp ((place     basic-place)
+                      (operation (eql 'modify-descendants)))
+  (if-let ((parent (parent place)))
+    (supportsp parent 'modify-descendants)
+    t))
+
+(defmethod supportsp :around ((place basic-place) (operation (eql 'setf)))
+  (and (call-next-method)
+       (if-let ((parent (parent place)))
+         (supportsp parent 'modify-descendants)
+         t)))
+
 (defmethod supportsp ((place basic-place) (operation (eql 'setf)))
-  t)
+  (if-let ((parent (parent place)))
+    (supportsp parent 'modify-descendants)
+    t))
+
+(defmethod supportsp :around ((place     basic-place)
+                              (operation (eql 'remove-value)))
+  (and (call-next-method)
+       (if-let ((parent (parent place)))
+         (supportsp parent 'modify-descendants)
+         t)))
 
 (defmethod supportsp ((place basic-place) (operation (eql 'remove-value)))
   nil)
@@ -86,6 +107,15 @@
 (defmethod supportsp ((place read-only-place) (operation (eql 'setf)))
   nil)
 
+;;; `deep-read-only-place'
+
+(defclass deep-read-only-place (read-only-place)
+  ())
+
+(defmethod supportsp ((place     read-only-place)
+                      (operation (eql 'modify-descendants)))
+  nil)
+
 ;;; `sequence-element-place'
 
 (defclass sequence-element-place (basic-place)
@@ -125,8 +155,12 @@
 
 ;;; `reader-place'
 
-(defclass reader-place (function-backed-place
-                        read-only-place)
+(defclass reader-place (read-only-place
+                        function-backed-place)
+  ())
+
+(defclass deep-reader-place (deep-read-only-place
+                             function-backed-place)
   ())
 
 ;;; `accessor-place'
@@ -142,9 +176,17 @@
 ;;; A place that is in some way computed or derived and not backed by
 ;;; a concrete location such as an instance slot or array element.
 
-(defclass pseudo-place (read-only-place)
+(defclass pseudo-place-mixin ()
   ((%cell :reader value)))
 
+(defclass pseudo-place (read-only-place
+                        pseudo-place-mixin)
+  ())
+
+(defclass deep-pseudo-place (deep-read-only-place
+                             pseudo-place-mixin)
+  ())
+
 ;;; `root-place'
 
 (defclass root-place (basic-place)