Commit | Line | Data |
---|---|---|
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 |