beginnings of a test component.
[clinton/lisp-on-lines.git] / src / standard-display.lisp
CommitLineData
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