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-active-p :around (attribute)
 138  (let ((active? (call-next-method)))
 139    (if (eq :when active?)
 140        (not (null (attribute-value attribute)))
 141        active?)))
 142
 143 (define-layered-method attribute-label-formatter :around (attribute)
 144    (or (slot-value attribute 'label-formatter)
 145        (attribute-value (find-attribute (attribute-description attribute) 'label-formatter))
 146        (error "No Formatter .. fool!")))
 147
 148 (define-layered-method attribute-value-formatter :around (attribute)
 149
 150    (or (slot-value attribute 'value-formatter)
 151        (attribute-value (find-attribute (attribute-description attribute) 'value-formatter))
 152        (error "No Formatter .. fool!")))
 153
 154
 155
 156 (define-layered-method attribute-object ((attribute standard-attribute))
 157  (if (slot-boundp attribute 'object)
 158      (call-next-method)
 159      (described-object (attribute-description attribute))))
 160
 161
 162 (define-layered-function attribute-value-using-object (object attribute))
 163 (define-layered-function (setf attribute-value-using-object) (value object attribute))
 164
 165 (define-layered-method attribute-value ((attribute standard-attribute))
 166  (attribute-value-using-object (attribute-object attribute) attribute))
 167
 168 (define-layered-method attribute-value-using-object (object attribute)
 169  (let ((fn (handler-case (attribute-function attribute)
 170              (unbound-slot () nil))))
 171    (if fn
 172        (funcall fn object)
 173        (slot-value attribute 'value))))
 174
 175 (define-layered-method (setf attribute-value) (value (attribute standard-attribute))
 176  (setf (attribute-value-using-object (attribute-object attribute) attribute) value))
 177
 178 (define-layered-method (setf attribute-value-using-object) (value object attribute)
 179  (error "No (SETF ATTRIBUTE-VALUE-USING-OBJECT) for ~A ~A and we are not editable"
 180         object attribute))
 181
 182
 183 (defun ensure-access-function (class attribute property)
 184   (with-function-access
 185     (if (slot-definition-specialp property)
 186         (let ((slot-symbol
 187                (with-symbol-access
 188                  (slot-value-using-class
 189                   class attribute property))))
 190           (if (fboundp slot-symbol)
 191               (symbol-function slot-symbol)
 192               (setf (symbol-function slot-symbol)
 193                     (property-access-function
 194                      (attribute-description attribute)
 195                      (attribute-name attribute)
 196                      (slot-definition-name property)))))
 197         (if (slot-boundp-using-class class attribute property)
 198             (slot-value-using-class class attribute property)
 199             (setf (slot-value-using-class class attribute property)
 200                   (property-access-function
 201                    (attribute-description attribute)
 202                    (attribute-name attribute)
 203                    (slot-definition-name property)))))))
 204
 205 (define-layered-method slot-boundp-using-layer
 206   :in-layer (layer t)
 207   :around (class (attribute standard-attribute) property reader)
 208
 209 ; (dprint "Checking boundp ~A ~A" (attribute-name attribute)
 210         ; (slot-definition-name property))
 211
 212   (if (or *symbol-access* *function-access*)
 213       (call-next-method)
 214       (or (when (slot-definition-specialp property)
 215             (with-function-access
 216            (slot-boundp-using-class class attribute property)))
 217           (if (generic-function-methods
 218                (ensure-access-function class attribute property))
 219               T
 220               NIL))))
 221
 222 (define-layered-method (setf slot-value-using-layer)
 223   :in-layer (context t)
 224   :around
 225   (new-value class (attribute standard-attribute) property writer)
 226
 227 ;;  (dprint "Setting ~A ~A to : ~A" attribute property new-value)
 228
 229   (if (or *symbol-access* *function-access*)
 230       (call-next-method)
 231
 232       (if (and (slot-definition-specialp property)
 233                (with-function-access
 234                  (without-symbol-access (slot-boundp-using-class class attribute property))))
 235           (with-function-access
 236             (call-next-method))
 237           (let ((layer
 238                  ;;FIXME: this is wrong for so many reasons
 239                  (find-layer (first (remove nil (closer-mop::class-precedence-list (class-of context))
 240                                             :key #'class-name))))
 241                 (boundp (slot-boundp-using-class class attribute property))
 242                 (fn  (ensure-access-function class attribute property)))
 243
 244             (when (not boundp)
 245               ;; * This slot has never been set before.
 246               ;; create a method on property-accessor-function
 247               ;; so subclasses can see this new property.
 248               (ensure-layered-method
 249                (layered-function-definer 'property-access-function)
 250                `(lambda (description attribute property)
 251                   (declare (ignore description attribute property))
 252                   ,fn)
 253                :in-layer layer
 254                :specializers
 255                (list (class-of
 256                       (attribute-description attribute))
 257                      (closer-mop:intern-eql-specializer
 258                       (attribute-name attribute))
 259                      (closer-mop:intern-eql-specializer
 260                       (closer-mop:slot-definition-name property)))))
 261
 262             ;; specialize this property to this description.
 263             ;;(dprint "actrually specializering")
 264             (ensure-layered-method
 265              fn
 266              `(lambda (description)
 267                 (funcall ,(lambda()
 268                                  new-value)))
 269              :in-layer layer
 270              :specializers (list (class-of (attribute-description attribute))))
 271
 272             ;;  and return the set value as is custom
 273             new-value))))
 274
 275 (define-layered-method slot-value-using-layer
 276   :in-layer (layer t)
 277   :around (class (attribute standard-attribute) property reader)
 278
 279 ;  ;(dprint "Getting the slot value of ~A" property)
 280   (if (or *symbol-access* *function-access*)
 281       (call-next-method)
 282       (let ((fn (ensure-access-function class attribute property)))
 283
 284         (unless (slot-boundp-using-class class attribute property)
 285           (slot-unbound class attribute (slot-definition-name property)))
 286
 287         (if (slot-definition-specialp property)
 288             (if (with-function-access
 289                   (slot-boundp-using-class class attribute property))
 290                 (with-function-access
 291                   (slot-value-using-class class attribute property))
 292                 (funcall fn layer (attribute-description attribute)))
 293             (handler-case (funcall fn layer (attribute-description attribute))
 294               (error ()
 295                 (warn "Error calling ~A" fn)))))))
 296
 297
 298
 299
 300
 301
 302 (defmethod print-object ((object standard-attribute) stream)
 303   (print-unreadable-object (object stream :type nil :identity t)
 304     (format stream "ATTRIBUTE ~A" (or (ignore-errors (attribute-name object)) "+unnamed-attribute+"))))
 305
 306 (defgeneric eval-property-initarg (att initarg)
 307   (:method ((attribute standard-attribute) initarg)
 308     nil)
 309   (:method ((attribute standard-attribute) (initarg (eql :function)))
 310     t)
 311   (:method ((attribute standard-attribute) (initarg (eql :value)))
 312     t))
 313
 314 (defun prepare-initargs (att args)
 315   (loop
 316      :for (key arg)
 317      :on args :by #'cddr
 318      :nconc (list key
 319                   (if (eval-property-initarg att key)
 320                       (eval arg)
 321                       arg))))
 322
 323
 324 (defun attribute-value* (attribute)
 325   (attribute-value *object* attribute))
 326
 327 (defmacro with-attributes (names description &body body)
 328   `(let ,(loop for name in names collect
 329               (list name `(find-attribute ,description ',name)))
 330      ,@body))
 331
 332
 333
 334
 335
 336
 337
 338
 339
 340
 341
 342
 343