src/attribute.lisp

   1 (in-package :lisp-on-lines)
   2
   3 (define-layered-class direct-attribute-definition-class
   4  (special-layered-direct-slot-definition contextl::singleton-direct-slot-definition)
   5   ((attribute-properties :accessor direct-attribute-properties
   6                      :documentation "This is an plist to hold the values of the attribute's properties as described by this direct attrbiute definition.")))
   7
   8 (defmethod initialize-instance :after ((attribute direct-attribute-definition-class) &rest initargs)
   9   (setf (direct-attribute-properties attribute) initargs))
  10
  11 (define-layered-class effective-attribute-definition-class (special-layered-effective-slot-definition)
  12   ((direct-attributes :accessor attribute-direct-attributes)
  13    (attribute-object :accessor attribute-object
  14                      :documentation "")))
  15
  16
  17 (define-layered-function attribute-value (object attribute))
  18
  19 (define-layered-method attribute-value (object attribute)
  20
  21  (let ((fn (handler-case (attribute-function attribute)
  22              (unbound-slot () nil))))
  23    (if fn
  24        (funcall fn object)
  25        (%attribute-value attribute))))
  26
  27 (defmethod attribute-description (attribute)
  28   ;(break "description for ~A is (slot-value attribute 'description-name)")
  29   (find-layer (slot-value attribute 'description-class))
  30 #+nil  (let ((name (slot-value attribute 'description-name)))
  31     (when name
  32       (find-description name))))
  33
  34
  35 (define-layered-class standard-attribute ()
  36
  37   ((effective-attribute-definition :initarg effective-attribute
  38                                    :accessor attribute-effective-attribute-definition)
  39    (description-name)
  40    (description-class :initarg description-class)
  41    (initfunctions :initform nil)
  42    (attribute-class :accessor attribute-class :initarg :attribute-class :initform 'standard-attribute)
  43    (name :layered-accessor attribute-name
  44           :initarg :name)
  45    (label :layered-accessor attribute-label
  46           :initarg :label
  47           :initform nil
  48           :layered t
  49           ;:special t
  50           )
  51    (function
  52     :initarg :function
  53     :layered-accessor attribute-function
  54     :layered t)
  55    (value :layered-accessor %attribute-value
  56           :initarg :value
  57           :layered t)))
  58
  59
  60
  61 (defmethod print-object ((object standard-attribute) stream)
  62   (print-unreadable-object (object stream :type nil :identity t)
  63     (format stream "ATTRIBUTE ~A" (or (ignore-errors (attribute-name object)) "+unnamed-attribute+"))))
  64
  65 (defvar *bypass-property-layered-function* nil)
  66
  67 (define-layered-function property-layered-function (description attribute-name property-name)
  68   (:method  (description attribute-name property-name)
  69     ;(dprint "First Time PLFunction for ~A ~A ~A" description attribute-name property-name)
  70     (ensure-layered-function
  71      (defining-description (intern (format nil "~A-~A-~A"
  72                     (description-print-name description)
  73                      attribute-name
  74                      property-name)))
  75
  76      :lambda-list '(description))))
  77
  78 (define-layered-method (setf slot-value-using-layer)
  79   :in-layer (context t)
  80   (new-value class (attribute standard-attribute) property writer)
  81
  82   (when (or *bypass-property-layered-function*
  83             (not (slot-definition-layeredp property)))
  84     (return-from slot-value-using-layer (call-next-method)))
  85
  86
  87   ;;FIXME: this is wrong for so many reasons.
  88   (let ((layer
  89          (find-layer (first (remove nil (closer-mop::class-precedence-list (class-of context))
  90                      :key #'class-name)))))
  91
  92
  93     (flet ((do-set-slot()
  94
  95              (let ((fn
  96               (let ((*bypass-property-layered-function* t))
  97                 (if (slot-boundp-using-class class attribute property)
  98                     (slot-value-using-class class attribute property)
  99                     (setf (slot-value-using-class class attribute property)
 100                           (property-layered-function
 101                            (attribute-description attribute)
 102                            (attribute-name attribute)
 103                            (closer-mop:slot-definition-name property)))))))
 104          ;(dprint "We are setting the fn ~A " fn)
 105          (when (not (generic-function-methods fn))
 106           ; (dprint "... there are no methods on it ever")
 107            ;; * This slot has never been set before.
 108            ;; create a method on property-layered-function
 109            ;; so subclasses can see this new property.
 110            (ensure-layered-method
 111             (layered-function-definer 'property-layered-function)
 112             `(lambda (description attribute property)
 113                (declare (ignore description attribute property))
 114                ,fn)
 115             :in-layer layer
 116             :specializers
 117             (list (class-of
 118                    (attribute-description attribute))
 119                   (closer-mop:intern-eql-specializer
 120                    (attribute-name attribute))
 121                   (closer-mop:intern-eql-specializer
 122                    (closer-mop:slot-definition-name property)))))
 123
 124
 125          ;; finally, specialize this property to this description.
 126          (ensure-layered-method
 127           fn
 128           `(lambda (description)
 129              ,new-value)
 130           :in-layer layer
 131           :specializers (list (class-of (attribute-description attribute)
 132                                        ))))))
 133
 134       (if (slot-boundp attribute 'description-class)
 135           (do-set-slot)
 136           (push (lambda () (do-set-slot))
 137                 (slot-value attribute 'initfunctions))))))
 138
 139
 140 (define-layered-method slot-value-using-layer
 141   :in-layer (layer t)
 142   :around (class (attribute standard-attribute) property reader)
 143   ;(dprint "Getting the slot value of ~A" property)
 144
 145   (when (not (slot-boundp-using-class class attribute property))
 146     ;; If the slot is unbound, we search for its layered-function
 147
 148     (let ((fn (property-layered-function
 149                (attribute-description attribute)
 150
 151                         (attribute-name attribute)
 152                         (closer-mop:slot-definition-name property))))
 153       (dprint ".. not bound yet, have function ~A" fn)
 154       (if (generic-function-methods fn)
 155           (let ((*bypass-property-layered-function* t))
 156            ; (dprint " This shit has been bound!. We gona set the _real_ slot to the generic function like.")
 157             (setf (slot-value-using-class class attribute property) fn))
 158           (progn
 159             ;(dprint "This shit aint never been bound nowhere! checking for initfunction...")
 160             (when (slot-definition-initfunction property)
 161               ;(dprint "At least we have an initfunction. sweeet")
 162               (let ((*bypass-property-layered-function* nil))
 163                 (setf (slot-value attribute (slot-definition-name property))
 164                     (funcall (slot-definition-initfunction property)))))))))
 165
 166   ;(dprint "If we're here, the slot should be bound")
 167
 168
 169    (if (and
 170        (contextl::slot-definition-layeredp property)
 171        (not *bypass-property-layered-function*))
 172       (let ((fn (call-next-method)))
 173         ;(dprint "... using fn ~A to get value" fn)
 174       (funcall fn layer  (attribute-description attribute)))
 175       (call-next-method)))
 176
 177
 178
 179
 180 (defun slot-boundp-using-property-layered-function (class attribute property)
 181   (when (not
 182          (let ((*bypass-property-layered-function* t))
 183            (slot-boundp-using-class class attribute property)))
 184     ;; If the slot is unbound, we search for its layered-function
 185
 186     (let ((fn (property-layered-function
 187                (attribute-description attribute)
 188
 189                         (attribute-name attribute)
 190                         (closer-mop:slot-definition-name property))))
 191       (if (generic-function-methods fn)
 192           (let ((*bypass-property-layered-function* t))
 193             (setf (slot-value-using-class class attribute property) fn))
 194           NIL))))
 195
 196 #+nil(define-layered-method slot-boundp-using-layer
 197   :in-layer (layer t)
 198   :around (class (attribute standard-attribute) property reader)
 199   (if *bypass-property-layered-function*
 200       (call-next-method)
 201       (slot-boundp-using-property-layered-function class attribute property)))
 202
 203 (defun attribute-value* (attribute)
 204   (attribute-value *object* attribute))
 205
 206 (defmacro with-attributes (names description &body body)
 207   `(with-slots ,names ,description ,@body))
 208
 209 (defun display-attribute (attribute)
 210   (display-using-description attribute *display* *object*))
 211
 212 (define-layered-method display-using-description
 213   ((attribute standard-attribute) display object &rest args)
 214   (declare (ignore args))
 215   (when (attribute-label attribute)
 216     (format display "~A " (attribute-label attribute)))
 217   (format display "~A" (attribute-value object attribute)))
 218
 219
 220
 221
 222
 223
 224
 225
 226
 227
 228