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 (component t))
  45   "The default display for CLOS objects"
  46   (print (class-name (class-of object)))
  47   (dolist* (slot-name (list-slots object))
  48
  49     (let ((boundp (slot-boundp object slot-name)))
  50       (format t "~A~A : ~A" (strcat slot-name)
  51               (if boundp
  52                   ""
  53                   "(unbound)")
  54               (if boundp
  55                   (slot-value object slot-name) "")))))
  56
  57 (defdisplay ((description t) object)
  58   "The default display for CLOS objects in UCW components"
  59    (dolist* (slot-name (list-slots object))
  60
  61       (let ((boundp (slot-boundp object slot-name)))
  62         (<:label :class "lol-label"
  63                  (display-attribute 'label  (strcat slot-name))
  64         (if boundp
  65             ""
  66             "(unbound)"))
  67       (<:as-html
  68        (if boundp
  69            (slot-value object slot-name) "")))))
  70
  71 ;;;; ** The default displays for objects with a MEWA occurence
  72
  73 (defdisplay (description object)
  74  (<:div
  75   :class "lol-display"
  76   (when (label description)
  77     (<:span
  78      :class "title"
  79      (<:as-html (label description))))
  80   (do-attributes (attribute description)
  81     (<:div
  82      :class "attribute"
  83      (display-attribute attribute object)))))
  84
  85 ;;;; ** One line
  86 (defdisplay
  87   :in-layer one-line (description object)
  88   "The one line presentation just displays the attributes with a #\Space between them"
  89   (do-attributes (attribute description)
  90     (display-attribute attribute object)
  91     (<:as-html " ")))
  92
  93 ;;;; ** as-table
  94
  95 (defdisplay :in-layer as-table (description object)
  96   (<:table
  97    (do-attributes (a description)
  98      (<:tr
  99       (<:td  :class "lol-label" (<:as-html (label a)))
 100       (<:td (display-attribute a object))))))
 101
 102 ;;;; List Displays
 103
 104 (deflayer list-display-layer)
 105
 106 (define-layered-class description
 107   :in-layer list-display-layer ()
 108   ((list-item :initarg :list-item :initform nil :special t :accessor list-item)))
 109
 110 (defdisplay (desc (list list))
 111  (with-active-layers (list-display-layer)
 112    (<:ul
 113     (dolist* (item list)
 114       (<:li  (apply #'display* item (list-item desc)))))))
 115
 116 ;;;; Attributes
 117 (defdisplay
 118     :in-layer editor
 119     ((attribute standard-attribute) object)
 120     (call-next-method))
 121
 122 (define-layered-method display-using-description
 123   ((attribute standard-attribute) object component)
 124   (with-component (component)
 125     (<ucw:a :action (call 'info-message :message (strcat (symbol-package (description.type attribute))":/::" (description.type attribute)))
 126             (<:as-html "*" )))
 127   (<:as-html (attribute-value object attribute)))
 128
 129
 130
 131
 132
 133
 134
 135
 136
 137
 138