src/static-presentations.lisp

   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   (<ucw:input :type "checkbox" :accessor (presentation-slot-value slot instance)))
 426
 427 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 428 ;;;; strings
 429
 430 (defslot-presentation string-slot-presentation ()
 431   ((max-length :accessor max-length :initarg :max-length :initform nil)
 432    (size :accessor size :initarg :size :initform nil))
 433   (:type-name string))
 434
 435 (defmethod present-slot ((slot string-slot-presentation) instance)
 436   (if (editablep slot)
 437       (<ucw:input :type "text"
 438                   :accessor (presentation-slot-value slot instance)
 439                   :size (or (size slot)
 440                             (if (string= "" (presentation-slot-value slot instance))
 441                                 (size slot)
 442                                 (+ 3 (length (presentation-slot-value slot instance)))))
 443                   :maxlength (max-length slot))
 444       (<:as-html (presentation-slot-value slot instance))))
 445
 446 ;;;; Critera
 447
 448 (defmethod applicable-criteria nconc ((s string-slot-presentation))
 449   (criteria-for-slot-presentation s
 450     string-starts-with
 451     string-contains
 452     string-ends-with))
 453
 454 (defcomponent string-criteria (criteria)
 455   ((search-text :accessor search-text :initform nil)))
 456
 457 (defmethod render-on ((res response) (criteria string-criteria))
 458   (<:as-html (label criteria) " ")
 459   (<ucw:input :type "text" :accessor (search-text criteria) :size 10))
 460
 461 (defslot-critera string-contains (string-criteria)
 462   ()
 463   :label "~A contains:"
 464   :apply-criteria (lambda (criteria instance slot-value)
 465                     (declare (ignore instance))
 466                     (and (<= (length (search-text criteria)) (length slot-value))
 467                          (search (search-text criteria) slot-value :test #'char-equal))))
 468
 469 (defslot-critera string-starts-with (string-contains)
 470   ()
 471   :label "~A starts with:"
 472   :apply-criteria (lambda (criteria instance slot-value)
 473                     (declare (ignore instance))
 474                     (and (<= (length (search-text criteria)) (length slot-value))
 475                          (= 0 (or (search (search-text criteria) slot-value
 476                                           :test #'char-equal)
 477                                   -1)))))
 478
 479 (defslot-critera string-ends-with (string-contains)
 480   ()
 481   :label "~A ends with:"
 482   :apply-criteria (lambda (criteria instance slot-value)
 483                     (declare (ignore instance))
 484                     (and  (<= (length (search-text criteria)) (length slot-value))
 485                           (= (- (length slot-value) (length (search-text criteria)))
 486                              (or (search (search-text criteria) slot-value
 487                                          :from-end t
 488                                          :test #'char-equal)
 489                                  -1)))))
 490
 491 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 492 ;;;; numbers
 493
 494 (defslot-presentation number-slot-presentation ()
 495   ((min-value :accessor min-value :initarg :min-value :initform nil)
 496    (max-value :accessor max-value :initarg :max-value :initform nil)))
 497
 498 (defcomponent number-criteria (criteria)
 499   ((number-input :accessor number-input :initform nil)))
 500
 501 (defmethod applicable-criteria nconc ((s number-slot-presentation))
 502   (criteria-for-slot-presentation s
 503     number-less-than
 504     number-greater-than
 505     number-equal-to))
 506
 507 (defmacro defnumber-criteria (name &key label render-on-prefix apply-criteria)
 508   `(progn
 509      (defslot-critera ,name (number-criteria)
 510        ()
 511        :label ,label
 512        :apply-criteria (lambda (criteria instance slot-value)
 513                          (declare (ignore instance))
 514                          (if (numberp slot-value)
 515                              (if (number-input criteria)
 516                                  (funcall ,apply-criteria slot-value (number-input criteria))
 517                                  t)
 518                              nil)))
 519
 520      (defmethod render-on ((res response) (obj ,name))
 521        (<:as-html (format nil ,render-on-prefix (label (presentation obj))))
 522        (<ucw:input :type "text"
 523                    :reader (or (number-input obj) "")
 524                    :writer (lambda (v)
 525                              (unless (string= "" v)
 526                                (let ((n (parse-float v)))
 527                                  (when n
 528                                    (setf (number-input obj) n)))))))))
 529
 530 (defnumber-criteria number-equal-to
 531   :apply-criteria (lambda (slot-value number-input)
 532                     (= slot-value number-input))
 533   :label "~A is equal to:"
 534   :render-on-prefix "~A = ")
 535
 536 (defnumber-criteria number-less-than
 537   :apply-criteria (lambda (slot-value number-input)
 538                     (< slot-value number-input))
 539   :label "~A is less than:"
 540   :render-on-prefix "~A < ")
 541
 542 (defnumber-criteria number-greater-than
 543   :apply-criteria (lambda (slot-value number-input)
 544                     (> slot-value number-input))
 545   :label "~A is greater than:"
 546   :render-on-prefix "~A > ")
 547
 548
 549 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 550 ;;;; Integers
 551
 552 (defslot-presentation integer-slot-presentation (number-slot-presentation)
 553   ()
 554   (:type-name integer))
 555
 556 (defmethod presentation-slot-value ((slot integer-slot-presentation) instance)
 557   (declare (ignore instance))
 558   (or (call-next-method) ""))
 559
 560 (defmethod (setf presentation-slot-value) ((value string) (slot integer-slot-presentation) instance)
 561   (unless (string= "" value)
 562     (let ((i (parse-integer value :junk-allowed t)))
 563       (when i
 564         (setf (presentation-slot-value slot instance) (parse-integer value))))))
 565
 566 (defmethod present-slot ((slot integer-slot-presentation) instance)
 567   (if (editablep slot)
 568       (<ucw:input :type "text"
 569                   :accessor (presentation-slot-value slot instance))
 570       (<:as-html (presentation-slot-value slot instance))))
 571
 572 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 573 ;;;; Reals
 574
 575 (defcomponent real-slot-presentation (number-slot-presentation)
 576   ())
 577
 578 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 579 ;;;; Currency (double precision reals)
 580
 581 (defslot-presentation currency-slot-presentation (real-slot-presentation)
 582   ()
 583   (:type-name currency))
 584
 585 (defmethod (setf presentation-slot-value) ((value string) (c currency-slot-presentation) instance)
 586   (let ((*read-eval* nil))
 587     (unless (string= "" value)
 588       (let ((value (read-from-string value)))
 589         (when (numberp value)
 590           (setf (presentation-slot-value c instance) value))))))
 591
 592 (defmethod present-slot ((currency currency-slot-presentation) instance)
 593   (if (editablep currency)
 594       (<ucw:input :type "text" :size 10
 595                   :accessor (presentation-slot-value currency instance))
 596       (<:as-html (presentation-slot-value currency instance))))
 597
 598 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 599 ;;;; dates and times
 600
 601 (defslot-presentation timestamp-slot-presentation (slot-presentation)
 602   ()
 603   (:type-name timestamp))
 604
 605 (defmacro deftimestamp-slot-accessor (accessor time-accessor nth-value make-time-arg)
 606   (let ((accessor-name (intern (strcat '#:timestamp-slot- accessor))))
 607     `(progn
 608        (defgeneric ,accessor-name (slot instance))
 609        (defgeneric (setf ,accessor-name) (value slot instance))
 610        (defmethod ,accessor-name ((slot timestamp-slot-presentation) instance)
 611          (when (presentation-slot-value slot instance)
 612            (nth-value ,nth-value (,time-accessor (presentation-slot-value slot instance)))))
 613        (defmethod (setf ,accessor-name) ((value integer) (slot timestamp-slot-presentation) instance)
 614          (if (presentation-slot-value slot instance)
 615              (setf (presentation-slot-value slot instance)
 616                    (make-time ,make-time-arg value :defaults (presentation-slot-value slot instance)))
 617              (setf (presentation-slot-value slot instance) (make-time ,make-time-arg value))))
 618        (defmethod (setf ,accessor-name) ((value string) (slot timestamp-slot-presentation) instance)
 619          (setf (,accessor-name slot instance)
 620                (if (string= "" value)
 621                    nil
 622                    (parse-integer value))))
 623        (defmethod (setf ,accessor-name) ((value null) (slot timestamp-slot-presentation) instance)
 624          (setf (presentation-slot-value slot instance) nil)))))
 625
 626 (deftimestamp-slot-accessor second time-hms 2 :second)
 627 (deftimestamp-slot-accessor minute time-hms 1 :minute)
 628 (deftimestamp-slot-accessor hour time-hms 0 :hour)
 629 (deftimestamp-slot-accessor year time-ymd 0 :year)
 630 (deftimestamp-slot-accessor month time-ymd 1 :month)
 631 (deftimestamp-slot-accessor day time-ymd 2 :day)
 632
 633 (defslot-presentation ymd-slot-presentation (timestamp-slot-presentation)
 634   ()
 635   (:type-name date))
 636
 637 (defmethod present-slot ((slot ymd-slot-presentation) instance)
 638   (if (editablep slot)
 639       (<:progn
 640         (<ucw:input :class (css-class slot) :type "text" :size 2
 641                     :accessor (timestamp-slot-day slot instance))
 642         "/"
 643         (<ucw:input :class (css-class slot) :type "text" :size 2
 644                     :accessor (timestamp-slot-month slot instance))
 645         "/"
 646         (<ucw:input :class (css-class slot) :type "text" :size 4
 647                     :accessor (timestamp-slot-year slot instance)))
 648       (if (presentation-slot-value slot instance)
 649           (<:progn
 650             (<:as-html (timestamp-slot-day slot instance))
 651             "/"
 652             (<:as-html (timestamp-slot-month slot instance))
 653             "/"
 654             (<:as-html (timestamp-slot-year slot instance)))
 655           (<:as-html "---"))))
 656
 657 (defmethod applicable-criteria nconc ((slot ymd-slot-presentation))
 658   (criteria-for-slot-presentation slot
 659     date-before-criteria))
 660
 661 (defslot-critera date-before-criteria (criteria)
 662   ((target :accessor target))
 663   :label "Date Before:")
 664
 665 (defmethod render-on ((res response) (dbc date-before-criteria))
 666   (<:as-html "Date Before: "))
 667
 668 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 669 ;;;; Relations
 670
 671 (defcomponent relation-slot-presentation (slot-presentation)
 672   ((presentation :accessor presentation
 673                  :initarg :presentation
 674                  :documentation "The class of presentation
 675                  objects used to fill the options of a select
 676                  tag.")
 677    (search-presentation :accessor search-presentation
 678                         :initarg :search-presentation
 679                         :initform nil)
 680    (allow-nil-p :accessor allow-nil-p
 681                 :initarg :allow-nil-p
 682                 :initform t
 683                 :documentation "Can this relation not exist.")))
 684
 685 (defmethod presentation ((slot relation-slot-presentation))
 686   (with-slots (presentation)
 687       slot
 688     (if (or (symbolp presentation)
 689             (consp presentation))
 690         (setf presentation (apply #'make-instance (ensure-list presentation)))
 691         presentation)))
 692
 693 (defgeneric get-foreign-instances (pres instance))
 694
 695 (defcomponent relation-criteria (criteria presentation-search)
 696   ((criteria :accessor criteria :initform '())))
 697
 698 (defmethod search-presentation ((criteria relation-criteria))
 699   (or (search-presentation (presentation criteria))
 700       (presentation (presentation criteria))))
 701
 702 ;;;; One-Of
 703
 704 (defslot-presentation one-of-presentation (relation-slot-presentation)
 705   ((none-label :initarg :none-label :accessor none-label
 706                :initform "none"))
 707   (:type-name one-of))
 708
 709 (defmethod present-slot ((slot one-of-presentation) instance)
 710   (if (editablep slot)
 711       (<ucw:select :accessor (presentation-slot-value slot instance)
 712         (when (allow-nil-p slot)
 713           (<ucw:option :value nil (<:as-html (none-label slot))))
 714         (dolist (option (get-foreign-instances (presentation slot) instance))
 715           (setf (instance (presentation slot)) option)
 716           (<ucw:option :value option (present (presentation slot)))))
 717       (if (presentation-slot-value slot instance)
 718           (progn
 719             (setf (instance (presentation slot)) (presentation-slot-value slot instance))
 720             (present (presentation slot)))
 721           (<:as-html "--"))))
 722
 723 (defmethod applicable-criteria nconc ((slot one-of-presentation))
 724   (criteria-for-slot-presentation slot
 725     one-of-criteria
 726     one-of-not-null))
 727
 728 (defslot-critera one-of-criteria (relation-criteria)
 729   ())
 730
 731 (defmethod label ((ooc one-of-criteria))
 732   (strcat (label (presentation ooc)) " with:"))
 733
 734 (defmethod render-on ((res response) (ooc one-of-criteria))
 735   (<:as-html (label (presentation ooc)) " with:")
 736   (render-criteria res ooc))
 737
 738 (defmethod apply-criteria and ((ooc one-of-criteria) instance)
 739   (let ((nested-instance (presentation-slot-value (presentation ooc) instance))
 740         (criteria (criteria ooc)))
 741     (if criteria
 742         (if nested-instance
 743             (dolist (c (criteria ooc) t)
 744               (unless (apply-criteria c nested-instance)
 745                 (return-from apply-criteria nil)))
 746             nil)
 747         t)))
 748
 749 (defslot-critera one-of-not-null (criteria)
 750   ())
 751
 752 (defmethod label ((oonn one-of-not-null))
 753   (strcat (label (presentation oonn)) " exists."))
 754
 755 (defmethod apply-criteria and ((oonn one-of-not-null) instance)
 756   (not (null (presentation-slot-value (presentation oonn) instance))))
 757
 758 (defmethod render-on ((res response) (oonn one-of-not-null))
 759   (<:as-html (label (presentation oonn)) " exists."))
 760
 761 ;;;; Some-Of
 762
 763 (defslot-presentation some-of-presentation (relation-slot-presentation)
 764   ()
 765   (:type-name some-of))
 766
 767 (defmethod present-slot ((slot some-of-presentation) instance)
 768   (<:ul
 769    (if (presentation-slot-value slot instance)
 770        (loop
 771           for option in (presentation-slot-value slot instance)
 772           for index upfrom 0
 773           do (let ((option option) ;; loop changes the values, it does
 774                                    ;; not create fresh bindings
 775                    (index index))
 776                (<:li
 777                  (<:table
 778                    (<:tr
 779                      (<:td (setf (instance (presentation slot)) option)
 780                            (present (presentation slot)))
 781                      (when (editablep slot)
 782                        (<:td :align "left" :valign "top"
 783                          (<ucw:input :type "submit"
 784                                      :action (delete-element slot instance option index)
 785                                      :value (concatenate 'string "Delete " (label slot))))))))))
 786        (<:li "None."))
 787    (render-add-new-item slot instance)))
 788
 789 (defmethod render-add-new-item ((slot some-of-presentation) instance)
 790   (let ((new-object nil)
 791         (foreign-instances (get-foreign-instances (presentation slot) instance)))
 792     (when (and foreign-instances (editablep slot))
 793       (<:li "Add: "
 794         (<ucw:select :accessor new-object
 795           (dolist (option foreign-instances)
 796             (setf (instance (presentation slot)) option)
 797             (<ucw:option :value option (present (presentation slot)))))
 798         (<ucw:input :type "submit"
 799                     :action (add-element slot instance new-object)
 800                     :value "Add")))))
 801
 802 (defaction add-element ((some-of some-of-presentation) instance item)
 803   (push item (presentation-slot-value some-of instance)))
 804
 805 (defaction delete-element ((some-of some-of-presentation) instance item index)
 806   (let ((nth (nth index (presentation-slot-value some-of instance))))
 807     (unless (eq nth item)
 808       (error "Attempting to delete the ~Dth item, which should be ~S, but the ~Dth item is actually ~S."
 809              index item index nth))
 810     (setf (presentation-slot-value some-of instance)
 811           (iterate
 812             (for element in (presentation-slot-value some-of instance))
 813             (for i upfrom 0)
 814             (unless (= index i)
 815               (collect element))))))
 816
 817 (defmethod applicable-criteria nconc ((slot some-of-presentation))
 818   (criteria-for-slot-presentation slot
 819     some-of-any
 820     some-of-all))
 821
 822 (defslot-critera some-of-criteria (relation-criteria)
 823   ())
 824
 825 (defmethod render-on ((res response) (soa some-of-criteria))
 826   (<:as-html (label soa))
 827   (render-criteria res soa))
 828
 829 (defmacro defsome-of-criteria (name supers slots &key label apply-criteria)
 830   (with-unique-names (obj)
 831     `(progn
 832        (defslot-critera ,name ,supers ,slots)
 833        (defmethod label ((,obj ,name))
 834          (format nil ,label (label (presentation ,obj))))
 835        (defmethod apply-criteria and ((,obj ,name) instance)
 836          (let ((nested-instances (presentation-slot-value (presentation ,obj) instance))
 837                (criteria (criteria ,obj)))
 838            (if criteria
 839                (if nested-instances
 840                    (funcall ,apply-criteria (criteria ,obj) nested-instances)
 841                    nil)
 842                t))))))
 843
 844 (defsome-of-criteria some-of-any (some-of-criteria)
 845   ()
 846   :label "Any ~A with:"
 847   :apply-criteria (lambda (criteria nested-instances)
 848                     ;; return T if any nested-instance meets all of criteria
 849                     (some (lambda (instance)
 850                             (every (lambda (criteria)
 851                                      (apply-criteria criteria instance))
 852                                    criteria))
 853                           nested-instances)))
 854
 855 (defsome-of-criteria some-of-all (some-of-criteria)
 856   ()
 857   :label "All ~A with:"
 858   :apply-criteria (lambda (criteria nested-instances)
 859                     ;; return T only if every nested-instances meets
 860                     ;; all of our criteria
 861                     (every (lambda (instance)
 862                              (every (lambda (criteria)
 863                                       (apply-criteria criteria instance))
 864                                     criteria))
 865                            nested-instances)))
 866
 867 ;;;; An-Object
 868
 869 (defslot-presentation an-object-presentation (one-of-presentation)
 870   ()
 871   (:type-name an-object))
 872
 873 (defmethod present-slot ((slot an-object-presentation) instance)
 874   (if (presentation-slot-value slot instance)
 875       (progn
 876         (setf (instance (presentation slot)) (presentation-slot-value slot instance))
 877         (present (presentation slot))
 878         (<ucw:input :type "submit" :action (delete-an-object slot instance)
 879                     :value (concatenate 'string "Delete " (label slot))))
 880       (<ucw:input :type "submit" :action (create-an-object slot instance) :value "Create")))
 881
 882 (defaction delete-an-object ((slot an-object-presentation) instance)
 883   (setf (presentation-slot-value slot instance) nil))
 884
 885 (defaction create-an-object ((slot an-object-presentation) instance)
 886   (let ((obj (make-new-instance (presentation slot) instance)))
 887     (format t "Setting (presentation-slot-value ~S ~S) to ~S.~%" slot instance obj)
 888     (setf (presentation-slot-value slot instance) obj)))
 889
 890 ;;;; Some-Objects
 891
 892 (defslot-presentation some-objects-presentation (some-of-presentation)
 893   ()
 894   (:type-name some-objects))
 895
 896 (defmethod render-add-new-item ((slot some-objects-presentation) instance)
 897   (when (editablep slot)
 898     (<:li (<ucw:input :type "submit"
 899                       :action (add-an-object slot instance)
 900                       :value "Add new object."))))
 901
 902 (defgeneric make-new-instance (presentation instance)
 903   (:documentation "Create an new instance suitable for
 904   PRESENTATION which will be added to INSTANCE (according to
 905   PRESENTATION)."))
 906
 907 (defaction add-an-object ((slot some-objects-presentation) instance)
 908   (push (make-new-instance (presentation slot) instance) (presentation-slot-value slot instance)))
 909
 910 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 911 ;;;; Convience macros/functions
 912
 913 (defmacro slot-presentations (&rest slot-specs)
 914   `(list ,@(mapcar (lambda (slot)
 915                      (let ((class-name (gethash (car slot) *presentation-slot-type-mapping*)))
 916                        (if class-name
 917                            `(make-instance ',class-name ,@(cdr slot))
 918                            (error "Unknown slot type ~S." (car slot)))))
 919                    slot-specs)))
 920
 921 (defmacro defpresentation (name supers slots &rest default-initargs)
 922   `(defcomponent ,name ,supers
 923      ()
 924      (:default-initargs
 925        ,@(when slots `(:slots (slot-presentations ,@slots)))
 926        ,@default-initargs)))
 927