src/standard-display.lisp

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