r11442: add compute-cached-value slot option

[hyperobject.git] / mop.lisp

diff --git a/mop.lisp b/mop.lisp
index 2ccf8d685a106ae8e51f3111781a90b495ce9442..3505a1bdf754c72113855cebbd510907d3e89cbc 100644 (file)
--- a/mop.lisp
+++ b/mop.lisp
@@ -51,6 +51,9 @@
    (subobjects :initform nil :accessor subobjects
               :documentation
               "List of fields that contain a list of subobjects objects.")
+   (compute-cached-values :initform nil :accessor compute-cached-values
+                         :documentation
+                         "List of fields that contain a list of compute-cached-value objects.")
    (hyperlinks :type list :initform nil :accessor hyperlinks
               :documentation "List of fields that have hyperlinks")
    (direct-rules :type list :initform nil :initarg :direct-rules
@@ -82,11 +85,22 @@
 (defclass subobject ()
   ((name-class :type symbol :initarg :name-class :reader name-class)
    (name-slot :type symbol :initarg :name-slot :reader name-slot)
-   (subobj-class :type symbol :initarg :subobj-class :reader subobj-class)
+   (lazy-class :type symbol :initarg :lazy-class :reader lazy-class)
    (lookup :type (or function symbol) :initarg :lookup :reader lookup)
    (lookup-keys :type list :initarg :lookup-keys :reader lookup-keys))
   (:documentation "subobject information")
-  (:default-initargs :name-class nil :name-slot nil :subobj-class nil
+  (:default-initargs :name-class nil :name-slot nil :lazy-class nil
+                    :lookup nil :lookup-keys nil))
+
+(defclass compute-cached-value ()
+  ((name-class :type symbol :initarg :name-class :reader name-class)
+   (name-slot :type symbol :initarg :name-slot :reader name-slot)
+   (lazy-class :type symbol :initarg :lazy-class
+                              :reader lazy-class)
+   (lookup :type (or function symbol) :initarg :lookup :reader lookup)
+   (lookup-keys :type list :initarg :lookup-keys :reader lookup-keys))
+  (:documentation "subobject information")
+  (:default-initargs :name-class nil :name-slot nil :lazy-class nil
                     :lookup nil :lookup-keys nil))
 
 
@@ -275,7 +289,7 @@
                    description value-constraint indexed null-allowed
                    unique short-description void-text read-only-groups
                    hidden-groups unit disable-predicate view-type
-                   list-of-values stored))
+                   list-of-values compute-cached-value stored))
       (setf (slot-value esd name) (slot-value dsd name)))
     esd))
 
@@ -387,11 +401,11 @@ SQL name"
 ;; The reader is a function and the reader-keys are slot names.  The slot is lazily set to
 ;; the result of applying the function to the slot-values of those slots, and that value
 ;; is also returned.
-(defun ensure-lazy-reader (cl class-name slot-name subobj-class reader
+(defun ensure-lazy-reader (cl class-name slot-name lazy-class reader
                           &rest reader-keys)
   (declare (ignore class-name))
   (setf (getf (gethash cl *lazy-readers*) slot-name)
-    (aif subobj-class
+    (aif lazy-class
         it
         (list* reader (copy-list reader-keys)))))
 
@@ -400,35 +414,40 @@ SQL name"
     nil))
 
 
+(defun store-lazily-computed-objects (cl slot esd-accessor obj-class)
+  (setf (slot-value cl slot)
+        (let ((objs '()))
+          (dolist (slot (class-slots cl))
+            (let-when
+             (def (funcall esd-accessor slot))
+             (let ((obj (make-instance obj-class
+                                       :name-class (class-name cl)
+                                       :name-slot (slot-definition-name slot)
+                                       :lazy-class (when (atom def)
+                                                     def)
+                                       :lookup (when (listp def)
+                                                 (car def))
+                                       :lookup-keys (when (listp def)
+                                                      (cdr def)))))
+               (unless (eq (lookup obj) t)
+                 (apply #'ensure-lazy-reader
+                  cl
+                  (name-class obj) (name-slot obj)
+                  (lazy-class obj)
+                  (lookup obj) (lookup-keys obj))
+                 (push obj objs)))))
+          ;; sbcl/cmu reverse class-slots compared to the defclass form
+          ;; so re-reverse on cmu/sbcl
+          #+(or cmu sbcl) objs
+          #-(or cmu sbcl) (nreverse objs)
+          )))
+
 (defun finalize-subobjects (cl)
-  "Process class subobjects slot"
-  (setf (subobjects cl)
-       (let ((subobjects '()))
-         (dolist (slot (class-slots cl))
-           (let-when
-            (subobj-def (esd-subobject slot))
-            (let ((subobject
-                   (make-instance 'subobject
-                                  :name-class (class-name cl)
-                                  :name-slot (slot-definition-name slot)
-                                  :subobj-class (when (atom subobj-def)
-                                                  subobj-def)
-                                  :lookup (when (listp subobj-def)
-                                            (car subobj-def))
-                                  :lookup-keys (when (listp subobj-def)
-                                                 (cdr subobj-def)))))
-              (unless (eq (lookup subobject) t)
-                (apply #'ensure-lazy-reader
-                       cl
-                       (name-class subobject) (name-slot subobject)
-                       (subobj-class subobject)
-                       (lookup subobject) (lookup-keys subobject))
-                (push subobject subobjects)))))
-         ;; sbcl/cmu reverse class-slots compared to the defclass form
-         ;; so re-reverse on cmu/sbcl
-         #+(or cmu sbcl) subobjects
-         #-(or cmu sbcl) (nreverse subobjects)
-         )))
+  (store-lazily-computed-objects cl 'subobjects 'esd-subobject 'subobject))
+
+(defun finalize-compute-cached (cl)
+  (store-lazily-computed-objects cl 'compute-cached-values 
+                                 'esd-compute-cached-value 'compute-cached-value))
 
 (defun finalize-class-slots (cl)
   "Make sure all class slots have an expected value"
@@ -487,6 +506,7 @@ SQL name"
 (defun init-hyperobject-class (cl)
   "Initialize a hyperobject class. Calculates all class slots"
   (finalize-subobjects cl)
+  (finalize-compute-cached cl)
   (finalize-views cl)
   (finalize-hyperlinks cl)
   (finalize-sql cl)