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
  57     (let ((val (attribute-value attribute)))
  58 #+nil            (break "display Attribute value: ~A with object ~A ~% Description ~A att-d ~A ~% VALUE ~A display on ~A"
  59                          attribute
  60                          (attribute-object attribute)
  61                          *description*
  62                          (attribute-description attribute)
  63                          val
  64                          *display*
  65                          )
  66       (if (and (not (slot-boundp attribute 'active-attributes))
  67                (equal val (attribute-object attribute)))
  68           (progn (generic-format *display* "~A"(funcall (attribute-value-formatter attribute) val))
  69                  #+nil(break "using generic format because val is object and there is no active attributes."))
  70
  71           (with-active-descriptions (inline)
  72             (cond ((slot-value attribute 'value-formatter)
  73                    (generic-format *display* "~A"(funcall (attribute-value-formatter attribute) val)))
  74                    ((slot-boundp attribute 'active-attributes)
  75                     (disp val :attributes (slot-value attribute 'active-attributes)))
  76                    (t
  77                     (disp val)))))))))
  78
  79 (define-layered-method display-using-description
  80   ((attribute standard-attribute) display object &rest args)
  81   (declare (ignore args))
  82   (when (attribute-label attribute)
  83     (display-attribute-label attribute))
  84   (display-attribute-value attribute))
  85
  86 (define-layered-method display-attribute :around
  87   ((attribute standard-attribute))
  88     (funcall-with-layer-context
  89    (modify-layer-context (current-layer-context)
  90                          :activate (attribute-active-descriptions attribute)
  91                          :deactivate (attribute-inactive-descriptions attribute))
  92    (lambda ()
  93      (call-next-method))))
  94
  95 (define-layered-method display-attribute :before
  96   ((attribute standard-attribute))
  97 #+nil  (break "Attribute : ~A with object ~A ~% Description ~A att-d ~A"
  98          attribute
  99          (attribute-object attribute)
 100          *description*
 101          (attribute-description attribute)
 102 ))
 103
 104 (define-display ((description t))
 105  (let ((attributes (attributes description)))
 106    (display-attribute (first attributes))
 107    (dolist (attribute (rest attributes) (values))
 108      (generic-format *display*
 109       (attribute-value
 110        (find-attribute description 'attribute-delimiter)))
 111      (display-attribute attribute))))
 112
 113
 114 (define-display :around ((description t) (display null) object)
 115  (with-output-to-string (*standard-output*)
 116    (call-next-layered-method description t object))
 117 )
 118
 119
 120
 121