src/attribute.lisp

   1 (in-package :lisp-on-lines)
   2
   3
   4 (define-layered-class attribute ()
   5   ())
   6
   7 (defgeneric eval-attribute-initarg (attribute initarg)
   8   (:method (a i)
   9     nil))
  10
  11 (defmethod eval-attribute-initarg (attribute (initarg (eql :function)))
  12   t)
  13
  14 (define-layered-function attribute-value (object attribute))
  15
  16 (define-layered-method attribute-value (object attribute)
  17  (funcall (attribute-function attribute) object))
  18
  19 (deflayer LISP-ON-LINES)
  20 (ensure-active-layer 'lisp-on-lines)
  21
  22 (defvar *standard-direct-slot-initarg-symbols*
  23     '(:layered :class :in-layer :name :readers :writers :initargs :allow-other-keys :special))
  24
  25 (define-layered-function special-slot-values (description slot-name)
  26   (:method-combination append))
  27
  28 (define-layered-class attribute-special-layered-direct-slot-definition
  29   (attribute contextl::special-layered-direct-slot-definition)
  30   (initargs))
  31
  32 (defmethod shared-initialize :around ((instance attribute-special-layered-direct-slot-definition) slots &rest initargs )
  33   (setf (slot-value instance 'initargs) (apply #'arnesi:remove-keywords initargs *standard-direct-slot-initarg-symbols*))
  34   (call-next-method))
  35
  36 (define-layered-class standard-attribute
  37   (attribute contextl::layered-effective-slot-definition-in-layers)
  38   ((direct-slots)
  39    (description
  40     :layered-accessor description-of)
  41    (label
  42     :initarg :label
  43     :layered-accessor attribute-label
  44     :layered t
  45     :initform nil)
  46    (function
  47     :initarg :function
  48     :layered-accessor attribute-function
  49     :layered t)
  50    (value
  51     :initarg :value
  52     :layered t)))
  53
  54 (defmethod shared-initialize :around ((attribute standard-attribute) slots &rest initargs)
  55   (declare (ignore initargs))
  56     (setf (attribute-function attribute)
  57         (lambda (object)
  58           (slot-value attribute 'value)))
  59   (call-next-method))
  60
  61 (defun attribute-name (attribute)
  62   (closer-mop:slot-definition-name attribute))
  63
  64 (define-layered-method slot-value-using-layer
  65 ;  :in-layer lisp-on-lines
  66   :around (class (attribute standard-attribute) slot reader)
  67   (loop for (key var) on (special-slot-values (slot-value attribute 'description)
  68                                                      (attribute-name attribute))
  69               :if (eq (closer-mop:slot-definition-name slot) key)
  70               :do (return-from slot-value-using-layer var))
  71   (call-next-method))
  72
  73 (define-layered-method display-using-description
  74   ((attribute standard-attribute) display object &rest args)
  75  (declare (ignore args))
  76  (format display "~@[~A ~]~A" (attribute-label attribute)
  77          (display display (attribute-value object attribute))))
  78
  79
  80
  81
  82
  83
  84
  85
  86