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-layered-class slot-definition-attribute (standard-attribute)
  17  ((slot-name :initarg :slot-name
  18              :accessor attribute-slot-name
  19              :layered t)))
  20
  21 (defmethod shared-initialize :around ((object slot-definition-attribute)
  22                                       slots &rest args)
  23   (prog1 (call-next-method)
  24     (unless (attribute-setter object)
  25       (setf (attribute-setter object)
  26             (lambda (v o)
  27               (setf (slot-value o (attribute-slot-name object)) v))))))
  28
  29
  30 (define-layered-method attribute-value-using-object (object (attribute slot-definition-attribute))
  31   (if (slot-boundp object (attribute-slot-name attribute))
  32
  33       (slot-value object (attribute-slot-name attribute))
  34       +unbound-slot+))
  35
  36 (defun attribute-slot-makunbound (attribute)
  37   (slot-makunbound (attribute-object attribute) (attribute-slot-name attribute)))
  38
  39 (defun ensure-description-for-class (class &key attributes (name (intern (format nil "DESCRIPTION-FOR-~A" (class-name class))))
  40                                      direct-superclasses direct-slot-specs)
  41
  42   (let* ((super-descriptions
  43           (mapcar #'class-of
  44                               (delete nil (mapcar (rcurry #'find-description nil)
  45                                                   (mapcar #'class-name direct-superclasses)))))
  46          (desc-class
  47           (ensure-class (defining-description name)
  48                 :direct-superclasses (or super-descriptions (list (class-of (find-description 'standard-object))))
  49                 :direct-slots
  50                 (loop
  51                    :for slot in (class-slots class)
  52                    :collect
  53                    (let ((direct-spec
  54                           (find (slot-definition-name slot)
  55                                 direct-slot-specs
  56                                 :key (rcurry 'getf :name))))
  57                      (if direct-spec
  58                          (append (alexandria:remove-from-plist direct-spec
  59                                                                :initfunction
  60                                                                :initform
  61                                                                :initargs
  62                                                                :readers
  63                                                                :writers)
  64                                  (unless
  65                                      (getf direct-spec :attribute-class)
  66                                    (list :attribute-class 'slot-definition-attribute))
  67                                  (unless
  68                                      (getf direct-spec :label)
  69                                    (list :label (format nil
  70                                                         "~@(~A~)" (substitute #\Space #\- (symbol-name (slot-definition-name slot))))))
  71                                  (list :slot-name (slot-definition-name slot)))
  72                          `(:name ,(slot-definition-name slot)
  73                                  :attribute-class slot-definition-attribute
  74                                  :slot-name ,(slot-definition-name slot)
  75                                  :label ,(format nil
  76                                                  "~@(~A~)" (substitute #\Space #\- (symbol-name (slot-definition-name slot)))))))
  77                    :into slots
  78                                  :collect (slot-definition-name slot) :into names
  79                                  :finally (return (cons `(:name active-attributes
  80                                                           :value ',(or attributes names))
  81                                                         slots)))
  82                 :metaclass 'standard-description-class)))
  83     (unless (ignore-errors (find-description (class-name class)))
  84       (ensure-class (defining-description (class-name class))
  85                     :direct-superclasses (list desc-class)
  86                     :metaclass 'standard-description-class))
  87     (find-description name)))
  88
  89
  90 (defclass described-class ()
  91   ((direct-slot-specs :accessor class-direct-slot-specs)
  92    (attributes :initarg :attributes :initform nil)))
  93
  94 (defmethod ensure-class-using-class :around ((class described-class) name &rest args)
  95
  96   (call-next-method))
  97
  98 (defmethod direct-slot-definition-class ((class described-class) &rest initargs)
  99   (let ((slot-class (call-next-method)))
 100     (make-instance (class-of slot-class) :direct-superclasses (list slot-class (find-class 'described-class-direct-slot-definition)))))
 101
 102 (defclass described-class-direct-slot-definition ()
 103   ())
 104
 105 (defmethod shared-initialize :around ((class described-class-direct-slot-definition) slot-names &key &allow-other-keys)
 106   (call-next-method))
 107
 108 (defmethod validate-superclass
 109            ((class described-class)
 110             (superclass standard-class))
 111   t)
 112
 113 (defmethod initialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '()) direct-slots)
 114   (declare (dynamic-extent initargs))
 115   (finalize-inheritance class)
 116   (ensure-description-for-class class :direct-slot-specs direct-slots
 117                                       :direct-superclasses  direct-superclasses
 118                                       :attributes (slot-value class 'attributes)))
 119
 120 (defmethod reinitialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '()) direct-slots)
 121   (declare (dynamic-extent initargs))
 122   (finalize-inheritance class)
 123   (ensure-description-for-class class :direct-slot-specs direct-slots
 124                                       :direct-superclasses direct-superclasses
 125                                       :attributes (slot-value class 'attributes)))
 126
 127 (defclass described-standard-class (described-class standard-class ) ())
 128
 129 (defmethod validate-superclass
 130     ((class described-standard-class)
 131      (superclass standard-class))
 132   t)
 133
 134 (define-layered-method description-of ((object standard-object))
 135   (or (ignore-errors (find-description (class-name (class-of object))))
 136       (find-description 'standard-object)))
 137
 138
 139