src/attribute.lisp

   1 (in-package :lisp-on-lines)
   2
   3 (define-layered-class direct-attribute-definition-class
   4   (special-layered-direct-slot-definition
   5    contextl::singleton-direct-slot-definition)
   6   ((attribute-properties
   7     :accessor direct-attribute-properties
   8     :documentation "This is an plist to hold the values of
   9     the attribute's properties as described by this direct
  10     attribute definition.")))
  11
  12 (defmethod initialize-instance
  13     :after ((attribute direct-attribute-definition-class)
  14             &rest initargs)
  15   (setf (direct-attribute-properties attribute) initargs))
  16
  17 (define-layered-class effective-attribute-definition-class
  18     (special-layered-effective-slot-definition)
  19   ((direct-attributes
  20     :accessor attribute-direct-attributes)
  21    (attribute-object
  22     :accessor slot-definition-attribute-object)
  23    (attribute-object-initargs
  24     :accessor attribute-object-initargs)))
  25
  26 (defvar *function-access* nil
  27   "set/get a place's property function instead of its symbol value
  28    when this is set to a non-nil value")
  29
  30 (defmacro with-function-access (&body body)
  31   "executes body in an environment with *function-access* set to t"
  32   `(let ((*function-access* t))
  33      ,@body))
  34
  35 (defmacro without-function-access (&body body)
  36   "executes body in an environment with *function-access* set to nil"
  37   `(let ((*function-access* nil))
  38      ,@body))
  39
  40 (define-layered-function property-access-function (description attribute-name property-name)
  41   (:method  (description attribute-name property-name)
  42     (ensure-layered-function
  43      (defining-description
  44          (intern (format nil "=PROPERTY-ACCESS-FUNCTION-FOR-~A->~A.~A="
  45                          (description-print-name description)
  46                          attribute-name
  47                          property-name)))
  48          :lambda-list '(description))))
  49
  50
  51 (defvar *init-time-description* nil)
  52
  53 (defmethod attribute-description :around (attribute)
  54   (handler-case (call-next-method)
  55     (unbound-slot ()
  56       (or
  57        *init-time-description*
  58        (call-next-method)))))
  59
  60 (define-layered-class attribute ()
  61  ((description :initarg :description
  62                :accessor attribute-description)
  63   (name
  64    :layered-accessor attribute-name
  65    :initarg :name)
  66   (effective-attribute-definition
  67     :initarg effective-attribute
  68     :accessor attribute-effective-attribute-definition)
  69   (attribute-class
  70    :accessor attribute-class
  71    :initarg :attribute-class
  72    :initform 'standard-attribute)
  73   (keyword
  74    :layered-accessor attribute-keyword
  75    :initarg :keyword
  76    :initform nil
  77    :layered t)
  78   (object
  79    :layered-accessor attribute-object
  80    :accessor described-object
  81    :special t)))
  82
  83
  84 (define-layered-class standard-attribute (attribute)
  85  ((label
  86    :layered-accessor attribute-label
  87    :initarg :label
  88    :initform nil
  89    :layered t
  90    :special t)
  91   (label-formatter
  92    :layered-accessor attribute-label-formatter
  93    :initarg :label-formatter
  94    :initform  nil
  95    :layered t
  96    :special t)
  97   (function
  98    :initarg :function
  99    :layered-accessor attribute-function
 100    :layered t
 101    :special t)
 102   (value
 103    :layered-accessor attribute-value
 104    :initarg :value
 105    :layered t
 106    :special t)
 107   (value-formatter
 108    :layered-accessor attribute-value-formatter
 109    :initarg :value-formatter
 110    :initform nil
 111    :layered t
 112    :special t)
 113   (activep
 114    :layered-accessor attribute-active-p
 115    :initarg :activep ;depreciated
 116    :initarg :active
 117    :initform t
 118    :layered t
 119    :special t
 120    :documentation
 121    "Can be T, NIL or :WHEN. In the latter case, attribute is only active if the attribute value is non-null.")
 122   (active-attributes :layered-accessor attribute-active-attributes
 123                        :initarg :attributes
 124                        :layered t
 125                        :special t)
 126   (active-descriptions :layered-accessor attribute-active-descriptions
 127                        :initarg :activate
 128                        :initform nil
 129                        :layered t
 130                        :special t)
 131   (inactive-descriptions :layered-accessor attribute-inactive-descriptions
 132                        :initarg :deactivate
 133                        :initform nil
 134                        :layered t
 135                        :special t)))
 136
 137 (define-layered-method attribute-label-formatter :around (attribute)
 138    (or (slot-value attribute 'label-formatter)
 139        (attribute-value (find-attribute (attribute-description attribute) 'label-formatter))
 140        (error "No Formatter .. fool!")))
 141
 142 (define-layered-method attribute-value-formatter :around (attribute)
 143
 144    (or (slot-value attribute 'value-formatter)
 145        (attribute-value (find-attribute (attribute-description attribute) 'value-formatter))
 146        (error "No Formatter .. fool!")))
 147
 148
 149
 150 (define-layered-method attribute-object ((attribute standard-attribute))
 151  (if (slot-boundp attribute 'object)
 152      (call-next-method)
 153      (described-object (attribute-description attribute))))
 154
 155
 156 (define-layered-function attribute-value-using-object (object attribute))
 157 (define-layered-function (setf attribute-value-using-object) (value object attribute))
 158
 159 (define-layered-method attribute-value ((attribute standard-attribute))
 160  (attribute-value-using-object (attribute-object attribute) attribute))
 161
 162 (define-layered-method attribute-value-using-object (object attribute)
 163  (let ((fn (handler-case (attribute-function attribute)
 164              (unbound-slot () nil))))
 165    (if fn
 166        (funcall fn object)
 167        (slot-value attribute 'value))))
 168
 169 (define-layered-method (setf attribute-value) (value (attribute standard-attribute))
 170  (setf (attribute-value-using-object (attribute-object attribute) attribute) value))
 171
 172 (define-layered-method (setf attribute-value-using-object) (value object attribute)
 173  (error "No (SETF ATTRIBUTE-VALUE-USING-OBJECT) for ~A ~A and we are not editable"
 174         object attribute))
 175
 176
 177 (defun ensure-access-function (class attribute property)
 178   (with-function-access
 179     (if (slot-definition-specialp property)
 180         (let ((slot-symbol
 181                (with-symbol-access
 182                  (slot-value-using-class
 183                   class attribute property))))
 184           (if (fboundp slot-symbol)
 185               (symbol-function slot-symbol)
 186               (setf (symbol-function slot-symbol)
 187                     (property-access-function
 188                      (attribute-description attribute)
 189                      (attribute-name attribute)
 190                      (slot-definition-name property)))))
 191         (if (slot-boundp-using-class class attribute property)
 192             (slot-value-using-class class attribute property)
 193             (setf (slot-value-using-class class attribute property)
 194                   (property-access-function
 195                    (attribute-description attribute)
 196                    (attribute-name attribute)
 197                    (slot-definition-name property)))))))
 198
 199 (define-layered-method slot-boundp-using-layer
 200   :in-layer (layer t)
 201   :around (class (attribute standard-attribute) property reader)
 202
 203 ; (dprint "Checking boundp ~A ~A" (attribute-name attribute)
 204         ; (slot-definition-name property))
 205
 206   (if (or *symbol-access* *function-access*)
 207       (call-next-method)
 208       (or (when (slot-definition-specialp property)
 209             (with-function-access
 210            (slot-boundp-using-class class attribute property)))
 211           (if (generic-function-methods
 212                (ensure-access-function class attribute property))
 213               T
 214               NIL))))
 215
 216 (define-layered-method (setf slot-value-using-layer)
 217   :in-layer (context t)
 218   :around
 219   (new-value class (attribute standard-attribute) property writer)
 220
 221 ;;  (dprint "Setting ~A ~A to : ~A" attribute property new-value)
 222
 223   (if (or *symbol-access* *function-access*)
 224       (call-next-method)
 225
 226       (if (and (slot-definition-specialp property)
 227                (with-function-access
 228                  (without-symbol-access (slot-boundp-using-class class attribute property))))
 229           (with-function-access
 230             (call-next-method))
 231           (let ((layer
 232                  ;;FIXME: this is wrong for so many reasons
 233                  (find-layer (first (remove nil (closer-mop::class-precedence-list (class-of context))
 234                                             :key #'class-name))))
 235                 (boundp (slot-boundp-using-class class attribute property))
 236                 (fn  (ensure-access-function class attribute property)))
 237
 238             (when (not boundp)
 239               ;; * This slot has never been set before.
 240               ;; create a method on property-accessor-function
 241               ;; so subclasses can see this new property.
 242               (ensure-layered-method
 243                (layered-function-definer 'property-access-function)
 244                `(lambda (description attribute property)
 245                   (declare (ignore description attribute property))
 246                   ,fn)
 247                :in-layer layer
 248                :specializers
 249                (list (class-of
 250                       (attribute-description attribute))
 251                      (closer-mop:intern-eql-specializer
 252                       (attribute-name attribute))
 253                      (closer-mop:intern-eql-specializer
 254                       (closer-mop:slot-definition-name property)))))
 255
 256             ;; specialize this property to this description.
 257             ;;(dprint "actrually specializering")
 258             (ensure-layered-method
 259              fn
 260              `(lambda (description)
 261                 (funcall ,(lambda()
 262                                  new-value)))
 263              :in-layer layer
 264              :specializers (list (class-of (attribute-description attribute))))
 265
 266             ;;  and return the set value as is custom
 267             new-value))))
 268
 269 (define-layered-method slot-value-using-layer
 270   :in-layer (layer t)
 271   :around (class (attribute standard-attribute) property reader)
 272
 273 ;  ;(dprint "Getting the slot value of ~A" property)
 274   (if (or *symbol-access* *function-access*)
 275       (call-next-method)
 276       (let ((fn (ensure-access-function class attribute property)))
 277
 278         (unless (slot-boundp-using-class class attribute property)
 279           (slot-unbound class attribute (slot-definition-name property)))
 280
 281         (if (slot-definition-specialp property)
 282             (if (with-function-access
 283                   (slot-boundp-using-class class attribute property))
 284                 (with-function-access
 285                   (slot-value-using-class class attribute property))
 286                 (funcall fn layer (attribute-description attribute)))
 287             (funcall fn layer (attribute-description attribute))))))
 288
 289
 290
 291
 292
 293
 294 (defmethod print-object ((object standard-attribute) stream)
 295   (print-unreadable-object (object stream :type nil :identity t)
 296     (format stream "ATTRIBUTE ~A" (or (ignore-errors (attribute-name object)) "+unnamed-attribute+"))))
 297
 298 (defgeneric eval-property-initarg (att initarg)
 299   (:method ((attribute standard-attribute) initarg)
 300     nil)
 301   (:method ((attribute standard-attribute) (initarg (eql :function)))
 302     t)
 303   (:method ((attribute standard-attribute) (initarg (eql :value)))
 304     t))
 305
 306 (defun prepare-initargs (att args)
 307   (loop
 308      :for (key arg)
 309      :on args :by #'cddr
 310      :nconc (list key
 311                   (if (eval-property-initarg att key)
 312                       (eval arg)
 313                       arg))))
 314
 315
 316 (defun attribute-value* (attribute)
 317   (attribute-value *object* attribute))
 318
 319 (defmacro with-attributes (names description &body body)
 320   `(let ,(loop for name in names collect
 321               (list name `(find-attribute ,description ',name)))
 322      ,@body))q
 323
 324
 325
 326
 327
 328
 329
 330
 331
 332
 333
 334
 335