More new description code, still broken

[clinton/lisp-on-lines.git] / src / mao / simple-plist-attribute.lisp

diff --git a/src/mao/simple-plist-attribute.lisp b/src/mao/simple-plist-attribute.lisp
new file mode 100644 (file)
index 0000000..35144e5
--- /dev/null
+++ b/src/mao/simple-plist-attribute.lisp
@@ -0,0 +1,120 @@
+(in-package :lisp-on-lines)
+
+(define-layered-class simple-plist-attribute ()
+  (%property-access-function 
+   (description-class :initarg description-class 
+                     :accessor attribute-description-class))
+  (:documentation "A very simple implementation of ATTRIBUTEs based on
+  simple plists.
+
+To implement layered slot values, we use an anonymous layered function
+with a combination of APPEND. Methods on different layers return a
+plist (which is APPENDed), from which we simply GETF for the slot
+value.
+
+This is ineffecient, of course, but is easy to understand. Caching and
+performance hacks are implemented in subclasses that extend the simple
+protocol we define here."))
+
+(defstruct static-attribute-slot value)
+
+(defmethod ensure-property-access-function ((attribute simple-plist-attribute))
+  "return the PROPERTY-ACCESS-FUNCTION of this attribute.  FUNCALLing
+the returned symbol will return the plist of slot values."
+  (if (slot-boundp attribute '%property-access-function)
+      (slot-value attribute '%property-access-function)
+      (let ((fn-name (gensym))) 
+       (ensure-layered-function fn-name :lambda-list '(description) :method-combination '(append))
+       (setf (slot-value attribute '%property-access-function) fn-name))))
+
+(defun property-access-value (attribute)
+  (ignore-errors (funcall (ensure-property-access-function attribute) (attribute-description attribute))))
+
+(defconstant +property-not-found+ '=lisp-on-lines-property-not-found-indicator= 
+  "A default value for GETF to return.")
+
+(defvar *special-symbol-access* nil)
+
+(defun special-symbol-access-p ()
+  *special-symbol-access*)
+
+(defmacro with-special-symbol-access (&body body)
+  `(let ((*special-symbol-access* t))
+     ,@body))
+
+(defmacro without-special-symbol-access (&body body)
+  `(let ((*special-symbol-access* nil))
+     ,@body))
+
+(define-layered-method 
+    contextl:slot-value-using-layer (class (attribute simple-plist-attribute) slotd reader) ()
+    "Only layered slots that are not currently dynamically rebound are looked up via the plist.
+Initial slot values are stored in the PLIST of the symbol ENSURE-PROPERTY-ACCESS-FUNCTION returns." 
+ 
+     (if (or contextl:*symbol-access*  
+         (special-symbol-access-p)
+         (not (slot-definition-layeredp slotd)))
+        (call-next-method)
+        (multiple-value-bind (value boundp)
+            (handler-case (values (call-next-method) t) 
+              (unbound-slot () (values nil nil)))
+
+          (when (and boundp (not (static-attribute-slot-p value)))
+            (return-from slot-value-using-layer value))
+
+          (let ((dynamic-value 
+                 (getf (ignore-errors  (funcall (ensure-property-access-function attribute) 
+                                                    (find-layer (slot-value attribute 'description-class))))
+                       
+                       (slot-definition-name slotd)
+                       +property-not-found+)))
+                
+            (if (eq dynamic-value +property-not-found+)
+                (if boundp 
+                    (static-attribute-slot-value value)
+                    (call-next-method))
+                dynamic-value)))))
+
+(defun set-property-value-for-layer (attribute property value layer)
+   (let ((vals (property-access-value attribute)))
+     (ensure-layered-method  
+      (ensure-property-access-function attribute)
+      `(lambda (description-class)
+        ',(append (list property value) (alexandria:remove-from-plist vals property)))
+      :specializers (list (class-of (attribute-description attribute)))
+      :qualifiers '(append)
+      :in-layer layer)))
+
+(define-layered-method 
+    (setf contextl:slot-value-using-layer) :around (value class (attribute simple-plist-attribute) slotd writer)
+"This might not be here"
+  (if (and (not contextl:*symbol-access*)
+           (not (special-symbol-access-p))
+           (slot-definition-layeredp slotd)) 
+      (with-special-symbol-access  (setf (slot-value-using-layer class attribute slotd writer) (make-static-attribute-slot :value value)))
+      (call-next-method))
+)
+
+(defmethod initialize-attribute-for-description (description-class (attribute simple-plist-attribute) layer-name &rest args)
+  "Define a method on the PROPERTY-ACCESS-FUNCTION to associate
+slots (named by their :initarg) with values in layer LAYER-NAME."
+  (let* ((class (class-of attribute))
+        (slotds (class-slots class)))    
+    (setf (slot-value attribute 'description-class) description-class)
+    (ensure-layered-method  
+     (ensure-property-access-function attribute)
+     `(lambda (description-class)
+       ',(alexandria:remove-from-plist  
+          (loop 
+             :for (key val) :on args :by #'cddr 
+             :nconc (list 
+                     (loop 
+                        :for slotd :in slotds 
+                        :do (when (find key (slot-definition-initargs slotd))
+                              (return  (slot-definition-name slotd))))
+                     val))
+          nil)) 
+     :specializers (list description-class)
+     :qualifiers '(append)
+     :in-layer layer-name)))
+