src/mao/simple-plist-attribute.lisp

   1 (in-package :lisp-on-lines)
   2
   3 (define-layered-class simple-plist-attribute ()
   4   (%property-access-function
   5    (description-class :initarg description-class
   6                       :accessor attribute-description-class))
   7   (:documentation "A very simple implementation of ATTRIBUTEs based on
   8   simple plists.
   9
  10 To implement layered slot values, we use an anonymous layered function
  11 with a combination of APPEND. Methods on different layers return a
  12 plist (which is APPENDed), from which we simply GETF for the slot
  13 value.
  14
  15 This is ineffecient, of course, but is easy to understand. Caching and
  16 performance hacks are implemented in subclasses that extend the simple
  17 protocol we define here."))
  18
  19 (defstruct static-attribute-slot value)
  20
  21 (defmethod ensure-property-access-function ((attribute simple-plist-attribute))
  22   "return the PROPERTY-ACCESS-FUNCTION of this attribute.  FUNCALLing
  23 the returned symbol will return the plist of slot values."
  24   (if (slot-boundp attribute '%property-access-function)
  25       (slot-value attribute '%property-access-function)
  26       (let ((fn-name (gensym)))
  27         (ensure-layered-function fn-name :lambda-list '(description) :method-combination '(append))
  28         (setf (slot-value attribute '%property-access-function) fn-name))))
  29
  30 (defun property-access-value (attribute)
  31   (ignore-errors (funcall (ensure-property-access-function attribute) (attribute-description attribute))))
  32
  33 (defconstant +property-not-found+ '=lisp-on-lines-property-not-found-indicator=
  34   "A default value for GETF to return.")
  35
  36 (defvar *special-symbol-access* nil)
  37
  38 (defun special-symbol-access-p ()
  39   *special-symbol-access*)
  40
  41 (defmacro with-special-symbol-access (&body body)
  42   `(let ((*special-symbol-access* t))
  43      ,@body))
  44
  45 (defmacro without-special-symbol-access (&body body)
  46   `(let ((*special-symbol-access* nil))
  47      ,@body))
  48
  49 (define-layered-method
  50     contextl:slot-value-using-layer (class (attribute simple-plist-attribute) slotd reader) ()
  51     "Only layered slots that are not currently dynamically rebound are looked up via the plist.
  52 Initial slot values are stored in the PLIST of the symbol ENSURE-PROPERTY-ACCESS-FUNCTION returns."
  53
  54      (if (or contextl:*symbol-access*
  55           (special-symbol-access-p)
  56           (not (slot-definition-layeredp slotd)))
  57          (call-next-method)
  58          (multiple-value-bind (value boundp)
  59              (handler-case (values (call-next-method) t)
  60                (unbound-slot () (values nil nil)))
  61
  62            (when (and boundp (not (static-attribute-slot-p value)))
  63              (return-from slot-value-using-layer value))
  64
  65            (let ((dynamic-value
  66                   (getf (ignore-errors  (funcall (ensure-property-access-function attribute)
  67                                                      (find-layer (slot-value attribute 'description-class))))
  68
  69                         (slot-definition-name slotd)
  70                         +property-not-found+)))
  71
  72              (if (eq dynamic-value +property-not-found+)
  73                  (if boundp
  74                      (static-attribute-slot-value value)
  75                      (call-next-method))
  76                  dynamic-value)))))
  77
  78 (defun set-property-value-for-layer (attribute property value layer)
  79    (let ((vals (property-access-value attribute)))
  80      (ensure-layered-method
  81       (ensure-property-access-function attribute)
  82       `(lambda (description-class)
  83          ',(append (list property value) (alexandria:remove-from-plist vals property)))
  84       :specializers (list (class-of (attribute-description attribute)))
  85       :qualifiers '(append)
  86       :in-layer layer)))
  87
  88 (define-layered-method
  89     (setf contextl:slot-value-using-layer) :around (value class (attribute simple-plist-attribute) slotd writer)
  90 "This might not be here"
  91   (if (and (not contextl:*symbol-access*)
  92             (not (special-symbol-access-p))
  93             (slot-definition-layeredp slotd))
  94       (with-special-symbol-access  (setf (slot-value-using-layer class attribute slotd writer) (make-static-attribute-slot :value value)))
  95       (call-next-method))
  96 )
  97
  98 (defmethod initialize-attribute-for-description (description-class (attribute simple-plist-attribute) layer-name &rest args)
  99   "Define a method on the PROPERTY-ACCESS-FUNCTION to associate
 100 slots (named by their :initarg) with values in layer LAYER-NAME."
 101   (let* ((class (class-of attribute))
 102          (slotds (class-slots class)))
 103     (setf (slot-value attribute 'description-class) description-class)
 104     (ensure-layered-method
 105      (ensure-property-access-function attribute)
 106      `(lambda (description-class)
 107         ',(alexandria:remove-from-plist
 108            (loop
 109               :for (key val) :on args :by #'cddr
 110               :nconc (list
 111                       (loop
 112                          :for slotd :in slotds
 113                          :do (when (find key (slot-definition-initargs slotd))
 114                                (return  (slot-definition-name slotd))))
 115                       val))
 116            nil))
 117      :specializers (list description-class)
 118      :qualifiers '(append)
 119      :in-layer layer-name)))
 120