removed warning which caused error
[clinton/lisp-on-lines.git] / 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