| 1 | ;;;; -*- lisp -*- |
| 2 | |
| 3 | (in-package :lisp-on-lines) |
| 4 | |
| 5 | (defcomponent presentation () |
| 6 | ((css-class :accessor css-class :initarg :css-class :initform nil)) |
| 7 | (:documentation "The super class of all UCW presentations. |
| 8 | |
| 9 | A presentation object is a UCW component which knows how to |
| 10 | read/write different kinds of data types. |
| 11 | |
| 12 | There are three major kinds of presentations: |
| 13 | |
| 14 | 1) object-presentation - Managing a single object. |
| 15 | |
| 16 | 2) slot-presentation - Managing the single parts (slots) which |
| 17 | make up an object. |
| 18 | |
| 19 | 3) collection-presentation - Managing multiple objects. |
| 20 | |
| 21 | Presentations are independant of the underlying application |
| 22 | specific lisp objects they manage. A presentation can be created |
| 23 | once and reused or modified before and aftre it has been used. |
| 24 | |
| 25 | Presentations fulfill two distinct roles: on the one hand they |
| 26 | create, given a lisp object, a grahpical (html) rendering of that |
| 27 | object, they also deal with whatever operations the user might |
| 28 | wish to perform on that object. |
| 29 | |
| 30 | * Creating Presentation Objects |
| 31 | |
| 32 | Presentation objects are created by making an instance of either |
| 33 | an object-presentation or a collection-presentation and then |
| 34 | filling the slots property of this object.")) |
| 35 | |
| 36 | (defgeneric present (presentation) |
| 37 | (:documentation "Render PRESENTATION (generally called from render-on).")) |
| 38 | |
| 39 | (defmacro present-object (object &key using presentation) |
| 40 | (assert (xor using presentation) |
| 41 | (using presentation) |
| 42 | "Must specify exactly one of :USING and :PRESENTATION.") |
| 43 | (if using |
| 44 | (destructuring-bind (type &rest args) |
| 45 | (ensure-list using) |
| 46 | `(call ',type ,@args 'instance ,object)) |
| 47 | (rebinding (presentation) |
| 48 | `(progn |
| 49 | (setf (slot-value ,presentation 'instance) ,object) |
| 50 | (call-component self ,presentation))))) |
| 51 | |
| 52 | (defmacro present-collection (presentation-type &rest initargs) |
| 53 | `(call ',presentation-type ,@initargs)) |
| 54 | |
| 55 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 56 | ;;;; object-presentation |
| 57 | |
| 58 | (defcomponent object-presentation (presentation) |
| 59 | ((slots :accessor slots :initarg :slots :initform nil) |
| 60 | (instance :initform nil :initarg instance :accessor instance)) |
| 61 | (:documentation "Presentations for single objects.")) |
| 62 | |
| 63 | (defmethod render-on ((res response) (o object-presentation)) |
| 64 | (unless (slot-value o 'instance) |
| 65 | (error "Attempting to render the presentation ~S, but it has no instance object to present." |
| 66 | o)) |
| 67 | (present o)) |
| 68 | |
| 69 | (defmethod present ((pres object-presentation)) |
| 70 | (<:table :class (css-class pres) |
| 71 | (dolist (slot (slots pres)) |
| 72 | (<:tr :class "presentation-slot-row" |
| 73 | (<:td :class "presentation-slot-label" (<:as-html (label slot))) |
| 74 | (<:td :class "presentation-slot-value" (present-slot slot (instance pres))))) |
| 75 | (render-options pres (instance pres)))) |
| 76 | |
| 77 | (defmethod render-options ((pres object-presentation) instance) |
| 78 | (declare (ignore instance pres)) |
| 79 | #| (<:tr |
| 80 | (<:td :colspan 2 :align "center" |
| 81 | (<ucw:input :type "submit" :action (ok pres) :value "Ok."))) |# ) |
| 82 | |
| 83 | (defaction ok ((o object-presentation) &optional (value (slot-value o 'instance))) |
| 84 | (answer value)) |
| 85 | |
| 86 | (defmethod find-slot ((o object-presentation) slot-label) |
| 87 | (find slot-label (slots o) :test #'string= :key #'label)) |
| 88 | |
| 89 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 90 | ;;;; inline objects are extremly similar to object-presentations |
| 91 | ;;;; except that we assume they're being edited within the context of |
| 92 | ;;;; some other and so don't get their own edit/delete/confirm |
| 93 | ;;;; whatever buttons. |
| 94 | |
| 95 | (defcomponent inline-object-presentation (object-presentation) |
| 96 | ()) |
| 97 | |
| 98 | (defmethod render-options ((pres inline-object-presentation) instance) |
| 99 | (declare (ignore instance)) |
| 100 | nil) |
| 101 | |
| 102 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 103 | ;;;; 'one line' objects |
| 104 | |
| 105 | (defcomponent one-line-presentation (object-presentation) |
| 106 | ((before :accessor before :initform "" :initarg :before |
| 107 | :documentation "Text to render before rendirng the slots.") |
| 108 | (between :accessor between :initform " " :initarg :between |
| 109 | :documentation "Text to render between each slot.") |
| 110 | (after :accessor after :initform "" :initarg after |
| 111 | :documentation "Text to render after all the slots have been rendered."))) |
| 112 | |
| 113 | (defmethod present ((pres one-line-presentation)) |
| 114 | (<:as-is (before pres)) |
| 115 | (when (slots pres) |
| 116 | (present-slot (first (slots pres)) (instance pres))) |
| 117 | (dolist (slot (cdr (slots pres))) |
| 118 | (<:as-is (between pres)) |
| 119 | (present-slot slot (instance pres))) |
| 120 | (<:as-is (after pres))) |
| 121 | |
| 122 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 123 | ;;;; List |
| 124 | |
| 125 | (defcomponent list-presentation (presentation) |
| 126 | ((slots :accessor slots :initarg :slots) |
| 127 | (editablep :accessor editablep :initform t :initarg :editablep) |
| 128 | (edit-label :accessor edit-label :initform "Edit") |
| 129 | (deleteablep :accessor deleteablep :initform t :initarg :deleteablep) |
| 130 | (delete-label :accessor delete-label :initform "Delete") |
| 131 | (instances :accessor instances))) |
| 132 | |
| 133 | (defmethod initialize-instance :after ((l list-presentation) &rest initargs) |
| 134 | (declare (ignore initargs)) |
| 135 | (setf (instances l) (get-all-instances l))) |
| 136 | |
| 137 | (defmethod render-on ((res response) (l list-presentation)) |
| 138 | (present l)) |
| 139 | |
| 140 | (defgeneric get-all-instances (listing) |
| 141 | (:documentation "Returns all the instances which should be viewable with LISTING. |
| 142 | |
| 143 | This method is also used by relation-slot-presentations for the same reason.")) |
| 144 | |
| 145 | (defmethod present ((listing list-presentation)) |
| 146 | (<:table :class (css-class listing) |
| 147 | (render-list-heading listing) |
| 148 | (iterate |
| 149 | (for element in (instances listing)) |
| 150 | (for index upfrom 0) |
| 151 | (render-list-row listing element index)))) |
| 152 | |
| 153 | (defmethod render-list-heading ((listing list-presentation)) |
| 154 | (<:tr :class "presentation-list-heading-row" |
| 155 | (<:th "") |
| 156 | (dolist (slot (slots listing)) |
| 157 | (<:th :class "presentation-list-heading-cell" |
| 158 | (<:as-html (label slot)))) |
| 159 | (<:th ""))) |
| 160 | |
| 161 | (defmethod render-list-row ((listing list-presentation) object index) |
| 162 | (<:tr :class "item-row" |
| 163 | (<:td :class "index-number-cell" |
| 164 | (<:i (<:as-html index))) |
| 165 | (dolist (slot (slots listing)) |
| 166 | (<:td :class "data-cell" (present-slot slot object))) |
| 167 | (<:td :align "center" :valign "top" |
| 168 | (when (editablep listing) |
| 169 | (let ((object object)) |
| 170 | (<ucw:input :type "submit" |
| 171 | :action (edit-from-listing listing object index) |
| 172 | :value (edit-label listing)))) |
| 173 | (<:as-is " ") |
| 174 | (when (deleteablep listing) |
| 175 | (let ((index index)) |
| 176 | (<ucw:input :type "submit" |
| 177 | :action (delete-from-listing listing object index) |
| 178 | :value (delete-label listing))))))) |
| 179 | |
| 180 | (defgeneric/cc create-from-listing (listing)) |
| 181 | |
| 182 | (defmethod/cc create-from-listing :after ((l list-presentation)) |
| 183 | (setf (instances l) (get-all-instances l))) |
| 184 | |
| 185 | (defgeneric/cc delete-from-listing (listing item index)) |
| 186 | |
| 187 | (defmethod/cc delete-from-listing :after ((l list-presentation) item index) |
| 188 | (declare (ignore item index)) |
| 189 | (setf (instances l) (get-all-instances l))) |
| 190 | |
| 191 | (defgeneric/cc edit-from-listing (listing item index)) |
| 192 | |
| 193 | (defmethod/cc edit-from-listing :after ((l list-presentation) item index) |
| 194 | (declare (ignore item index)) |
| 195 | (setf (instances l) (get-all-instances l))) |
| 196 | |
| 197 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 198 | ;;;; Searching/Filtering |
| 199 | |
| 200 | (defcomponent presentation-search (presentation) |
| 201 | ((criteria :accessor criteria :initform '()) |
| 202 | (search-presentation :accessor search-presentation :initarg :search-presentation |
| 203 | :documentation "The presentation object |
| 204 | used in determining what the possible |
| 205 | search options are.") |
| 206 | (list-presentation :accessor list-presentation :initarg :list-presentation |
| 207 | :documentation "The presentation object used when showing the results."))) |
| 208 | |
| 209 | (defgeneric applicable-criteria (presentation) |
| 210 | (:method-combination nconc)) |
| 211 | |
| 212 | (defmethod applicable-criteria nconc ((search presentation-search)) |
| 213 | (let ((criteria '())) |
| 214 | (dolist (slot (slots (search-presentation search))) |
| 215 | (setf criteria (append criteria (applicable-criteria slot)))) |
| 216 | (cons (make-instance 'negated-criteria :presentation search) |
| 217 | criteria))) |
| 218 | |
| 219 | (defcomponent criteria () |
| 220 | ((presentation :accessor presentation :initarg :presentation))) |
| 221 | |
| 222 | (defaction add-criteria ((search presentation-search) (criteria criteria)) |
| 223 | (push criteria (criteria search))) |
| 224 | |
| 225 | (defaction drop-criteria ((search presentation-search) (criteria criteria)) |
| 226 | (setf (criteria search) (delete criteria (criteria search)))) |
| 227 | |
| 228 | (defgeneric apply-criteria (criteria instance) |
| 229 | (:method-combination and)) |
| 230 | |
| 231 | (defmethod valid-instances ((search presentation-search)) |
| 232 | (let ((valid '())) |
| 233 | (dolist (i (get-all-instances search)) |
| 234 | (block apply-criteria |
| 235 | (dolist (criteria (criteria search)) |
| 236 | (unless (apply-criteria criteria i) |
| 237 | (return-from apply-criteria nil))) |
| 238 | (push i valid))) |
| 239 | valid)) |
| 240 | |
| 241 | (defcomponent search-results-list (list-presentation) |
| 242 | ((search-presentation :accessor search-presentation))) |
| 243 | |
| 244 | (defmethod render-on ((res response) (s presentation-search)) |
| 245 | (<:p "Results:") |
| 246 | (let ((listing (list-presentation s))) |
| 247 | (<:table |
| 248 | (<:tr :class "presentation-list-heading-row" |
| 249 | (<:th "") |
| 250 | (dolist (slot (slots (list-presentation s))) |
| 251 | (<:th :class "presentation-list-heading-cell" |
| 252 | (<:as-html (label slot)))) |
| 253 | (<:th "")) |
| 254 | (loop |
| 255 | for object in (valid-instances s) |
| 256 | for index upfrom 0 |
| 257 | do (<:tr :class "item-row" |
| 258 | (<:td :class "index-number-cell" (<:i (<:as-html index))) |
| 259 | (dolist (slot (slots (list-presentation s))) |
| 260 | (<:td :class "data-cell" (present-slot slot object))) |
| 261 | (<:td :align "center" :valign "top" |
| 262 | (when (editablep listing) |
| 263 | (let ((object object)) |
| 264 | (<ucw:input :type "submit" |
| 265 | :action (edit-from-search s object index) |
| 266 | :value (edit-label listing)))) |
| 267 | (<:as-is " ") |
| 268 | (when (deleteablep listing) |
| 269 | (let ((index index)) |
| 270 | (<ucw:input :type "submit" |
| 271 | :action (delete-from-search s object index) |
| 272 | :value (delete-label listing))))))))) |
| 273 | (<:p "Search Criteria:") |
| 274 | (<:ul |
| 275 | (render-criteria res s) |
| 276 | (<:li (<ucw:input :type "submit" :action (refresh-component s) |
| 277 | :value "update")))) |
| 278 | |
| 279 | (defmethod render-criteria ((res response) (s presentation-search)) |
| 280 | (<:ul |
| 281 | (dolist (c (criteria s)) |
| 282 | (<:li (render-on res c) |
| 283 | (let ((c c)) |
| 284 | (<ucw:input :action (drop-criteria s c) :type "submit" :value "eliminate")))) |
| 285 | (let ((new-criteria nil)) |
| 286 | (<:li "Add Criteria: " |
| 287 | (<ucw:select :accessor new-criteria |
| 288 | (dolist (criteria (applicable-criteria s)) |
| 289 | (<ucw:option :value criteria (<:as-html (label criteria))))) |
| 290 | (<ucw:input :type "submit" :action (add-criteria s new-criteria) |
| 291 | :value "add"))))) |
| 292 | |
| 293 | (defgeneric/cc edit-from-search (search object index)) |
| 294 | |
| 295 | (defgeneric/cc delete-from-search (search object index)) |
| 296 | |
| 297 | ;;;; meta criteria |
| 298 | |
| 299 | (defcomponent negated-criteria (criteria) |
| 300 | ((criteria :accessor criteria :initform nil))) |
| 301 | |
| 302 | (defmethod label ((n negated-criteria)) "Not:") |
| 303 | |
| 304 | (defmethod render-on ((res response) (n negated-criteria)) |
| 305 | (<:p "Not: " |
| 306 | (when (criteria n) |
| 307 | (render-on res (criteria n)))) |
| 308 | (let ((new-criteria nil)) |
| 309 | (<:p "Set Criteria: " |
| 310 | (<ucw:select :accessor new-criteria |
| 311 | (dolist (criteria (applicable-criteria (presentation n))) |
| 312 | (<ucw:option :value criteria (<:as-html (label criteria))))) |
| 313 | (<ucw:input :type "submit" :action (setf (criteria n) new-criteria) |
| 314 | :value "add")))) |
| 315 | |
| 316 | (defmethod apply-criteria and ((n negated-criteria) instance) |
| 317 | (if (criteria n) |
| 318 | (not (apply-criteria (criteria n) instance)) |
| 319 | t)) |
| 320 | |
| 321 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 322 | ;;;; Slot presentations |
| 323 | |
| 324 | (defcomponent slot-presentation (presentation) |
| 325 | ((label :accessor label :initarg :label) |
| 326 | (label-plural :accessor label-plural :initarg :label-plural) |
| 327 | (getter :accessor getter :initarg :getter |
| 328 | :documentation "A function used for getting the |
| 329 | current value of the object. It will be passed the |
| 330 | objcet and must return the current value.") |
| 331 | (setter :accessor setter :initarg :setter |
| 332 | :documentation "A function used for updatig the value of |
| 333 | the underlying object. It will be passed the new |
| 334 | value and the object (in that order).") |
| 335 | (editablep :accessor editablep :initarg :editablep :initform t) |
| 336 | (print-object-label))) |
| 337 | |
| 338 | (defmethod print-object ((s slot-presentation) stream) |
| 339 | (if *print-readably* |
| 340 | (call-next-method) |
| 341 | (print-unreadable-object (s stream :type t :identity t) |
| 342 | (princ (label s) stream) |
| 343 | (princ " (" stream) |
| 344 | (princ (slot-value s 'print-object-label) stream) |
| 345 | (princ ")" stream)))) |
| 346 | |
| 347 | (defgeneric present-slot (slot instance)) |
| 348 | |
| 349 | (defmethod initialize-instance :after ((presentation slot-presentation) |
| 350 | &key slot-name getter setter &allow-other-keys) |
| 351 | (if slot-name |
| 352 | (setf (slot-value presentation 'print-object-label) slot-name) |
| 353 | (setf (slot-value presentation 'print-object-label) getter)) |
| 354 | (when slot-name |
| 355 | (assert (not (or getter setter)) |
| 356 | (slot-name getter setter) |
| 357 | "Can't specify :GETTER and/or :SETTER alnog with :SLOT-NAME.") |
| 358 | (setf (getter presentation) (lambda (object) |
| 359 | (when (slot-boundp object slot-name) |
| 360 | (slot-value object slot-name))) |
| 361 | (setter presentation) (lambda (value object) |
| 362 | (setf (slot-value object slot-name) value))))) |
| 363 | |
| 364 | (defvar *presentation-slot-type-mapping* (make-hash-table :test 'eql)) |
| 365 | |
| 366 | (defun register-slot-type-mapping (name class-name) |
| 367 | (setf (gethash name *presentation-slot-type-mapping*) class-name)) |
| 368 | |
| 369 | (defmacro defslot-presentation (name supers slots &rest options) |
| 370 | `(progn |
| 371 | (defcomponent ,name ,(or supers `(slot-presentation)) |
| 372 | ,slots |
| 373 | ,@(remove :type-name options :key #'car)) |
| 374 | ,(let ((type-name (assoc :type-name options))) |
| 375 | (when type-name |
| 376 | `(register-slot-type-mapping ',(second type-name) ',name))) |
| 377 | ',name)) |
| 378 | |
| 379 | (defgeneric presentation-slot-value (slot instance) |
| 380 | (:method ((slot slot-presentation) instance) |
| 381 | (funcall (getter slot) instance))) |
| 382 | |
| 383 | (defgeneric (setf presentation-slot-value) (value slot instance) |
| 384 | (:method (value (slot slot-presentation) instance) |
| 385 | (funcall (setter slot) value instance))) |
| 386 | |
| 387 | (defmethod applicable-criteria nconc ((s slot-presentation)) |
| 388 | nil) |
| 389 | |
| 390 | (defmacro criteria-for-slot-presentation (slot &body criteria-clauses) |
| 391 | (rebinding (slot) |
| 392 | `(list |
| 393 | ,@(mapcar (lambda (criteria-clause) |
| 394 | (let ((criteria-clause (ensure-list criteria-clause))) |
| 395 | `(make-instance ',(first criteria-clause) |
| 396 | ,@(cdr criteria-clause) |
| 397 | :presentation ,slot))) |
| 398 | criteria-clauses)))) |
| 399 | |
| 400 | (defmacro defslot-critera (class-name supers slots &key label apply-criteria) |
| 401 | (with-unique-names (obj instance) |
| 402 | (list |
| 403 | 'progn |
| 404 | `(defcomponent ,class-name ,supers ,slots) |
| 405 | (when label |
| 406 | `(defmethod label ((,obj ,class-name)) |
| 407 | (format nil ,label (label (presentation ,obj))))) |
| 408 | |
| 409 | (when apply-criteria |
| 410 | `(defmethod apply-criteria and ((,obj ,class-name) ,instance) |
| 411 | (funcall ,apply-criteria |
| 412 | ,obj |
| 413 | ,instance |
| 414 | (presentation-slot-value (presentation ,obj) ,instance)))) |
| 415 | `(quote ,class-name)))) |
| 416 | |
| 417 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 418 | ;;;; Boolean |
| 419 | |
| 420 | (defslot-presentation boolean-slot-presentation () |
| 421 | () |
| 422 | (:type-name boolean)) |
| 423 | |
| 424 | (defmethod present-slot ((slot boolean-slot-presentation) instance) |
| 425 | (if (editablep slot) |
| 426 | (let ((callback (ucw::make-new-callback |
| 427 | (lambda (val) |
| 428 | |
| 429 | (if (listp val) |
| 430 | (setf (presentation-slot-value slot instance) t) |
| 431 | (setf (presentation-slot-value slot instance) nil)))))) |
| 432 | (<:input :type "hidden" :name callback :value "DEFAULT") |
| 433 | (<:input :type "checkbox" |
| 434 | :name callback |
| 435 | :checked (slot-value instance (slot-name slot)))) |
| 436 | (<:as-html |
| 437 | (if (presentation-slot-value slot instance) |
| 438 | "YES" |
| 439 | "NO")))) |
| 440 | |
| 441 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 442 | ;;;; strings |
| 443 | |
| 444 | (defslot-presentation string-slot-presentation () |
| 445 | ((max-length :accessor max-length :initarg :max-length :initform nil) |
| 446 | (size :accessor size :initarg :size :initform nil)) |
| 447 | (:type-name string)) |
| 448 | |
| 449 | (defmethod present-slot ((slot string-slot-presentation) instance) |
| 450 | (if (editablep slot) |
| 451 | (<ucw:input :type "text" |
| 452 | :accessor (presentation-slot-value slot instance) |
| 453 | :size (or (size slot) |
| 454 | (if (string= "" (presentation-slot-value slot instance)) |
| 455 | (size slot) |
| 456 | (+ 3 (length (presentation-slot-value slot instance))))) |
| 457 | :maxlength (max-length slot)) |
| 458 | (<:as-html (presentation-slot-value slot instance)))) |
| 459 | |
| 460 | ;;;; Critera |
| 461 | |
| 462 | (defmethod applicable-criteria nconc ((s string-slot-presentation)) |
| 463 | (criteria-for-slot-presentation s |
| 464 | string-starts-with |
| 465 | string-contains |
| 466 | string-ends-with)) |
| 467 | |
| 468 | (defcomponent string-criteria (criteria) |
| 469 | ((search-text :accessor search-text :initform nil))) |
| 470 | |
| 471 | (defmethod render-on ((res response) (criteria string-criteria)) |
| 472 | (<:as-html (label criteria) " ") |
| 473 | (<ucw:input :type "text" :accessor (search-text criteria) :size 10)) |
| 474 | |
| 475 | (defslot-critera string-contains (string-criteria) |
| 476 | () |
| 477 | :label "~A contains:" |
| 478 | :apply-criteria (lambda (criteria instance slot-value) |
| 479 | (declare (ignore instance)) |
| 480 | (and (<= (length (search-text criteria)) (length slot-value)) |
| 481 | (search (search-text criteria) slot-value :test #'char-equal)))) |
| 482 | |
| 483 | (defslot-critera string-starts-with (string-contains) |
| 484 | () |
| 485 | :label "~A starts with:" |
| 486 | :apply-criteria (lambda (criteria instance slot-value) |
| 487 | (declare (ignore instance)) |
| 488 | (and (<= (length (search-text criteria)) (length slot-value)) |
| 489 | (= 0 (or (search (search-text criteria) slot-value |
| 490 | :test #'char-equal) |
| 491 | -1))))) |
| 492 | |
| 493 | (defslot-critera string-ends-with (string-contains) |
| 494 | () |
| 495 | :label "~A ends with:" |
| 496 | :apply-criteria (lambda (criteria instance slot-value) |
| 497 | (declare (ignore instance)) |
| 498 | (and (<= (length (search-text criteria)) (length slot-value)) |
| 499 | (= (- (length slot-value) (length (search-text criteria))) |
| 500 | (or (search (search-text criteria) slot-value |
| 501 | :from-end t |
| 502 | :test #'char-equal) |
| 503 | -1))))) |
| 504 | |
| 505 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 506 | ;;;; numbers |
| 507 | |
| 508 | (defslot-presentation number-slot-presentation () |
| 509 | ((min-value :accessor min-value :initarg :min-value :initform nil) |
| 510 | (max-value :accessor max-value :initarg :max-value :initform nil))) |
| 511 | |
| 512 | (defcomponent number-criteria (criteria) |
| 513 | ((number-input :accessor number-input :initform nil))) |
| 514 | |
| 515 | (defmethod applicable-criteria nconc ((s number-slot-presentation)) |
| 516 | (criteria-for-slot-presentation s |
| 517 | number-less-than |
| 518 | number-greater-than |
| 519 | number-equal-to)) |
| 520 | |
| 521 | (defmacro defnumber-criteria (name &key label render-on-prefix apply-criteria) |
| 522 | `(progn |
| 523 | (defslot-critera ,name (number-criteria) |
| 524 | () |
| 525 | :label ,label |
| 526 | :apply-criteria (lambda (criteria instance slot-value) |
| 527 | (declare (ignore instance)) |
| 528 | (if (numberp slot-value) |
| 529 | (if (number-input criteria) |
| 530 | (funcall ,apply-criteria slot-value (number-input criteria)) |
| 531 | t) |
| 532 | nil))) |
| 533 | |
| 534 | (defmethod render-on ((res response) (obj ,name)) |
| 535 | (<:as-html (format nil ,render-on-prefix (label (presentation obj)))) |
| 536 | (<ucw:input :type "text" |
| 537 | :reader (or (number-input obj) "") |
| 538 | :writer (lambda (v) |
| 539 | (unless (string= "" v) |
| 540 | (let ((n (parse-float v))) |
| 541 | (when n |
| 542 | (setf (number-input obj) n))))))))) |
| 543 | |
| 544 | (defnumber-criteria number-equal-to |
| 545 | :apply-criteria (lambda (slot-value number-input) |
| 546 | (= slot-value number-input)) |
| 547 | :label "~A is equal to:" |
| 548 | :render-on-prefix "~A = ") |
| 549 | |
| 550 | (defnumber-criteria number-less-than |
| 551 | :apply-criteria (lambda (slot-value number-input) |
| 552 | (< slot-value number-input)) |
| 553 | :label "~A is less than:" |
| 554 | :render-on-prefix "~A < ") |
| 555 | |
| 556 | (defnumber-criteria number-greater-than |
| 557 | :apply-criteria (lambda (slot-value number-input) |
| 558 | (> slot-value number-input)) |
| 559 | :label "~A is greater than:" |
| 560 | :render-on-prefix "~A > ") |
| 561 | |
| 562 | |
| 563 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 564 | ;;;; Integers |
| 565 | |
| 566 | (defslot-presentation integer-slot-presentation (number-slot-presentation) |
| 567 | () |
| 568 | (:type-name integer)) |
| 569 | |
| 570 | (defmethod presentation-slot-value ((slot integer-slot-presentation) instance) |
| 571 | (declare (ignore instance)) |
| 572 | (or (call-next-method) "")) |
| 573 | |
| 574 | (defmethod (setf presentation-slot-value) ((value string) (slot integer-slot-presentation) instance) |
| 575 | (unless (string= "" value) |
| 576 | (let ((i (parse-integer value :junk-allowed t))) |
| 577 | (when i |
| 578 | (setf (presentation-slot-value slot instance) i))))) |
| 579 | |
| 580 | (defmethod present-slot ((slot integer-slot-presentation) instance) |
| 581 | (if (editablep slot) |
| 582 | (<ucw:input :type "text" |
| 583 | :accessor (presentation-slot-value slot instance)) |
| 584 | (<:as-html (presentation-slot-value slot instance)))) |
| 585 | |
| 586 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 587 | ;;;; Reals |
| 588 | |
| 589 | (defcomponent real-slot-presentation (number-slot-presentation) |
| 590 | ()) |
| 591 | |
| 592 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 593 | ;;;; Currency (double precision reals) |
| 594 | |
| 595 | (defslot-presentation currency-slot-presentation (real-slot-presentation) |
| 596 | ((as-money-p :accessor as-money-p :initarg :as-money-p :initform nil)) |
| 597 | (:type-name currency)) |
| 598 | |
| 599 | (defmethod (setf presentation-slot-value) ((value string) (c currency-slot-presentation) instance) |
| 600 | (let ((*read-eval* nil)) |
| 601 | (unless (string= "" value) |
| 602 | (let ((value (read-from-string value))) |
| 603 | (when (numberp value) |
| 604 | (setf (presentation-slot-value c instance) value)))))) |
| 605 | |
| 606 | (defmethod present-slot ((currency currency-slot-presentation) instance) |
| 607 | (if (editablep currency) |
| 608 | (<ucw:input :type "text" :size 10 |
| 609 | :accessor (presentation-slot-value currency instance)) |
| 610 | (<:as-html (format nil (if (as-money-p currency) |
| 611 | "$~$" |
| 612 | "~D") |
| 613 | (presentation-slot-value currency instance)) ))) |
| 614 | |
| 615 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 616 | ;;;; dates and times |
| 617 | |
| 618 | (defslot-presentation timestamp-slot-presentation (slot-presentation) |
| 619 | () |
| 620 | (:type-name timestamp)) |
| 621 | |
| 622 | (defmacro deftimestamp-slot-accessor (accessor time-accessor nth-value make-time-arg) |
| 623 | (let ((accessor-name (intern (strcat '#:timestamp-slot- accessor)))) |
| 624 | `(progn |
| 625 | (defgeneric ,accessor-name (slot instance)) |
| 626 | (defgeneric (setf ,accessor-name) (value slot instance)) |
| 627 | (defmethod ,accessor-name ((slot timestamp-slot-presentation) instance) |
| 628 | (when (presentation-slot-value slot instance) |
| 629 | (nth-value ,nth-value (,time-accessor (presentation-slot-value slot instance))))) |
| 630 | (defmethod (setf ,accessor-name) ((value integer) (slot timestamp-slot-presentation) instance) |
| 631 | (if (presentation-slot-value slot instance) |
| 632 | (setf (presentation-slot-value slot instance) |
| 633 | (make-time ,make-time-arg value :defaults (presentation-slot-value slot instance))) |
| 634 | (setf (presentation-slot-value slot instance) (make-time ,make-time-arg value)))) |
| 635 | (defmethod (setf ,accessor-name) ((value string) (slot timestamp-slot-presentation) instance) |
| 636 | (setf (,accessor-name slot instance) |
| 637 | (if (string= "" value) |
| 638 | nil |
| 639 | (parse-integer value)))) |
| 640 | (defmethod (setf ,accessor-name) ((value null) (slot timestamp-slot-presentation) instance) |
| 641 | (setf (presentation-slot-value slot instance) nil))))) |
| 642 | |
| 643 | (deftimestamp-slot-accessor second time-hms 2 :second) |
| 644 | (deftimestamp-slot-accessor minute time-hms 1 :minute) |
| 645 | (deftimestamp-slot-accessor hour time-hms 0 :hour) |
| 646 | (deftimestamp-slot-accessor year time-ymd 0 :year) |
| 647 | (deftimestamp-slot-accessor month time-ymd 1 :month) |
| 648 | (deftimestamp-slot-accessor day time-ymd 2 :day) |
| 649 | |
| 650 | (defslot-presentation ymd-slot-presentation (timestamp-slot-presentation) |
| 651 | () |
| 652 | (:type-name date)) |
| 653 | |
| 654 | (defmethod present-slot ((slot ymd-slot-presentation) instance) |
| 655 | (if (editablep slot) |
| 656 | (<:progn |
| 657 | (<ucw:input :class (css-class slot) :type "text" :size 2 |
| 658 | :accessor (timestamp-slot-day slot instance)) |
| 659 | "/" |
| 660 | (<ucw:input :class (css-class slot) :type "text" :size 2 |
| 661 | :accessor (timestamp-slot-month slot instance)) |
| 662 | "/" |
| 663 | (<ucw:input :class (css-class slot) :type "text" :size 4 |
| 664 | :accessor (timestamp-slot-year slot instance))) |
| 665 | (if (presentation-slot-value slot instance) |
| 666 | (<:progn |
| 667 | (<:as-html (timestamp-slot-day slot instance)) |
| 668 | "/" |
| 669 | (<:as-html (timestamp-slot-month slot instance)) |
| 670 | "/" |
| 671 | (<:as-html (timestamp-slot-year slot instance))) |
| 672 | (<:as-html "---")))) |
| 673 | |
| 674 | (defmethod applicable-criteria nconc ((slot ymd-slot-presentation)) |
| 675 | (criteria-for-slot-presentation slot |
| 676 | date-before-criteria)) |
| 677 | |
| 678 | (defslot-critera date-before-criteria (criteria) |
| 679 | ((target :accessor target)) |
| 680 | :label "Date Before:") |
| 681 | |
| 682 | (defmethod render-on ((res response) (dbc date-before-criteria)) |
| 683 | (<:as-html "Date Before: ")) |
| 684 | |
| 685 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 686 | ;;;; Relations |
| 687 | |
| 688 | (defcomponent relation-slot-presentation (slot-presentation) |
| 689 | ((presentation :accessor presentation |
| 690 | :initarg :presentation |
| 691 | :documentation "The class of presentation |
| 692 | objects used to fill the options of a select |
| 693 | tag.") |
| 694 | (search-presentation :accessor search-presentation |
| 695 | :initarg :search-presentation |
| 696 | :initform nil) |
| 697 | (allow-nil-p :accessor allow-nil-p |
| 698 | :initarg :allow-nil-p |
| 699 | :initform t |
| 700 | :documentation "Can this relation not exist."))) |
| 701 | |
| 702 | (defmethod presentation ((slot relation-slot-presentation)) |
| 703 | (with-slots (presentation) |
| 704 | slot |
| 705 | (if (or (symbolp presentation) |
| 706 | (consp presentation)) |
| 707 | (setf presentation (apply #'make-instance (ensure-list presentation))) |
| 708 | presentation))) |
| 709 | |
| 710 | (defgeneric get-foreign-instances (pres instance)) |
| 711 | |
| 712 | (defcomponent relation-criteria (criteria presentation-search) |
| 713 | ((criteria :accessor criteria :initform '()))) |
| 714 | |
| 715 | (defmethod search-presentation ((criteria relation-criteria)) |
| 716 | (or (search-presentation (presentation criteria)) |
| 717 | (presentation (presentation criteria)))) |
| 718 | |
| 719 | ;;;; One-Of |
| 720 | |
| 721 | (defslot-presentation one-of-presentation (relation-slot-presentation) |
| 722 | ((none-label :initarg :none-label :accessor none-label |
| 723 | :initform "none")) |
| 724 | (:type-name one-of)) |
| 725 | |
| 726 | (defmethod present-slot ((slot one-of-presentation) instance) |
| 727 | (if (editablep slot) |
| 728 | (<ucw:select :accessor (presentation-slot-value slot instance) |
| 729 | (when (allow-nil-p slot) |
| 730 | (<ucw:option :value nil (<:as-html (none-label slot)))) |
| 731 | (dolist (option (get-foreign-instances (presentation slot) instance)) |
| 732 | (setf (instance (presentation slot)) option) |
| 733 | (<ucw:option :value option (present (presentation slot))))) |
| 734 | (if (presentation-slot-value slot instance) |
| 735 | (progn |
| 736 | (setf (instance (presentation slot)) (presentation-slot-value slot instance)) |
| 737 | (present (presentation slot))) |
| 738 | (<:as-html "--")))) |
| 739 | |
| 740 | (defmethod applicable-criteria nconc ((slot one-of-presentation)) |
| 741 | (criteria-for-slot-presentation slot |
| 742 | one-of-criteria |
| 743 | one-of-not-null)) |
| 744 | |
| 745 | (defslot-critera one-of-criteria (relation-criteria) |
| 746 | ()) |
| 747 | |
| 748 | (defmethod label ((ooc one-of-criteria)) |
| 749 | (strcat (label (presentation ooc)) " with:")) |
| 750 | |
| 751 | (defmethod render-on ((res response) (ooc one-of-criteria)) |
| 752 | (<:as-html (label (presentation ooc)) " with:") |
| 753 | (render-criteria res ooc)) |
| 754 | |
| 755 | (defmethod apply-criteria and ((ooc one-of-criteria) instance) |
| 756 | (let ((nested-instance (presentation-slot-value (presentation ooc) instance)) |
| 757 | (criteria (criteria ooc))) |
| 758 | (if criteria |
| 759 | (if nested-instance |
| 760 | (dolist (c (criteria ooc) t) |
| 761 | (unless (apply-criteria c nested-instance) |
| 762 | (return-from apply-criteria nil))) |
| 763 | nil) |
| 764 | t))) |
| 765 | |
| 766 | (defslot-critera one-of-not-null (criteria) |
| 767 | ()) |
| 768 | |
| 769 | (defmethod label ((oonn one-of-not-null)) |
| 770 | (strcat (label (presentation oonn)) " exists.")) |
| 771 | |
| 772 | (defmethod apply-criteria and ((oonn one-of-not-null) instance) |
| 773 | (not (null (presentation-slot-value (presentation oonn) instance)))) |
| 774 | |
| 775 | (defmethod render-on ((res response) (oonn one-of-not-null)) |
| 776 | (<:as-html (label (presentation oonn)) " exists.")) |
| 777 | |
| 778 | ;;;; Some-Of |
| 779 | |
| 780 | (defslot-presentation some-of-presentation (relation-slot-presentation) |
| 781 | () |
| 782 | (:type-name some-of)) |
| 783 | |
| 784 | (defmethod present-slot ((slot some-of-presentation) instance) |
| 785 | (<:ul |
| 786 | (if (presentation-slot-value slot instance) |
| 787 | (loop |
| 788 | for option in (presentation-slot-value slot instance) |
| 789 | for index upfrom 0 |
| 790 | do (let ((option option) ;; loop changes the values, it does |
| 791 | ;; not create fresh bindings |
| 792 | (index index)) |
| 793 | (<:li |
| 794 | (<:table |
| 795 | (<:tr |
| 796 | (<:td (setf (instance (presentation slot)) option) |
| 797 | (present (presentation slot))) |
| 798 | (when (editablep slot) |
| 799 | (<:td :align "left" :valign "top" |
| 800 | (<ucw:input :type "submit" |
| 801 | :action (delete-element slot instance option index) |
| 802 | :value (concatenate 'string "Delete " (label slot)))))))))) |
| 803 | (<:li "None.")) |
| 804 | (render-add-new-item slot instance))) |
| 805 | |
| 806 | (defmethod render-add-new-item ((slot some-of-presentation) instance) |
| 807 | (let ((new-object nil) |
| 808 | (foreign-instances (get-foreign-instances (presentation slot) instance))) |
| 809 | (when (and foreign-instances (editablep slot)) |
| 810 | (<:li "Add: " |
| 811 | (<ucw:select :accessor new-object |
| 812 | (dolist (option foreign-instances) |
| 813 | (setf (instance (presentation slot)) option) |
| 814 | (<ucw:option :value option (present (presentation slot))))) |
| 815 | (<ucw:input :type "submit" |
| 816 | :action (add-element slot instance new-object) |
| 817 | :value "Add"))))) |
| 818 | |
| 819 | (defaction add-element ((some-of some-of-presentation) instance item) |
| 820 | (push item (presentation-slot-value some-of instance))) |
| 821 | |
| 822 | (defaction delete-element ((some-of some-of-presentation) instance item index) |
| 823 | (let ((nth (nth index (presentation-slot-value some-of instance)))) |
| 824 | (unless (eq nth item) |
| 825 | (error "Attempting to delete the ~Dth item, which should be ~S, but the ~Dth item is actually ~S." |
| 826 | index item index nth)) |
| 827 | (setf (presentation-slot-value some-of instance) |
| 828 | (iterate |
| 829 | (for element in (presentation-slot-value some-of instance)) |
| 830 | (for i upfrom 0) |
| 831 | (unless (= index i) |
| 832 | (collect element)))))) |
| 833 | |
| 834 | (defmethod applicable-criteria nconc ((slot some-of-presentation)) |
| 835 | (criteria-for-slot-presentation slot |
| 836 | some-of-any |
| 837 | some-of-all)) |
| 838 | |
| 839 | (defslot-critera some-of-criteria (relation-criteria) |
| 840 | ()) |
| 841 | |
| 842 | (defmethod render-on ((res response) (soa some-of-criteria)) |
| 843 | (<:as-html (label soa)) |
| 844 | (render-criteria res soa)) |
| 845 | |
| 846 | (defmacro defsome-of-criteria (name supers slots &key label apply-criteria) |
| 847 | (with-unique-names (obj) |
| 848 | `(progn |
| 849 | (defslot-critera ,name ,supers ,slots) |
| 850 | (defmethod label ((,obj ,name)) |
| 851 | (format nil ,label (label (presentation ,obj)))) |
| 852 | (defmethod apply-criteria and ((,obj ,name) instance) |
| 853 | (let ((nested-instances (presentation-slot-value (presentation ,obj) instance)) |
| 854 | (criteria (criteria ,obj))) |
| 855 | (if criteria |
| 856 | (if nested-instances |
| 857 | (funcall ,apply-criteria (criteria ,obj) nested-instances) |
| 858 | nil) |
| 859 | t)))))) |
| 860 | |
| 861 | (defsome-of-criteria some-of-any (some-of-criteria) |
| 862 | () |
| 863 | :label "Any ~A with:" |
| 864 | :apply-criteria (lambda (criteria nested-instances) |
| 865 | ;; return T if any nested-instance meets all of criteria |
| 866 | (some (lambda (instance) |
| 867 | (every (lambda (criteria) |
| 868 | (apply-criteria criteria instance)) |
| 869 | criteria)) |
| 870 | nested-instances))) |
| 871 | |
| 872 | (defsome-of-criteria some-of-all (some-of-criteria) |
| 873 | () |
| 874 | :label "All ~A with:" |
| 875 | :apply-criteria (lambda (criteria nested-instances) |
| 876 | ;; return T only if every nested-instances meets |
| 877 | ;; all of our criteria |
| 878 | (every (lambda (instance) |
| 879 | (every (lambda (criteria) |
| 880 | (apply-criteria criteria instance)) |
| 881 | criteria)) |
| 882 | nested-instances))) |
| 883 | |
| 884 | ;;;; An-Object |
| 885 | |
| 886 | (defslot-presentation an-object-presentation (one-of-presentation) |
| 887 | () |
| 888 | (:type-name an-object)) |
| 889 | |
| 890 | (defmethod present-slot ((slot an-object-presentation) instance) |
| 891 | (if (presentation-slot-value slot instance) |
| 892 | (progn |
| 893 | (setf (instance (presentation slot)) (presentation-slot-value slot instance)) |
| 894 | (present (presentation slot)) |
| 895 | (<ucw:input :type "submit" :action (delete-an-object slot instance) |
| 896 | :value (concatenate 'string "Delete " (label slot)))) |
| 897 | (<ucw:input :type "submit" :action (create-an-object slot instance) :value "Create"))) |
| 898 | |
| 899 | (defaction delete-an-object ((slot an-object-presentation) instance) |
| 900 | (setf (presentation-slot-value slot instance) nil)) |
| 901 | |
| 902 | (defaction create-an-object ((slot an-object-presentation) instance) |
| 903 | (let ((obj (make-new-instance (presentation slot) instance))) |
| 904 | (format t "Setting (presentation-slot-value ~S ~S) to ~S.~%" slot instance obj) |
| 905 | (setf (presentation-slot-value slot instance) obj))) |
| 906 | |
| 907 | ;;;; Some-Objects |
| 908 | |
| 909 | (defslot-presentation some-objects-presentation (some-of-presentation) |
| 910 | () |
| 911 | (:type-name some-objects)) |
| 912 | |
| 913 | (defmethod render-add-new-item ((slot some-objects-presentation) instance) |
| 914 | (when (editablep slot) |
| 915 | (<:li (<ucw:input :type "submit" |
| 916 | :action (add-an-object slot instance) |
| 917 | :value "Add new object.")))) |
| 918 | |
| 919 | (defgeneric make-new-instance (presentation instance) |
| 920 | (:documentation "Create an new instance suitable for |
| 921 | PRESENTATION which will be added to INSTANCE (according to |
| 922 | PRESENTATION).")) |
| 923 | |
| 924 | (defaction add-an-object ((slot some-objects-presentation) instance) |
| 925 | (push (make-new-instance (presentation slot) instance) (presentation-slot-value slot instance))) |
| 926 | |
| 927 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 928 | ;;;; Convience macros/functions |
| 929 | |
| 930 | (defmacro slot-presentations (&rest slot-specs) |
| 931 | `(list ,@(mapcar (lambda (slot) |
| 932 | (let ((class-name (gethash (car slot) *presentation-slot-type-mapping*))) |
| 933 | (if class-name |
| 934 | `(make-instance ',class-name ,@(cdr slot)) |
| 935 | (error "Unknown slot type ~S." (car slot))))) |
| 936 | slot-specs))) |
| 937 | |
| 938 | (defmacro defpresentation (name supers slots &rest default-initargs) |
| 939 | `(defcomponent ,name ,supers |
| 940 | () |
| 941 | (:default-initargs |
| 942 | ,@(when slots `(:slots (slot-presentations ,@slots))) |
| 943 | ,@default-initargs))) |
| 944 | |