src/standard-display.lisp

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