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 (define-layered-function display-attribute-label (attribute)
  44   (:method (attribute)
  45     (funcall (attribute-label-formatter attribute) (attribute-label attribute))))
  46
  47
  48
  49 (define-layered-function display-attribute-value (attribute)
  50   (:method (attribute)
  51     (flet ((disp (val &rest args)
  52              (apply #'display *display* val
  53                     :activate (attribute-active-descriptions attribute)
  54                     :deactivate (attribute-inactive-descriptions attribute)
  55                     args)))
  56
  57     (let ((val (attribute-value attribute)))
  58       (if (eql val (attribute-object attribute))
  59           (generic-format *display* (funcall (attribute-value-formatter attribute) val))
  60           (with-active-descriptions (inline)
  61             (if (slot-boundp attribute 'active-attributes)
  62                 (disp val :attributes (slot-value attribute 'active-attributes))
  63                 (disp val))))))))
  64
  65 (define-layered-method display-using-description
  66   ((attribute standard-attribute) display object &rest args)
  67   (declare (ignore args))
  68   (when (attribute-label attribute)
  69     (display-attribute-label attribute))
  70   (display-attribute-value attribute))
  71
  72 (define-display ((description t))
  73  (let ((attributes (attributes description)))
  74    (display-attribute (first attributes))
  75    (dolist (attribute (rest attributes) (values))
  76      (generic-format *display*
  77       (attribute-value
  78        (find-attribute description 'attribute-delimiter)))
  79      (display-attribute attribute))))
  80
  81
  82 (define-display :around ((description t) (display null) object)
  83  (with-output-to-string (*standard-output*)
  84    (call-next-layered-method description t object))
  85 )
  86
  87
  88
  89