src/standard-display.lisp

   1 (in-package :lisp-on-lines)
   2
   3 ;;;; The Standard Layers
   4 (deflayer viewer)
   5 (deflayer editor)
   6
   7 (define-layered-method label (anything)
   8   nil)
   9
  10 (defdisplay
  11     :in-layer editor :around (description object)
  12   "It is useful to remove the viewer layer when in the editing layer.
  13 This allows us to dispatch to a subclasses editor."
  14   (with-inactive-layers (viewer)
  15     (call-next-method)))
  16
  17 ;;;; These layers affect the layout of the object
  18 (deflayer one-line)
  19 (deflayer as-table)
  20 (deflayer as-string)
  21
  22 (defdisplay
  23   :in-layer as-string (d o)
  24   (with-inactive-layers (editor viewer one-line as-table show-attribute-labels)
  25     (do-attributes (a d)
  26       (display-attribute a o)
  27       (<:as-is " "))))
  28
  29 (defmethod list-slots (thing)
  30   (list 'identity))
  31
  32 ;;;; * Object displays.
  33
  34
  35
  36 ;;;; TODO: all lisp types should have occurences and attributes defined for them.
  37
  38 (defdisplay ((description t) lisp-value)
  39   (<:as-html lisp-value))
  40
  41 (defdisplay (description (object string))
  42   (<:as-html object))
  43
  44 (defdisplay (description (object symbol))
  45   (<:as-html object))
  46
  47 (defdisplay (description object (component t))
  48   "The default display for CLOS objects"
  49   (print (class-name (class-of object)))
  50   (dolist* (slot-name (list-slots object))
  51
  52     (let ((boundp (slot-boundp object slot-name)))
  53       (format t "~A~A : ~A" (strcat slot-name)
  54               (if boundp
  55                   ""
  56                   "(unbound)")
  57               (if boundp
  58                   (slot-value object slot-name) "")))))
  59
  60 (defdisplay ((description t) object)
  61   "The default display for CLOS objects in UCW components"
  62    (dolist* (slot-name (list-slots object))
  63
  64       (let ((boundp (slot-boundp object slot-name)))
  65         (<:label :class "lol-label"
  66                  (display-attribute 'label  (strcat slot-name))
  67         (if boundp
  68             ""
  69             "(unbound)"))
  70       (<:as-html
  71        (if boundp
  72            (slot-value object slot-name) "")))))
  73
  74 ;;;; ** The default displays for objects with a MEWA occurence
  75
  76 (defdisplay (description object)
  77  (<:div
  78   :class "lol-display"
  79   (when (label description)
  80     (<:span
  81      :class "title"
  82      (<:as-html (label description))))
  83   (do-attributes (attribute description)
  84     (<:div
  85      :class "attribute"
  86      (display-attribute attribute object)))))
  87
  88 ;;;; ** One line
  89 (defdisplay
  90   :in-layer one-line (description object)
  91   "The one line presentation just displays the attributes with a #\Space between them"
  92   (do-attributes (attribute description)
  93     (display-attribute attribute object)
  94     (<:as-html " ")))
  95
  96 ;;;; ** as-table
  97
  98 (defdisplay :in-layer as-table (description object)
  99   (<:table
 100    (do-attributes (a description)
 101      (<:tr
 102       (<:td  :class "lol-label" (<:as-html (label a)))
 103       (<:td (display-attribute a object))))))
 104
 105 ;;;; List Displays
 106
 107 (deflayer list-display-layer)
 108
 109 (define-layered-class description
 110   :in-layer list-display-layer ()
 111   ((list-item :initarg :list-item :initform nil :special t :accessor list-item)))
 112
 113 (defdisplay (desc (list list))
 114  (with-active-layers (list-display-layer)
 115    (<:ul
 116     (dolist* (item list)
 117       (<:li  (apply #'display* item (list-item desc)))))))
 118
 119 ;;;; Attributes
 120 (defdisplay
 121     :in-layer editor
 122     ((attribute standard-attribute) object)
 123     (call-next-method))
 124
 125 (define-layered-method display-using-description
 126   ((attribute standard-attribute) object component)
 127   (with-component (component)
 128     (<ucw:a :action (call 'info-message :message (strcat (symbol-package (description.type attribute))":/::" (description.type attribute)))
 129             (<:as-html "*" )))
 130   (<:as-html (attribute-value object attribute)))
 131
 132
 133
 134
 135
 136
 137
 138
 139
 140
 141