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 (define-layered-function display-attribute-value (attribute)
  49   (:method (attribute)
  50     (flet ((disp (val &rest args)
  51              (apply #'display *display* val
  52                     :activate (attribute-active-descriptions attribute)
  53                     :deactivate (attribute-inactive-descriptions attribute)
  54                     args)))
  55
  56     (let ((val (attribute-value attribute)))
  57       (if (and (not (slot-boundp attribute 'active-attributes))
  58                (eql val (attribute-object attribute)))
  59           (generic-format *display* (funcall (attribute-value-formatter attribute) val))
  60           (with-active-descriptions (inline)
  61             (cond ((slot-value attribute 'value-formatter)
  62                    (generic-format *display* (funcall (attribute-value-formatter attribute) val)))
  63                    ((slot-boundp attribute 'active-attributes)
  64                     (disp val :attributes (slot-value attribute 'active-attributes)))
  65                    (t
  66                     (disp val)))))))))
  67
  68 (define-layered-method display-using-description
  69   ((attribute standard-attribute) display object &rest args)
  70   (declare (ignore args))
  71   (when (attribute-label attribute)
  72     (display-attribute-label attribute))
  73   (display-attribute-value attribute))
  74
  75 (define-layered-method display-attribute :around
  76   ((attribute standard-attribute))
  77     (funcall-with-layer-context
  78    (modify-layer-context (current-layer-context)
  79                          :activate (attribute-active-descriptions attribute)
  80                          :deactivate (attribute-inactive-descriptions attribute))
  81    (lambda ()
  82      (call-next-method))))
  83
  84 (define-layered-method display-attribute :before
  85   ((attribute standard-attribute))
  86 )
  87
  88 (define-display ((description t))
  89  (let ((attributes (attributes description)))
  90    (display-attribute (first attributes))
  91    (dolist (attribute (rest attributes) (values))
  92      (generic-format *display*
  93       (attribute-value
  94        (find-attribute description 'attribute-delimiter)))
  95      (display-attribute attribute))))
  96
  97
  98 (define-display :around ((description t) (display null) object)
  99  (with-output-to-string (*standard-output*)
 100    (call-next-layered-method description t object))
 101 )
 102
 103
 104
 105