src/mewa/presentations.lisp

   1 (in-package :mewa)
   2
   3
   4
   5  (defun split-list (n list)
   6   (loop for cons on list
   7         by #'(lambda (x) (nthcdr n x))
   8         if (< 0 n)
   9         collect (loop for atom in cons
  10                       repeat n
  11                       collect atom)
  12         else return nil))
  13
  14 (defaction edit-instance ((self mewa))
  15   (call-presentation (instance self) :type :editor))
  16
  17 ;;;one-line objects
  18 (defcomponent mewa-one-line-presentation (mewa one-line-presentation)
  19   ()
  20   (:default-initargs
  21    :attributes-getter #'one-line-attributes-getter
  22    :global-properties '(:editablep nil)))
  23
  24 (defmethod one-line-attributes-getter ((self mewa))
  25   (or (meta-model::find-slots-of-type (instance self))
  26       (meta-model::list-keys (instance self))))
  27
  28 ;;;objects
  29 (defcomponent mewa-object-presentation (mewa object-presentation)
  30   ((instance :accessor instance :initarg :instance :initform nil)))
  31
  32 (defcomponent mewa-viewer (mewa-object-presentation)
  33   ()
  34   (:default-initargs
  35    :global-properties '(:editablep nil)))
  36
  37 (defcomponent mewa-editor (mewa-object-presentation)
  38   ()
  39   (:default-initargs
  40    :global-properties '(:editablep t)))
  41
  42 (defcomponent mewa-creator (mewa-editor)
  43   ())
  44
  45 (defmethod present ((pres mewa-object-presentation))
  46   (<:table :class (css-class pres)
  47     (dolist (slot (slots pres))
  48       (<:tr :class "presentation-slot-row"
  49             (present-slot-as-row pres slot))))
  50     (render-options pres (instance pres)))
  51
  52 (defmethod present-slot-as-row ((pres mewa-object-presentation) (slot slot-presentation))
  53   (<:td :class "presentation-slot-label" (<:as-html (label slot)))
  54   (<:td :class "presentation-slot-value" (present-slot slot (instance pres))))
  55
  56
  57 (defcomponent two-column-presentation (mewa-object-presentation) ())
  58
  59 (defmethod present ((pres two-column-presentation))
  60
  61   (<:table :class (css-class pres)
  62            (loop for slot on (slots pres) by #'cddr
  63                  do
  64                  (<:tr :class "presentation-slot-row"
  65                        (<:td :class "presentation-slot-label"
  66                              (<:as-html (label (first slot))))
  67                        (<:td :class "presentation-slot-value"
  68                              (present-slot (first slot) (instance pres)))
  69                        (when (second slot)
  70                          (<:td :class "presentation-slot-label"
  71                                (<:as-html (label (second slot))))
  72                          (<:td :class "presentation-slot-value"
  73                                (present-slot (second slot) (instance pres))))))
  74            (render-options pres (instance pres))))
  75
  76
  77 ;;;lists
  78 (defcomponent mewa-list-presentation (mewa list-presentation)
  79   ((instances :accessor instances :initarg :instances :initform nil)
  80    (instance :accessor instance)
  81    (select-label :accessor select-label :initform "select" :initarg :select-label)
  82    (selectablep :accessor selectablep :initform t :initarg :selectablep)
  83    (deleteablep :accessor deletablep :initarg :deletablep :initform nil)
  84    (viewablep :accessor viewablep :initarg :viewablep :initform nil)))
  85
  86 (defaction select-from-listing ((listing mewa-list-presentation) object index)
  87   (answer object))
  88
  89 (defmethod render-list-row ((listing mewa-list-presentation) object index)
  90   (<:tr :class "item-row"
  91     (<:td :align "center" :valign "top"
  92       (when (editablep listing)
  93         (let ((object object))
  94           (<ucw:input :type "submit"
  95                       :action (edit-from-listing listing object index)
  96                       :value (edit-label listing))))
  97       (<:as-is " ")
  98       (when (deleteablep listing)
  99         (let ((index index))
 100           (<ucw:input :type "submit"
 101                       :action (delete-from-listing listing object index)
 102                       :value (delete-label listing))))
 103       (when (selectablep listing)
 104         (let ((index index))
 105           (<ucw:input :type "submit"
 106                       :action (select-from-listing listing object index)
 107                       :value (select-label listing))))
 108       (when (viewablep listing)
 109         (let ((index index))
 110           (<ucw:input :type "submit"
 111                       :action (call-component listing  (make-presentation object))
 112                       :value "view"))))
 113     (dolist (slot (slots listing))
 114       (<:td :class "data-cell" (present-slot slot object)))
 115     (<:td :class "index-number-cell")
 116     ))
 117
 118 (defmethod get-all-instances ((self mewa-list-presentation))
 119   (instances self))
 120
 121
 122 ;;;; * Presentation Searches
 123
 124
 125 ;;;; ** "search all fields" criteria
 126
 127 (defgeneric search-expr (criteria instance)
 128   (:documentation "Return ready to apply criteria.
 129                    What to do with it is backend dependent."))
 130
 131 (defmacro def-search-expr (((self criteria-type)) (model-expr &body body))
 132   `(defmethod search-expr ((,self ,criteria-type) instance)
 133      (,model-expr
 134       instance
 135       (slot-name (presentation ,self))
 136       ,@body)))
 137
 138 (defmethod search-expr ((self negated-criteria) instance)
 139   (when (criteria self)
 140     (meta-model:expr-not
 141      instance
 142      (search-expr (criteria self) instance))))
 143
 144 (def-search-expr ((self string-starts-with))
 145     (meta-model:expr-starts-with (search-text self)))
 146
 147 (def-search-expr ((self string-ends-with))
 148     (meta-model:expr-ends-with (search-text self)))
 149
 150 (def-search-expr ((self string-contains))
 151     (meta-model:expr-contains (search-text self)))
 152
 153 (def-search-expr ((self number-less-than))
 154     (meta-model:expr-< (number-input self)))
 155
 156 (def-search-expr ((self number-greater-than))
 157     (meta-model:expr-> (number-input self)))
 158
 159 (def-search-expr ((self number-equal-to))
 160     (meta-model:expr-= (number-input self)))
 161
 162
 163
 164 (defcomponent mewa-presentation-search (presentation-search)
 165   ((display-results-p :accessor display-results-p :initarg :display-results-p :initform nil)
 166    (criteria-input :accessor criteria-input :initform "")
 167    (new-criteria :accessor new-criteria :initform nil)))
 168
 169 (defmethod instance ((self mewa:mewa-presentation-search))
 170   (instance (search-presentation self)))
 171
 172 (defmethod search-expr ((self mewa:mewa-presentation-search) instance)
 173   (apply #'meta-model:expr-and instance
 174          (mapcan (lambda (c) (let ((e  (search-expr c instance)))
 175                                (if (listp e) e (list e))))
 176                  (criteria self))))
 177
 178 (defmethod search-query ((self mewa:mewa-presentation-search))
 179   (search-expr self (instance self)))
 180
 181 (defmethod valid-instances ((self mewa:mewa-presentation-search))
 182   (meta-model:select-instances (instance self) (search-query self)))
 183
 184 (defmethod get-all-instances ((self mewa-presentation-search))
 185   (meta-model:select-instances (instance self)))
 186
 187 (defmethod ok ((self mewa-presentation-search) &optional arg)
 188   (declare (ignore arg))
 189   (setf (instances (list-presentation self)) (valid-instances self))
 190   (setf (display-results-p self) t))
 191
 192
 193 (defmethod set-search-input-for-criteria ((criteria criteria) (input t))
 194   (error "No search-input-for-criteria method for ~A : ~A" criteria input))
 195
 196 (defmethod set-search-input-for-criteria ((c string-criteria) input)
 197   (setf (search-text c) input))
 198
 199 (defmethod set-search-input-for-criteria ((c negated-criteria) i)
 200   nil)
 201
 202
 203 (defmethod mewa-add-criteria ((self component) (criteria criteria))
 204   (set-search-input-for-criteria criteria (criteria-input self))
 205   (add-criteria self criteria))
 206
 207 (defmethod find-default-criteria (c mewa-string-slot-presentation)
 208   'string-contains)
 209
 210
 211
 212 (defmethod render-criteria ((res response) (s mewa-presentation-search))
 213   (setf (criteria-input s) "")
 214   (<:ul
 215    (dolist (c (criteria s))
 216      (<:li (render-on res c)
 217            (let ((c c))
 218              (<ucw:input :action (drop-criteria s c) :type "submit" :value "eliminate"))))
 219      (<:li
 220       "Search For: "
 221       (<ucw:input :type "text" :accessor (criteria-input s))
 222       " Using : "
 223        (<ucw:select :accessor (new-criteria s)
 224          (dolist (criteria (applicable-criteria s))
 225            (<ucw:option :value criteria (<:as-html (label criteria)))))
 226        (<ucw:input :type "submit" :action (mewa-add-criteria s (new-criteria s))
 227                    :value "add"))))
 228
 229 (defmethod submit-search ((s mewa-presentation-search))
 230   (with-slots (criteria-input) s
 231
 232     (unless (or (null criteria-input)
 233                 (string-equal "" (remove #\Space criteria-input)))
 234
 235       (mewa-add-criteria s (new-criteria s)))
 236
 237     (ok s)))
 238
 239 (defmethod render-on ((res response) (self mewa-presentation-search))
 240   ;(<:as-html (search-query self))
 241   (render-criteria res self)
 242   (<ucw:input :type "submit" :value "Search" :action (submit-search self))
 243   (when (display-results-p self)
 244     (let ((listing (list-presentation self)))
 245       (setf
 246        (slot-value listing 'ucw::calling-component) (slot-value self 'ucw::calling-component)
 247        (slot-value listing 'ucw::place) (slot-value self 'ucw::place)
 248        (slot-value listing 'ucw::continuation) (slot-value self 'ucw::continuation))
 249
 250       (render-on res listing))))
 251
 252
 253 ;;;;
 254 (defcomponent dont-show-unset-slots ()())
 255
 256 (defmethod slots :around ((self dont-show-unset-slots))
 257   (remove-if-not #'(lambda (s) (let ((s (presentation-slot-value s (instance self))))
 258                                  (and s (not (equal "" s)))))
 259                  (call-next-method)))