src/ucw/html-description.lisp

   1 (in-package :lisp-on-lines)
   2
   3 (export '(html-description) (find-package :lisp-on-lines))
   4
   5 (defvar *escape-html* t)
   6
   7 (defmethod generic-format ((display ucw-core:component) string &rest args)
   8   (<:as-html (with-output-to-string (stream)
   9                (apply #'call-next-method stream string args))))
  10
  11 (define-description html-description ()
  12   ())
  13
  14 (define-description t ()
  15   ((css-class  :value "lol-description" :activep nil)
  16    (dom-id :function (lambda (x)
  17                        (declare (ignore x))
  18                        (symbol-name
  19                         (gensym "DOM-ID-")))
  20            :activep nil))
  21   (:in-description html-description))
  22
  23 (define-layered-class html-attribute ()
  24   ((css-class :accessor attribute-css-class
  25               :initform "lol-attribute")
  26    (dom-id :accessor attribute-dom-id :initform nil)
  27    (value-tag :accessor attribute-html-tag :initform nil :initarg :html-tag)
  28    (display-empty-label :accessor attribute-display-empty-label-p :initarg :display-empty-label-p :initform t)))
  29
  30 (define-layered-class standard-attribute
  31   :in-layer #.(defining-description 'html-description)
  32  (html-attribute)
  33  ())
  34
  35 (define-layered-function display-html-attribute-label (object attribute)
  36   (:method (object attribute)
  37
  38     (let ((label (attribute-label attribute)))
  39       (when (or label (attribute-display-empty-label-p attribute))
  40            (<:td (<:label
  41             :class "lol-attribute-label"
  42             (when label
  43               (<:as-html
  44                (with-output-to-string (*display*)
  45                  (display-attribute-label attribute)))))))))
  46   (:method
  47       :in-layer #.(defining-description 'inline)
  48       (object attribute)
  49     (let ((label (attribute-label attribute)))
  50       (when label
  51         (<:as-html (display-attribute-label attribute))))))
  52
  53 (define-layered-function display-html-attribute-value (object attribute)
  54   (:method (object attribute)
  55
  56     (<:td
  57      :class "lol-attribute-value"
  58      (<:as-html
  59       (display-attribute-value attribute))))
  60
  61   (:method
  62     :in-layer #.(defining-description 'inline) (object attribute)
  63     (display-attribute-value attribute)))
  64
  65
  66 (define-layered-function display-html-attribute (object attribute)
  67
  68   (:method (object attribute)
  69     (<:tr
  70      :class (format nil "~A lol-attribute" (attribute-css-class attribute))
  71      (when (attribute-dom-id attribute)
  72        :id (attribute-dom-id attribute))
  73      (display-html-attribute-label object attribute)
  74      (display-html-attribute-value object attribute)))
  75
  76   (:method
  77       :in-layer #.(defining-description 'inline)
  78       (object attribute)
  79       (<:span
  80        :class (attribute-css-class attribute)
  81        (when (attribute-dom-id attribute)
  82          :id (attribute-dom-id attribute))
  83        (<:span :class "lol-attribute-label"
  84        (display-html-attribute-label object attribute))
  85        (<:span :class "lol-attribute-value"
  86        (display-html-attribute-value object attribute)))))
  87
  88 (define-layered-method display-using-description
  89   :in-layer #.(defining-description 'html-description)
  90   :around ((attribute standard-attribute) display object &rest args)
  91  (declare (ignore args))
  92  (display-html-attribute object attribute))
  93
  94
  95 (defun capture-description (attribute function)
  96    (let ((obj (described-object (attribute-description attribute))))
  97    (lambda (&rest args)
  98      (dletf (((described-object attribute) obj))
  99        (apply function args)))))
 100
 101 (defun make-attribute-value-writer (attribute)
 102   (let ((obj (described-object (attribute-description attribute)))
 103         (value (attribute-value attribute))
 104         (desc (attribute-description attribute)))
 105    (lambda (val)
 106      (dletf (((described-object (attribute-description attribute)) obj))
 107        (with-active-descriptions (editable)
 108          (unless (and (unbound-slot-value-p value)
 109                       (equal "" val))
 110            (with-described-object (obj desc)
 111              (setf (attribute-value attribute)
 112                    (parse-attribute-value attribute val)))))))))
 113
 114
 115 (defmethod html-attribute-value (attribute)
 116   (let ((val (attribute-value attribute)))
 117     (if (unbound-slot-value-p val)
 118         ""
 119         val)))
 120
 121 (defmethod display-html-attribute-editor (attribute editor)
 122   (<ucw:input :type "text"
 123               :reader (html-attribute-value attribute)
 124               :writer (make-attribute-value-writer attribute)))
 125
 126 (defmethod display-html-attribute-editor ((attribute slot-definition-attribute) editor)
 127   (call-next-method))
 128
 129 (defmethod display-html-attribute-editor (attribute (editor password-attribute-editor))
 130   (<ucw:input :type "password"
 131               :reader (html-attribute-value attribute)
 132               :writer (make-attribute-value-writer attribute)))
 133
 134 (define-layered-method display-attribute-editor
 135    :in-layer #.(defining-description 'html-description) (attribute)
 136    (display-html-attribute-editor attribute (attribute-editor attribute)))
 137
 138
 139 (define-layered-method display-html-attribute-value
 140   :in-layer #.(defining-description 'editable) (object attribute)
 141
 142   (<:as-html (princ-to-string (attribute-editp attribute)))
 143     (if (attribute-editp attribute)
 144             (<:td
 145              :class "lol-attribute-value" (display-attribute-editor attribute))
 146         (call-next-method)))
 147
 148 (define-layered-function display-html-description (description display object &optional next-method)
 149   (:method (description display object &optional (next-method #'display-using-description))
 150       (let ((dom-id (find-attribute description 'dom-id))
 151         (css-class (find-attribute description 'dom-id)))
 152               (<:table
 153        :class (list (attribute-value css-class) "lol-description" "t")
 154        :id    (attribute-value dom-id)
 155        (funcall next-method)
 156        (<:br :class "clear")))))
 157
 158
 159 (define-layered-method display-html-description
 160   :in-layer #.(defining-description 'inline) (description display object &optional next-method)
 161   (let ((dom-id (find-attribute description 'dom-id))
 162         (css-class (find-attribute description 'dom-id)))
 163     (<:span
 164                       :class (list (attribute-value css-class) "lol-description")
 165                       :id    (attribute-value dom-id)
 166                       (funcall next-method))))
 167
 168
 169 (define-display
 170   :in-description html-description ((description t)
 171                                     (display ucw-core:component)
 172                                     object)
 173   (display-html-description description display object (lambda ()
 174                                                          (call-next-method))))
 175
 176 (define-layered-method display-html-attribute-value
 177   (object (attribute list-attribute))
 178   (let ((val (attribute-value attribute)))
 179     (when (listp  val)
 180       (<:ul
 181        (arnesi:dolist* (item (attribute-value attribute))
 182
 183          (dletf (((attribute-object attribute) item))
 184            (<:li (apply #'display *display* item (slot-value attribute 'item-args)))))))))