| 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 | |