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