src/mao/display/display-description.lisp

   1 (in-package :lisp-on-lines)
   2
   3 (defclass display-description-class (standard-description-class)
   4   ())
   5
   6 (defmethod description-class-attribute-class ((class display-description-class))
   7   'display-attribute)
   8
   9 (defun label-for-object (object)
  10   (format nil "~@(~A~)"
  11           (substitute #\Space #\-
  12                       (symbol-name
  13                        (class-name (class-of
  14                                     object))))))
  15 #+nil(defdescription t ()
  16   ((label :label nil
  17           :function label-for-object)
  18    (identity :label nil :function identity)
  19    (type :label "Type" :function type-of)
  20    (class :label "Class" :function class-of)
  21    (attribute-delimiter :label "Attribute Delimiter"
  22                         :value "~%"
  23                         :activep nil
  24                         :keyword :delimter)
  25
  26    (label-formatter :value princ-to-string
  27                     :activep nil)
  28    (value-formatter :value princ-to-string
  29                     :activep nil))
  30   (:metaclass standard-description-class))
  31
  32 #+nil(defmethod initialize-instance :around ((class display-description-class) &rest initargs &key (direct-superclasses '()))
  33   (declare (dynamic-extent initargs))
  34   (prog1
  35       (if (loop for direct-superclass in direct-superclasses
  36                 thereis (ignore-errors (subtypep direct-superclass (class-of (find-description t)))))
  37         (call-next-method)
  38         (apply #'call-next-method
  39                class
  40                :direct-superclasses
  41                (append direct-superclasses
  42                        (list (class-of (find-description 't))))
  43                initargs))))
  44
  45
  46 #+nil(defmethod reinitialize-instance :around ((class display-description-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p))
  47   (declare (dynamic-extent initargs))
  48 ;  (warn "CLASS ~A ARGS ~A:" class initargs)
  49   (prog1
  50       (if (or (not direct-superclasses-p)
  51                 (loop for direct-superclass in direct-superclasses
  52                       thereis (ignore-errors (subtypep direct-superclass (class-of (find-description t))))))
  53           (call-next-method)
  54           (apply #'call-next-method
  55                  class
  56                  :direct-superclasses
  57                  (append direct-superclasses
  58                          (list (class-of (find-description 't))))
  59                  initargs))))