Commit | Line | Data |
---|---|---|
dee565d0 DC |
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 | ||
14a7e1bc DC |
14 | (deflayer as-table) |
15 | ||
dee565d0 DC |
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)) | |
87e47dd6 | 24 | (declare (ignorable self)) |
dee565d0 | 25 | (flet ((display* (thing &rest args) |
87e47dd6 DC |
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*)) | |
dee565d0 DC |
30 | ,@body))) |
31 | ||
d1b0ed7c DC |
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 | |
dee565d0 DC |
46 | :display #'(lambda (component) |
47 | (with-component (component) | |
60a24293 | 48 | (display ,component ,object ,@args)))))) |
dee565d0 | 49 | |
dee565d0 | 50 | |
87e47dd6 DC |
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))) | |
dee565d0 DC |
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 | ||
dee565d0 | 68 | (define-layered-method display |
a9e8666b | 69 | ((component t) (object standard-object) &rest args &key layers (type 'viewer) &allow-other-keys) |
dee565d0 | 70 | (let* ((occurence (find-occurence object)) |
87e47dd6 | 71 | (properties (attribute.properties |
dee565d0 DC |
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 | |
87e47dd6 | 76 | (getf properties :layers)))) |
dee565d0 DC |
77 | (funcall-with-layers |
78 | layers | |
87e47dd6 | 79 | #'display-using-description occurence component object (plist-union args properties)))) |
dee565d0 | 80 | |
14a7e1bc | 81 | |
dee565d0 | 82 | (define-layered-method display |
d2882889 | 83 | ((component t) (object t) &rest args &key layers (type 'viewer) &allow-other-keys) |
dee565d0 | 84 | (funcall-with-layers |
14a7e1bc DC |
85 | layers |
86 | #'display-using-description t component object args)) | |
dee565d0 DC |
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 | ||
dee565d0 | 98 | |
dee565d0 | 99 | |
87e47dd6 | 100 | ;;;; ** The default display |
60a24293 DC |
101 | |
102 | ||
103 | ||
14a7e1bc | 104 | ;;;; ** One line |
87e47dd6 | 105 | (defdisplay object (:in-layer one-line) |
60a24293 | 106 | "The one line presentation just displays the attributes with a #\Space between them" |
87e47dd6 DC |
107 | (do-attributes* (attribute) |
108 | (display-current-attribute) | |
14a7e1bc DC |
109 | (<:as-html " "))) |
110 | ||
111 | ;;;; ** as-table | |
112 | ||
87e47dd6 | 113 | (defdisplay object (:in-layer as-table) |
14a7e1bc | 114 | (<:table |
87e47dd6 | 115 | (do-attributes* (a) |
14a7e1bc DC |
116 | (<:tr |
117 | (<:td (<:as-html (a-getp :label))) | |
87e47dd6 | 118 | (<:td (display-current-attribute)))))) |
14a7e1bc DC |
119 | |
120 | ;;;; List Displays | |
87e47dd6 | 121 | (defdisplay (list list) () |
14a7e1bc DC |
122 | (<:ul |
123 | (dolist* (item list) | |
124 | (<:li (apply #'display component item properties))))) | |
dee565d0 | 125 | |
14a7e1bc | 126 | ;;;; Attributes |
87e47dd6 | 127 | (defdisplay object (:in-layer |
dee565d0 DC |
128 | editor |
129 | :description (attribute standard-attribute)) | |
14a7e1bc | 130 | "Legacy editor using UCW presentations" |
87e47dd6 | 131 | (warn "USING LEGACY EDITOR FOR ~A" (getf (find-properties attribute) :slot-name)) |
dee565d0 | 132 | (let ((p (lol:make-view object :type :editor))) |
87e47dd6 | 133 | (present-slot-view p (getf (find-properties attribute) :slot-name)))) |
dee565d0 | 134 | |
14a7e1bc | 135 | (define-layered-method display-using-description |
87e47dd6 DC |
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)) | |
14a7e1bc DC |
143 | (<ucw:submit :action (ok component) |
144 | :value "Ok.")) | |
dee565d0 | 145 | |
87e47dd6 | 146 | (defdisplay object (:in-layer wrap-form |
dee565d0 DC |
147 | :combination :around) |
148 | (<ucw:form | |
149 | :action (refresh-component component) | |
150 | (call-next-method) | |
14a7e1bc DC |
151 | (display component 'standard-form-buttons))) |
152 | ||
dee565d0 | 153 | |
dee565d0 DC |
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 |