Drop usage of defaction
[clinton/lisp-on-lines.git] / src / components / crud.lisp
CommitLineData
301f28fd 1(in-package :lisp-on-lines)
2
88670bec 3(defmethod/cc read-instance ((self component) instance)
301f28fd 4 "View an existing instance"
5 (call 'crud-viewer :instance instance))
6
88670bec 7(defmethod/cc update-instance ((self component) instance)
301f28fd 8 "Edit an instance, possibly a newly created one"
9 (call 'crud-editor :instance instance))
10
88670bec 11(defmethod/cc create-instance ((self component) class &rest initargs)
301f28fd 12 "Create a new instance and edit it."
13 (update-instance self (apply #'make-instance class initargs)))
14
15(defun %delete-instance-and-return-nil (instance)
16 "returns nil on success"
17 (handler-case (clsql:delete-instance-records instance)
18 (error (x)
19 (return-from %delete-instance-and-return-nil x)))
20 nil)
21
22(defun display-as-string (instance)
23 (with-output-to-string (s)
24 (yaclml:with-yaclml-stream s
25 (display (make-instance 'component) instance
26 :layers '(+ as-string)))))
27
88670bec 28(defmethod/cc delete-instance ((self component) instance)
907c9983 29 (when (call 'option-dialog
30 :message (format nil "Really Delete ~A" (display-as-string instance))
31 :options '((t "Yes, really delete it,")
32 (nil "No, i'll hold on to this one.")))
33 (let ((delete-failed (%delete-instance-and-return-nil instance)))
34 (if (not delete-failed)
35 (answer t)
36 (progn
37 (call 'info-message :message delete-failed)
38 (answer t))))))
301f28fd 39
40
41(defmethod breadcrumb-name (component)
42 (string-downcase (string (class-name (class-of component)))))
43
44(defun render-breadcrumb (self)
45 (<:p :class "breadcrumb"
907c9983 46 (let ((count 0)
47 (trail-length 3))
48 (labels ((find-call-stack-for-crumbs (component list-of-parents)
49 (cond ((and (not (null component))
50 (> trail-length count))
51 (incf count)
52 (find-call-stack-for-crumbs
53 (when (slot-boundp component 'ucw::calling-component)
54 (slot-value component 'ucw::calling-component))
55 (cons component list-of-parents)))
56 (t
57 list-of-parents))))
58 (loop
59 :for c
60 :on (find-call-stack-for-crumbs self nil)
61 :do (let ((c c))
62 (<:as-html " / ")
63 (if (cdr c)
64 (<ucw:a
65 :action (answer-component (second c) nil)
66 (<:as-html (breadcrumb-name (first c))))
67 (<:as-html (breadcrumb-name (first c))))))))))
301f28fd 68
69(defcomponent crud ()
70 ((instance :accessor instance :initarg :instance :initform nil))
71 (:documentation "The base class for all standard crud components"))
72
73(defmethod render ((self crud))
74 "Just to show off more of LOL, we'll use its display mechanism for UCW components.
75
76DISPLAY takes two required arguments,
77COMPONENT : The component to display FROM (not neccesarily 'in')
78OBJECT : The 'thing' we want to display... in this case it's the component,
79
80DISPLAY also takes keyword arguments that modify the DESCRIPTION at run time.
81
82By default, the display method iterates through the ATTRIBUTES
83of the DESCRIPTION of the OBJECT. This will hopfully become clear.
84
85In this case, we are displaying the component from itself.
86"
87
88 (display self self))
89
90(defun class-name-of (instance)
91 (class-name (class-of instance)))
92
93;;;; We'll use this in a string attribute to display the title.
94(defgeneric find-title (crud)
95 (:method (crud)
96 (if (instance crud)
97 (format nil "An instance of ~A" (class-name-of (instance crud)))
98 "Welcome to Crud 1.0")))
99
100;;;; ** We define an attribute for the menu
101;;;; DEFATTRIBUTE is like defclass for attributes.
102(defattribute crud-menu ()
103 ()
104 (:default-properties
105 :show-back-p t)
106 (:documentation
107 "A Custom menu attribute"))
108
109(defdisplay :wrapping ((menu crud-menu) object (component component))
110 "Set up the menu with an optional back button
111
112In a DEFDISPLAY form, the variable SELF is bound to the component we are displaying.
113This allows it to work with UCW's CALL and ANSWER, and saves some typing as well.
114One can also provide a name (or a specializer) for the component as the third parameter
115in the defdisplay argument list, (as i did above) but this is optional.
116
117DEFDISPLAY is really just a few macros around DISPLAY-USING-DESCRIPTION,
118which does the real work. Macroexpand if you're interested."
119 (<:ul
120 (when (show-back-p menu)
121 (<:li (<ucw:a :action (answer nil)
122 (<:as-html "Go Back"))))
123 (call-next-method)))
124
125(defdisplay ((menu crud-menu) object)
126 "Do nothing beyond the defalt for our standard menu
127
128note the omitted COMPONENT argument. sugar is all."
129 t)
130
131;;;; create a new layer for some customisations.
132(deflayer crud)
133
134;;;; we don't really _have_ to do this in our own layer,
135;;;; but it does give us the ability to turn the behaviour off.
136(defdisplay :in-layer crud
137 :wrap-around ((attribute standard-attribute) (object crud))
138 "Around every attribute of a CRUD instance, i'd like to wrap a div."
139 (<:div
140 :class (format nil "crud-~A" (string-downcase
1cc831d4 141 (string (attribute-name attribute))))
301f28fd 142 (call-next-method)))
143
144;;;; A description contains attributes.
145;;;; ATTRIBUTES are the various pieces that come together to make a display
146;;;; In this case, we define parts of the 'page'.
147
148(defdescription crud ()
149 (;; use a generic function for the title attribute
150 (title
151 ;; attributes have types.
152 ;; inspect LOL::FIND-ATTRIBUTE-CLASS-FOR-TYPE for a list.
153 :type 'string
154 ;; almost all attributes have a getter and/or setter function
155 ;; which is passed the object being displayed.
156 ;; You can also use :SLOT-NAME
157 ;; see ATTRIBUTE-VALUE for details.
158 :getter #'find-title)
159
160 ;; our breadcrumb function renders itself,
161 ;; and does not return a value.
162 (breadcrumb
163 ;; the FUNCTION type calls a function
164 ;; again, passing the object.
165 :type 'function
166 :function #'render-breadcrumb
167 ;; We need to specify IDENTITY here,
168 ;; as the default :GETTER calls
169 ;; SLOT-VALUE on the name of the attribute.
170 :getter #'identity)
171 ;; So we don't need a getter in INSTANCE.
172 (instance
173 ;; the DISPLAY type calls DISPLAY
174 ;; passing the component and the object
175 ;; along with any arguments specified using the
176 ;; :DISPLAY property
177 :type 'display
178 :display '(:layers (+ show-attribute-labels)))
179 ;; this is our menu, a custom attribute
180 (menu
181 :type 'crud-menu))
182 (;; now we create a LINE in the default layer.
183 ;; LINES describe how an object is displayed
184 ;; when that layer is active.
185 :in-layer
186 t
187 :attributes '(breadcrumb title menu instance)
188 :layers '(- show-attribute-labels + crud)))
189
190
191;;;; That's the basic outline of our app, now we fill in the blanks.
192
193;;;; ** Viewer
194(defcomponent crud-viewer (crud)
195 ()
196 (:documentation "A component for viewing objects"))
197
198(defdisplay ((menu crud-menu) (crud crud-viewer))
199 "Allow the user to edit and delete the object"
200 (<:li (<ucw:a :action (delete-instance crud (instance crud))
201 (<:as-html "DELETE this object.")))
202 (<:li (<ucw:a :action (update-instance crud (instance crud))
203 (<:as-html "EDIT this object."))))
204
205;;;; ** Editor
206;;;; (use the same component for creating and editing,
207;;;; with a little magic to make it all work.
208(defcomponent crud-editor (crud validation-mixin)
209 ())
210
88670bec 211(defmethod/cc ensure-instance ((self crud-editor))
301f28fd 212 "This one does a little magic, see SYNC-INSTANCE"
213 (meta-model::sync-instance (instance self)))
214
215(defmethod find-title ((crud crud-editor))
216 (<:as-html "Editing a "
217 (class-name (class-of (instance crud)))
218 " ")
219 (unless (meta-model:persistentp (instance crud))
220 (<:as-html "(new)")))
221
222(defattribute crud-editor-attribute (display-attribute)
223 ()
224 (:type-name crud-editor))
225
226(defdisplay :around ((ed crud-editor-attribute) object)
227 (with-active-layers (editor show-attribute-labels wrap-form)
228 (call-next-method)))
229
230
231(defdescription crud-editor ()
232 ((instance :type 'crud-editor))
233 (:in-layer
234 t
235 :default-attributes
236 `((instance
237 :display
238 (:form-buttons
239 ((:value ,(if (meta-model:persistentp (instance self))
240 "Save"
241 "Create")
242 :action ,(action (self object)
243 (ensure-instance self)
244 (answer (instance self))))
245 (:value
246 "Cancel"
247 :action
248 ,(action (self object)
249 (setf (instance self) nil)
250 (answer nil)))))))))
251
252;;;; ** Summary
253(defcomponent crud-summary (crud)
254 ((class :accessor db-class :initarg :class)
255 (limit :accessor row-limit :initform 25)
256 (offset :accessor row-offset :initform 0)))
257
258(defmethod find-title ((crud crud-summary))
259 (format nil "Viewing Summary of ~A" (db-class crud)))
260
261(defun find-some (class limit offset)
262 (clsql:select class :limit limit :offset offset :flatp t))
263
264(defmethod find-summary ((crud crud-summary))
265 (find-some (db-class crud)
266 (row-limit crud)
267 (row-offset crud)))
268
269(defdescription crud-summary ()
270 ()
271 (:in-layer t
272 ;;; here we show :default-attributes
273 ;;; the attributes themselves can vary by layer
274 ;;; the same syntax is supported in an :ATTRIBUTES form
275 ;;; but that also specifies which attributes to display
276 :default-attributes
277 `((instance
278 :getter ,#'find-summary
279 :display
280 (:layers (+ one-line)
281 :list-item
282 (:layers (+ lol::wrap-link + lol::show-attribute-labels)
283 :link-action ,(action (self obj)
284 (call 'crud-viewer :instance obj))))))))
285
286(defdisplay ((menu crud-menu) (object crud-summary))
287 (<:li (<ucw:a
288 :action (create-instance object (db-class object))
289 (<:as-html "(Create New " (db-class object) ")"))))
290
88670bec 291(defmethod/cc call-crud-summary ((self component) class)
301f28fd 292 (call 'crud-summary :class class))
293
294
295(defcomponent crud-database (crud)
296 ())
297
298(defdescription crud-database ()
299 ((instructions
300 :type 'string
301 :getter (constantly "View Object Summary: "))
302 (instance
303 :type 'display
304 :getter #'(lambda (obj)
305 (declare (ignore obj))
306 (meta-model::list-base-classes :clsql))
307 :display `(:layers (+ one-line)
308 :list-item
309 (:layers (+ lol::wrap-link )
310 :link-action ,(action (self class)
311 (call-crud-summary self class))))))
312 (:in-layer
313 t
314 :attributes '(title menu instructions instance)))