src/standard-descriptions/clos.lisp

   1 (in-package :lisp-on-lines)
   2
   3 (defstruct unbound-slot-value (s))
   4
   5 (defvar +unbound-slot+ (make-unbound-slot-value))
   6
   7 (defmethod print-object ((object unbound-slot-value) stream)
   8   (print-unreadable-object (object stream)
   9     (format stream "UNBOUND")))
  10
  11 (define-description standard-object ()
  12   ((editp :value t)
  13    (class-slots :label "Slots"
  14                 :function (compose 'class-slots 'class-of))))
  15
  16 (define-description standard-object ()
  17   ((editp :value t)
  18    (class-slots :label "Slots"
  19                 :function (compose 'class-slots 'class-of)))
  20   (:in-description editable))
  21
  22 (define-layered-class slot-definition-attribute (define-description-attribute)
  23  ((slot-name :initarg :slot-name
  24              :accessor attribute-slot-name
  25              :layered t)))
  26
  27
  28 (define-layered-method attribute-active-p :around ((attribute slot-definition-attribute))
  29  (let ((active? (slot-value attribute 'activep)))
  30    (if (and (eq :when active?)
  31             (unbound-slot-value-p (attribute-value attribute)))
  32        NIL
  33
  34        (call-next-method))))
  35
  36 (define-layered-method attribute-active-p
  37  :in-layer #.(defining-description 'editable)
  38  :around ((attribute slot-definition-attribute))
  39  (let ((active? (slot-value attribute 'activep)))
  40    (if (and (eq :when active?)
  41             (unbound-slot-value-p (attribute-value attribute)))
  42        t
  43        (call-next-method))))
  44
  45 (defmethod shared-initialize :around ((object slot-definition-attribute)
  46                                       slots &rest args)
  47   (with-active-descriptions (editable)
  48     (prog1 (call-next-method)
  49       (unless (attribute-setter object)
  50         (setf (attribute-setter object)
  51               (lambda (v o)
  52                 (if (unbound-slot-value-p v)
  53                     (slot-makunbound o (attribute-slot-name object))
  54                     (setf (slot-value o (attribute-slot-name object)) v))))))))
  55
  56
  57 (define-layered-method attribute-value-using-object (object (attribute slot-definition-attribute))
  58   (if (slot-boundp object (attribute-slot-name attribute))
  59
  60       (slot-value object (attribute-slot-name attribute))
  61       +unbound-slot+))
  62
  63 (defun attribute-slot-makunbound (attribute)
  64   (slot-makunbound (attribute-object attribute) (attribute-slot-name attribute)))
  65
  66 (defun ensure-description-for-class (class &key attributes (name (intern (format nil "DESCRIPTION-FOR-~A" (class-name class))))
  67                                      direct-superclasses direct-slot-specs)
  68
  69   (let* ((super-descriptions
  70           (mapcar #'class-of
  71                               (delete nil (mapcar (rcurry #'find-description nil)
  72                                                   (mapcar #'class-name direct-superclasses)))))
  73          (desc-class
  74           (ensure-layer (defining-description name)
  75                 :direct-superclasses (or super-descriptions (list (class-of (find-description 'standard-object))))
  76                 :direct-slots
  77                 (loop
  78                    :for slot in (class-slots class)
  79                    :collect
  80                    (let ((direct-spec
  81                           (find (slot-definition-name slot)
  82                                 direct-slot-specs
  83                                 :key (rcurry 'getf :name))))
  84                      (if direct-spec
  85                          (append (alexandria:remove-from-plist direct-spec
  86                                                                :initfunction
  87                                                                :initform
  88                                                                :initargs
  89                                                                :readers
  90                                                                :writers)
  91                                  (unless
  92                                      (getf direct-spec :attribute-class)
  93                                    (list :attribute-class 'slot-definition-attribute))
  94                                  (unless
  95                                      (getf direct-spec :label)
  96                                    (list :label (format nil
  97                                                         "~@(~A~)" (substitute #\Space #\- (symbol-name (slot-definition-name slot))))))
  98                                  (list :slot-name (slot-definition-name slot)))
  99                          `(:name ,(slot-definition-name slot)
 100                                  :attribute-class slot-definition-attribute
 101                                  :slot-name ,(slot-definition-name slot)
 102                                  :label ,(format nil
 103                                                  "~@(~A~)" (substitute #\Space #\- (symbol-name (slot-definition-name slot)))))))
 104                    :into slots
 105                                  :collect (slot-definition-name slot) :into names
 106                                  :finally (return (cons `(:name active-attributes
 107                                                           :value ',(or attributes names))
 108                                                         slots)))
 109                 :metaclass 'define-description-class)))
 110     (unless (ignore-errors (find-description (class-name class)))
 111       (find-layer  (ensure-layer (defining-description (class-name class))
 112                                  :direct-superclasses (list desc-class)
 113                                  :metaclass 'define-description-class)))))
 114
 115
 116 (defclass described-class ()
 117   ((direct-slot-specs :accessor class-direct-slot-specs)
 118    (attributes :initarg :attributes :initform nil)))
 119
 120 (defmethod ensure-class-using-class :around ((class described-class) name &rest args)
 121
 122   (call-next-method))
 123
 124 (defmethod direct-slot-definition-class ((class described-class) &rest initargs)
 125   (let ((slot-class (call-next-method)))
 126     (make-instance (class-of slot-class) :direct-superclasses (list slot-class (find-class 'described-class-direct-slot-definition)))))
 127
 128 (defclass described-class-direct-slot-definition ()
 129   ())
 130
 131 (defmethod shared-initialize :around ((class described-class-direct-slot-definition) slot-names &key &allow-other-keys)
 132   (call-next-method))
 133
 134 (defmethod validate-superclass
 135            ((class described-class)
 136             (superclass standard-class))
 137   t)
 138
 139 (defmethod initialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '()) direct-slots)
 140   (declare (dynamic-extent initargs))
 141   (finalize-inheritance class)
 142   (ensure-description-for-class class :direct-slot-specs direct-slots
 143                                       :direct-superclasses  direct-superclasses
 144                                       :attributes (slot-value class 'attributes)))
 145
 146 (defmethod reinitialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '()) direct-slots)
 147   (declare (dynamic-extent initargs))
 148   (finalize-inheritance class)
 149   (ensure-description-for-class class :direct-slot-specs direct-slots
 150                                       :direct-superclasses direct-superclasses
 151                                       :attributes (slot-value class 'attributes)))
 152
 153 (defclass described-standard-class (described-class standard-class ) ())
 154
 155 (defmethod validate-superclass
 156     ((class described-standard-class)
 157      (superclass standard-class))
 158   t)
 159
 160 (define-layered-method description-of ((object standard-object))
 161   (or (ignore-errors (find-description (class-name (class-of object))))
 162       (find-description 'standard-object)))
 163
 164
 165