src/standard-display.lisp

   1 (in-package :lisp-on-lines)
   2
   3
   4 ;;;; The Standard Layer Hierarchy
   5 (deflayer viewer)
   6 (deflayer editor (viewer))
   7 (deflayer creator (editor))
   8
   9 ;;;; 'Mixin' Layers
  10 (deflayer one-line)
  11
  12 (deflayer wrap-form)
  13
  14 (deflayer as-table)
  15
  16 (define-attributes (contextl-default)
  17   (:viewer viewer)
  18   (:editor editor)
  19   (:creator creator))
  20
  21
  22 (defmacro with-component ((component) &body body)
  23   `(let ((self ,component))
  24     (declare (ignorable self))
  25     (flet ((display* (thing &rest args)
  26              (apply #'display ,component thing args))
  27            (display-using-description* (desc obj &optional props)
  28              (display-using-description desc ,component obj props)))
  29       (declare (ignorable #'display* #'display-using-description*))
  30       ,@body)))
  31
  32
  33 (define-layered-function find-display-type (object))
  34
  35 (define-layered-method find-display-type (object)
  36   'viewer)
  37
  38 (define-layered-function find-display-layers (object))
  39
  40 (define-layered-method find-display-layers (object)
  41   "layered function"
  42   nil)
  43
  44 (defmacro call-display (component object &rest args)
  45   `(call-component ,component (make-instance 'standard-display-component
  46                          :display #'(lambda (component)
  47                                       (with-component (component)
  48                                         (display ,component ,object ,@args))))))
  49
  50
  51
  52 ;;;; * Object displays.
  53
  54 ;;;; We like to have a label for attributes, and meta-model provides a default.
  55 (defdisplay label
  56     (:description (d (eql 'attribute-label)))
  57   (<:span
  58    :class "label"
  59    (<:as-html label)))
  60
  61
  62 (define-layered-function display (component object &rest args)
  63   (:documentation
  64    "Displays OBJECT in COMPONENT.
  65
  66  default action is to FUNCALL-WITH-LAYERS the DISPLAY-USING-DESCRIPTION method."))
  67
  68 (define-layered-method display
  69     ((component t) (object standard-object) &rest args &key layers (type 'viewer)  &allow-other-keys)
  70   (let* ((occurence (find-occurence object))
  71          (properties (attribute.properties
  72                  (find-attribute occurence (intern (format nil "~A" type) :KEYWORD))))
  73          (layers (append (when type (loop for ty in (ensure-list type)
  74                                           nconc `(+ ,ty)))
  75                          layers
  76                          (getf properties :layers))))
  77     (funcall-with-layers
  78      layers
  79      #'display-using-description  occurence component object (plist-union args properties))))
  80
  81
  82 (define-layered-method display
  83   ((component t) (object t) &rest args &key layers (type 'viewer) &allow-other-keys)
  84   (funcall-with-layers
  85    layers
  86    #'display-using-description  t component object args))
  87
  88
  89 (define-layered-function display-using-description (description component object properties)
  90   (:documentation
  91    "Render the object in component, using DESCRIPTION, which is an occurence, and attribute, or something else"))
  92
  93 (define-layered-method display-using-description (description component object properties)
  94   "The standard display simply prints the object"
  95   (declare (ignore component properties description))
  96   (<:as-html object))
  97
  98
  99
 100 ;;;; ** The default display
 101
 102
 103
 104 ;;;; ** One line
 105 (defdisplay object (:in-layer one-line)
 106   "The one line presentation just displays the attributes with a #\Space between them"
 107   (do-attributes* (attribute)
 108         (display-current-attribute)
 109         (<:as-html " ")))
 110
 111 ;;;; ** as-table
 112
 113 (defdisplay object (:in-layer as-table)
 114   (<:table
 115    (do-attributes* (a)
 116      (<:tr
 117       (<:td  (<:as-html (a-getp :label)))
 118       (<:td (display-current-attribute))))))
 119
 120 ;;;; List Displays
 121 (defdisplay (list list) ()
 122   (<:ul
 123    (dolist* (item list)
 124      (<:li  (apply #'display component item properties)))))
 125
 126 ;;;; Attributes
 127 (defdisplay object (:in-layer
 128              editor
 129              :description (attribute standard-attribute))
 130     "Legacy editor using UCW presentations"
 131     (warn "USING LEGACY EDITOR FOR ~A" (getf (find-properties attribute) :slot-name))
 132   (let ((p (lol:make-view object :type :editor)))
 133     (present-slot-view p (getf (find-properties attribute) :slot-name))))
 134
 135 (define-layered-method display-using-description
 136   ((attribute standard-attribute) component object properties)
 137   (<:as-html (attribute.type attribute) " ")
 138
 139   (<:as-html (attribute-value object attribute)))
 140
 141 (defdisplay (button (eql 'standard-form-buttons))
 142     (:description (description t))
 143     (<ucw:submit :action (ok component)
 144                  :value "Ok."))
 145
 146 (defdisplay object (:in-layer wrap-form
 147                        :combination :around)
 148   (<ucw:form
 149    :action (refresh-component component)
 150    (call-next-method)
 151    (display component 'standard-form-buttons)))
 152
 153
 154 (defcomponent standard-display-component ()
 155   ((display-function :accessor display-function :initarg :display)))
 156
 157 (defmethod render ((self standard-display-component))
 158   (funcall (display-function self) self))
 159
 160
 161
 162
 163
 164