src/new-description.lisp

   1 (in-package :lisp-on-lines)
   2
   3 (setf (find-class 'simple-attribute nil) nil)
   4
   5 (define-layered-class simple-attribute ()
   6   ((%property-access-function
   7     :initarg property-access-function)))
   8
   9 (defun ensure-property-access-function (attribute)
  10   (if (slot-boundp attribute '%property-access-function)
  11       (slot-value attribute '%property-access-function)
  12       (let ((fn-name (gensym)))
  13         (ensure-layered-function fn-name :lambda-list '() :method-combination '(append))
  14         (setf (slot-value attribute '%property-access-function) fn-name))))
  15
  16 (defconstant +property-not-found+ '=lisp-on-lines-property-not-found-indicator=)
  17
  18 (define-layered-method
  19     contextl:slot-value-using-layer (class (attribute simple-attribute) slotd reader)
  20   (if (or *symbol-access*
  21           (eq (slot-definition-name slotd)
  22               '%property-access-function)
  23           (not (slot-definition-layeredp slotd)))
  24       (call-next-method)
  25       (let ((value (getf (funcall (ensure-property-access-function attribute))
  26                          (slot-definition-name slotd)
  27                          +property-not-found+)))
  28         (if (eq value +property-not-found+)
  29             (call-next-method)
  30             value))))
  31
  32 (defvar *test-attribute-definitions*
  33   `((t :label "foo" :value "foo")
  34     (simple-test-layer :label "BAZ" :value "BAZ")))
  35
  36 (defmethod initialize-attribute-for-layer (attribute layer-name &rest args)
  37   (let* ((class (class-of attribute))
  38          (slotds (class-slots class)))
  39
  40     (ensure-layered-method
  41      (ensure-property-access-function attribute)
  42      `(lambda ()
  43         ',(loop
  44                      :for (key val) :on args :by #'cddr
  45                      :nconc (list
  46                              (loop :for slotd :in slotds
  47                                 :do (when (find key (slot-definition-initargs slotd))
  48                                       (return  (slot-definition-name slotd))))
  49                              val)))
  50      :qualifiers '(append)
  51      :in-layer layer-name)))
  52
  53
  54
  55 (define-layered-class simple-standard-attribute (simple-attribute)
  56  ((label
  57    :layered-accessor attribute-label
  58    :initarg :label
  59    :initform nil
  60    :layered t
  61    :special t)
  62   (label-formatter
  63    :layered-accessor attribute-label-formatter
  64    :initarg :label-formatter
  65    :initform  nil
  66    :layered t
  67    :special t)
  68   (function
  69    :initarg :function
  70    :layered-accessor attribute-function
  71    :layered t
  72    :special t)
  73   (value
  74    :layered-accessor attribute-value
  75    :initarg :value
  76    :layered t
  77    :special t)
  78   (value-formatter
  79    :layered-accessor attribute-value-formatter
  80    :initarg :value-formatter
  81    :initform nil
  82    :layered t
  83    :special t)
  84   (activep
  85    :layered-accessor attribute-active-p
  86    :initarg :active
  87    :initform t
  88    :layered t
  89    :special t
  90    :documentation
  91    "Can be T, NIL or :WHEN. In the latter case, attribute is only active if the attribute value is non-null.")
  92   (active-attributes :layered-accessor attribute-active-attributes
  93                        :initarg :attributes
  94                        :layered t
  95                        :special t)
  96   (active-descriptions :layered-accessor attribute-active-descriptions
  97                        :initarg :activate
  98                        :initform nil
  99                        :layered t
 100                        :special t)
 101   (inactive-descriptions :layered-accessor attribute-inactive-descriptions
 102                        :initarg :deactivate
 103                        :initform nil
 104                        :layered t
 105                        :special t)))
 106
 107
 108 (define-layered-class direct-attribute-slot-definition-class
 109   (special-layered-direct-slot-definition
 110    contextl::singleton-direct-slot-definition)
 111   ((attribuite-properties
 112     :accessor slot-definition-attribute-properties
 113     :documentation "Holds the initargs passed to the slotd")))
 114
 115 (defmethod initialize-instance
 116     :after ((slotd direct-attribute-slot-definition-class)
 117             &rest initargs)
 118   (setf (slot-definition-attribute-properties slotd) initargs))
 119
 120 (defmethod reinitialize-instance
 121     :after ((slotd direct-attribute-slot-definition-class)
 122             &rest initargs)
 123   (setf (slot-definition-attribute-properties slotd) initargs))
 124
 125 (define-layered-class effective-attribute-slot-definition-class
 126     (special-layered-effective-slot-definition)
 127     ((attribute-object
 128       :accessor slot-definition-attribute-object)))
 129
 130 (define-layered-class description-access-class (standard-layer-class contextl::special-layered-access-class)
 131   ((defined-in-descriptions :initarg :in-description)
 132    (class-active-attributes-definition :initarg :attributes)
 133    (mixin-class-p :initarg :mixinp)))
 134
 135 (defmethod direct-slot-definition-class
 136            ((class description-access-class) &key &allow-other-keys)
 137   (find-class 'direct-attribute-slot-definition-class))
 138
 139 (defmethod effective-slot-definition-class
 140            ((class description-access-class) &key &allow-other-keys)
 141   (find-class 'effective-attribute-slot-definition-class))
 142 (fmakunbound 'initialize-slot-definition-attribute)
 143 (defmethod initialize-slot-definition-attribute ((slotd effective-attribute-slot-definition-class) name direct-slot-definitions)
 144   (let ((tbl (make-hash-table))
 145         (attribute (make-instance 'simple-standard-attribute :name name)))
 146     (loop for ds in direct-slot-definitions
 147        :do (setf (gethash (slot-definition-layer ds) tbl)
 148                  (append (gethash (slot-definition-layer ds) tbl '())
 149                          (slot-definition-attribute-properties ds))))
 150     (maphash (lambda (layer properties)
 151                (apply #'initialize-attribute-for-layer attribute layer properties))
 152              tbl)
 153     (setf (slot-definition-attribute-object slotd) attribute)))
 154
 155 (defmethod compute-effective-slot-definition
 156            ((class description-access-class) name direct-slot-definitions)
 157   (declare (ignore name))
 158   (let ((slotd (call-next-method)))
 159     (initialize-slot-definition-attribute slotd)
 160     slotd))
 161
 162 (defclass standard-description-class (description-access-class layered-class)
 163   ((attributes :accessor description-class-attributes :initform (list)))
 164   (:default-initargs :defining-metaclass 'description-access-class))
 165
 166 (defmethod validate-superclass
 167            ((class standard-description-class)
 168             (superclass standard-class))
 169   t)
 170
 171 (define-layered-class standard-description-object (standard-layer-object)
 172   ((described-object :accessor described-object
 173                      :special t)))
 174
 175 (defun initialize-description-class-attribute (description attribute initargs)
 176   )
 177
 178 (defmethod initialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '()))
 179   (declare (dynamic-extent initargs))
 180   (prog1
 181       (if (loop for direct-superclass in direct-superclasses
 182                 thereis (ignore-errors (subtypep direct-superclass 'standard-description-object)))
 183         (call-next-method)
 184         (apply #'call-next-method
 185                class
 186                :direct-superclasses
 187                (append direct-superclasses
 188                        (list (find-class 'standard-description-object)))
 189                initargs))
 190     (break "initializing ~A ~A" class initargs)))
 191
 192
 193 (defmethod reinitialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p))
 194   (declare (dynamic-extent initargs))
 195 ;  (warn "CLASS ~A ARGS ~A:" class initargs)
 196   (prog1
 197       (if (or (not direct-superclasses-p)
 198                 (loop for direct-superclass in direct-superclasses
 199                       thereis (ignore-errors (subtypep direct-superclass 'standard-description-object))))
 200           (call-next-method)
 201           (apply #'call-next-method
 202                  class
 203                  :direct-superclasses
 204                  (append direct-superclasses
 205                          (list (find-class 'standard-description-object)))
 206                  initargs))
 207     (break "RE-initializing ~A ~A" class initargs)))
 208
 209 (defmethod finalize-inheritance :after ((class standard-description-class))
 210   (break "Finalizing ~S" (class-name  class)))
 211
 212 ;;;; A simpler implementation of descriptions based on plists
 213
 214
 215