src/standard-descriptions/t.lisp

   1 (in-package :lisp-on-lines)
   2
   3 (define-description T ()
   4   ((label :label nil
   5           :function (lambda (object)
   6                       (format nil "~@(~A~)"
   7                               (substitute #\Space #\-
   8                                           (symbol-name
   9                                            (class-name (class-of
  10                                                         object)))))))
  11    (identity :label nil :function #'identity)
  12    (type :label "Type" :function #'type-of)
  13    (class :label "Class" :function #'class-of)
  14    (active-attributes :label "Attributes"
  15                       :value nil
  16                       :activep nil
  17                       :keyword :attributes)
  18    (attribute-delimiter :label "Attribute Delimiter"
  19                         :value "~%"
  20                         :activep nil
  21                         :keyword :delimter)
  22    (active-descriptions :label "Active Descriptions"
  23                         :value nil
  24                         :activep nil
  25                         :keyword :activate)
  26    (inactive-descriptions :label "Inactive Descriptions"
  27                           :value nil
  28                           :activep nil
  29                           :keyword :deactivate)
  30    (label-formatter :value (lambda (label)
  31                              (generic-format *display* "~A:" label))
  32                     :activep nil)
  33    (value-formatter :value (curry #'format nil "~A")
  34                     :activep nil)))
  35
  36 (define-layered-method description-of (any-lisp-object)
  37   (find-description 't))
  38
  39 (define-layered-function display-attribute (attribute)
  40   (:method (attribute)
  41     (display-using-description attribute *display* (attribute-object attribute))))
  42
  43
  44 (define-layered-function display-attribute-label (attribute)
  45   (:method (attribute)
  46     (funcall (attribute-label-formatter attribute) (attribute-label attribute))))
  47
  48
  49
  50
  51 (define-layered-function display-attribute-value (attribute)
  52   (:method (attribute)
  53     (flet ((disp (val &rest args)
  54              (apply #'display *display* val
  55                     :activate (attribute-active-descriptions attribute)
  56                     :deactivate (attribute-inactive-descriptions attribute)
  57                     args)))
  58
  59     (let ((val (attribute-value attribute)))
  60       (if (and (not (slot-boundp attribute 'active-attributes))
  61                (eql val (attribute-object attribute)))
  62           (generic-format *display* (funcall (attribute-value-formatter attribute) val))
  63           (with-active-descriptions (inline)
  64             (cond ((slot-value attribute 'value-formatter)
  65                    (generic-format *display* (funcall (attribute-value-formatter attribute) val)))
  66                    ((slot-boundp attribute 'active-attributes)
  67                     (disp val :attributes (slot-value attribute 'active-attributes)))
  68                    (t
  69                     (disp val)))))))))
  70
  71 (define-layered-method display-using-description
  72   ((attribute standard-attribute) display object &rest args)
  73   (declare (ignore args))
  74   (when (attribute-label attribute)
  75     (display-attribute-label attribute))
  76   (display-attribute-value attribute))
  77
  78 (define-layered-method display-attribute :around
  79   ((attribute standard-attribute))
  80     (funcall-with-layer-context
  81    (modify-layer-context (current-layer-context)
  82                          :activate (attribute-active-descriptions attribute)
  83                          :deactivate (attribute-inactive-descriptions attribute))
  84    (lambda ()
  85      (call-next-method))))
  86
  87 (define-layered-method display-attribute :before
  88   ((attribute standard-attribute))
  89 )
  90
  91 (define-display ((description t))
  92  (let ((attributes (attributes description)))
  93    (display-attribute (first attributes))
  94    (dolist (attribute (rest attributes) (values))
  95      (generic-format *display*
  96       (attribute-value
  97        (find-attribute description 'attribute-delimiter)))
  98      (display-attribute attribute))))
  99
 100
 101 (define-display :around ((description t) (display null) object)
 102  (with-output-to-string (*standard-output*)
 103    (call-next-layered-method description t object))
 104 )
 105
 106
 107
 108