src/standard-descriptions/t.lisp

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