src/standard-display.lisp

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