weblocks-dev / src / views / types / presentations / checkboxes.lisp

(in-package :weblocks)

(export '(checkboxes checkboxes-presentation checkboxes-parser render-checkboxes))

(defclass checkboxes-presentation (form-presentation choices-presentation-mixin)

(defmethod obtain-presentation-choices ((choices-mixin checkboxes-presentation) obj)
  (mapcar (lambda (cons) (cons (car cons)
                               (intern (string-upcase (cdr cons)) :keyword)))

(defmethod render-view-field ((field form-view-field) (view form-view)
                              widget (presentation checkboxes-presentation) value obj
                              &rest args &key validation-errors &allow-other-keys)
  (let* ((attribute-slot-name (attributize-name (view-field-slot-name field)))
         (validation-error (assoc attribute-slot-name validation-errors
                                  :test #'string-equal
                                  :key #'view-field-slot-name))
         (field-class (concatenate 'string attribute-slot-name
                                   (when validation-error " item-not-validated"))))
      (:li :class field-class
           (:span :class "label"
                  (:span :class "slot-name"
                         (:span :class "extra"
                                (str (view-field-label field)) ": "
                                (when (form-view-field-required-p field)
                                  (htm (:em :class "required-slot" "(required) "))))))
           (apply #'render-view-field-value
                  value presentation
                  field view widget obj
           (when validation-error
             (htm (:p :class "validation-error"
                       (:span :class "validation-error-heading" "Error: ")
                       (str (format nil "~A" (cdr validation-error)))))))))))

(defmethod render-view-field-value (value (presentation checkboxes-presentation)
                                    (field form-view-field) (view form-view) widget obj
                                    &rest args &key intermediate-values &allow-other-keys)
  (declare (ignore args))
  (multiple-value-bind (intermediate-value intermediate-value-p)
      (form-field-intermediate-value field intermediate-values)
    (render-checkboxes (view-field-slot-name field)
                       (obtain-presentation-choices presentation obj)
                       :selected-values (when (or value intermediate-value)
                                          (mapcar (compose (curry-after #'intern :keyword) #'string-upcase)
                                                  (if intermediate-value-p

(defmethod render-view-field-value (value (presentation checkboxes-presentation)
                                    field view widget obj &rest args
                                    &key highlight &allow-other-keys)
  (declare (ignore highlight args))
  (if (null value)
      (mapcar #'(lambda (value)
                    (:span value))) value)))

(defun render-checkboxes (name selections &key id (class "checkbox") selected-values)
  (dolist (val selections)
    (let ((checked-p (if (find (cdr val) selected-values :test #'equal) "checked" nil))
          (label (if (consp val) (car val) val))
          (value (if (consp val) (cdr val) val)))
      (:input :name (attributize-name name) :type "checkbox" :id id :class class
	      :checked checked-p :value value (str (humanize-name label)))))))

(defmethod request-parameter-for-presentation (name (presentation checkboxes-presentation))
  (declare (ignore presentation))
  (post-parameter->list name))

(defclass checkboxes-parser (parser)
  (:documentation "A parser for checkboxes"))

(defun post-parameter->list (param)
  (loop for x in (hunchentoot:post-parameters*)
        when (equalp (car x) param)
        collect (cdr x)))

(defmethod parse-view-field-value ((parser checkboxes-parser) value obj
                                   (view form-view) (field form-view-field) &rest args)
  (declare (ignore args))
  (let ((result (mapcar (compose (curry-after #'intern "KEYWORD") #'string-upcase)
                          (symbol-name (view-field-slot-name field))))))
      (values t result result)))

;; ; usage
;;   (dressings :present-as (checkboxes :choices (f_ '(mustard onions cheese)))
;;              :parse-as checkboxes)
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.