removed warning which caused error
[clinton/lisp-on-lines.git] / src / standard-display.lisp
CommitLineData
dee565d0
DC
1(in-package :lisp-on-lines)
2
2b0fd9c8 3;;;; The Standard Layers
dee565d0 4(deflayer viewer)
2b0fd9c8
DC
5(deflayer editor)
6(deflayer creator)
dee565d0 7(deflayer one-line)
14a7e1bc 8(deflayer as-table)
2b0fd9c8 9(deflayer as-string)
14a7e1bc 10
2b0fd9c8
DC
11(defdisplay
12 :in-layer as-string (d o)
13 (do-attributes (a d)
14 (display-attribute a o)
15 (<:as-is " ")))
dee565d0 16
2b0fd9c8
DC
17(defmethod list-slots (thing)
18 (list 'identity))
d1b0ed7c 19
d1b0ed7c 20
2b0fd9c8 21;;;; TODO : this doesn't work
d1b0ed7c 22
2b0fd9c8
DC
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)))))
d1b0ed7c 30
2b0fd9c8
DC
31(defmacro call-display (component object &rest properties)
32 `(let ()
33 (call-display-with-context ,component ,object nil ,@properties)))
d1b0ed7c 34
2b0fd9c8
DC
35(defcomponent standard-display-component ()
36 ((context :accessor context :initarg :context)
37 (object :accessor object :initarg :object)
38 (args :accessor args :initarg :args)))
dee565d0 39
2b0fd9c8
DC
40(defmethod render ((self standard-display-component))
41
42 (apply #'display self (object self) (args self)))
dee565d0 43
87e47dd6
DC
44
45;;;; * Object displays.
46
47;;;; We like to have a label for attributes, and meta-model provides a default.
2b0fd9c8 48(defdisplay ((desc (eql 'label)) label)
87e47dd6
DC
49 (<:span
50 :class "label"
51 (<:as-html label)))
dee565d0 52
2b0fd9c8 53;;;; TODO: all lisp types should have occurences and attributes defined for them.
dee565d0 54
2b0fd9c8
DC
55(defdisplay ((description t) lisp-value)
56 (<:as-html lisp-value))
14a7e1bc 57
2b0fd9c8 58(defdisplay (description (object string))
dee565d0
DC
59 (<:as-html object))
60
2b0fd9c8
DC
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)))))
60a24293 97
14a7e1bc 98;;;; ** One line
2b0fd9c8
DC
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 " ")))
14a7e1bc
DC
105
106;;;; ** as-table
107
2b0fd9c8
DC
108(defdisplay :in-layer as-table (description object)
109 (<:table
110 (do-attributes (a description)
14a7e1bc 111 (<:tr
2b0fd9c8
DC
112 (<:td :class "lol-label" (<:as-html (label a)))
113 (<:td (display-attribute a object))))))
14a7e1bc
DC
114
115;;;; List Displays
2b0fd9c8 116(defdisplay (desc (list list))
14a7e1bc
DC
117 (<:ul
118 (dolist* (item list)
2b0fd9c8
DC
119 (<:li (display* item)
120 (<:as-html item)))))
dee565d0 121
14a7e1bc 122;;;; Attributes
2b0fd9c8
DC
123(defdisplay
124 :in-layer editor
125 ((attribute standard-attribute) object)
14a7e1bc 126 "Legacy editor using UCW presentations"
2b0fd9c8
DC
127
128 (warn "USING LEGACY EDITOR FOR ~A" (slot-name attribute)))
dee565d0 129
14a7e1bc 130(define-layered-method display-using-description
2b0fd9c8
DC
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 "*" )))
87e47dd6
DC
135 (<:as-html (attribute-value object attribute)))
136
dee565d0 137
14a7e1bc 138
dee565d0 139
dee565d0 140
dee565d0
DC
141
142
143
144
145
146