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    (display-empty-label :accessor attribute-display-empty-label-p :initarg :display-empty-label-p :initform t)))
  28
  29 (define-layered-class standard-attribute
  30   :in-layer #.(defining-description 'html-description)
  31  (html-attribute)
  32  ())
  33
  34 (define-layered-function display-html-attribute-label (object attribute)
  35   (:method (object attribute)
  36
  37     (let ((label (attribute-label attribute)))
  38       (when (or label (attribute-display-empty-label-p attribute))
  39            (<:td (<:label
  40             :class "lol-attribute-label"
  41             (when label
  42               (<:as-html
  43                (with-output-to-string (*display*)
  44                  (display-attribute-label attribute)))))))))
  45   (:method
  46       :in-layer #.(defining-description 'inline)
  47       (object attribute)
  48     (let ((label (attribute-label attribute)))
  49       (when label
  50                  (<:as-html
  51           (with-output-to-string (*display*)
  52             (display-attribute-label attribute)))))))
  53
  54 (define-layered-function display-html-attribute-value (object attribute)
  55   (:method (object attribute)
  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 (define-layered-function display-html-attribute (object attribute)
  66
  67   (:method (object attribute)
  68     (<:tr
  69      :class (attribute-css-class attribute)
  70      (when (attribute-dom-id attribute)
  71        :id (attribute-dom-id attribute))
  72      (display-html-attribute-label object attribute)
  73      (display-html-attribute-value object attribute)))
  74
  75   (:method
  76       :in-layer #.(defining-description 'inline)
  77       (object attribute)
  78       (<:span
  79        :class (attribute-css-class attribute)
  80        (when (attribute-dom-id attribute)
  81          :id (attribute-dom-id attribute))
  82        (display-html-attribute-label object attribute)
  83        (display-html-attribute-value object attribute))))
  84
  85 (define-layered-method display-using-description
  86   :in-layer #.(defining-description 'html-description)
  87   :around ((attribute standard-attribute) display object &rest args)
  88  (declare (ignore args))
  89  (display-html-attribute object attribute))
  90
  91
  92 (defun capture-description (attribute function)
  93    (let ((obj (described-object (attribute-description attribute))))
  94    (lambda (&rest args)
  95      (dletf (((described-object attribute) obj))
  96        (apply function args)))))
  97
  98 (defun make-attribute-value-writer (attribute)
  99  (let ((obj (described-object (attribute-description attribute)))
 100        (value (attribute-value attribute)))
 101    (lambda (val)
 102      (dletf (((described-object attribute) obj))
 103        (with-active-descriptions (editable)
 104          (unless (and (unbound-slot-value-p value)
 105                       (equal "" val))
 106          (setf (attribute-value attribute)
 107              (parse-attribute-value attribute val))))))))
 108
 109
 110 (defmethod html-attribute-value (attribute)
 111   (let ((val (attribute-value attribute)))
 112     (if (unbound-slot-value-p val)
 113         ""
 114         val)))
 115
 116 (defmethod display-html-attribute-editor (attribute editor)
 117   (<ucw:input :type "text"
 118               :reader (html-attribute-value attribute)
 119               :writer (make-attribute-value-writer attribute)))
 120
 121 (defmethod display-html-attribute-editor ((attribute slot-definition-attribute) editor)
 122   (call-next-method))
 123
 124 (defmethod display-html-attribute-editor (attribute (editor password-attribute-editor))
 125   (<ucw:input :type "password"
 126               :reader (html-attribute-value attribute)
 127               :writer (make-attribute-value-writer attribute)))
 128
 129
 130
 131
 132 (define-layered-method display-attribute-editor
 133    :in-layer #.(defining-description 'html-description) (attribute)
 134    (display-html-attribute-editor attribute (attribute-editor attribute)))
 135
 136
 137 (define-layered-method display-html-attribute-value
 138   :in-layer #.(defining-description 'editable) (object attribute)
 139
 140     (<:td
 141         :class "lol-attribute-value"
 142     (if (attribute-editp attribute)
 143         (display-attribute-editor attribute)
 144         (call-next-method))))
 145
 146 (define-layered-function display-html-description (description display object &optional next-method)
 147   (:method (description display object &optional (next-method #'display-using-description))
 148     (<:style
 149      (<:as-html "
 150
 151
 152
 153 div.lol-description .lol-attribute-label,
 154 div.lol-description .lol-attribute-value {
 155       display: block;
 156       width: 69%;
 157       float: left;
 158       margin-bottom: 1em;
 159 border:1px solid black;
 160
 161 }
 162 div.lol-description
 163 .lol-attribute-label {
 164      text-align: right;
 165      width: 24%;
 166      padding-right: 1em;
 167 }
 168
 169 span.lol-attribute-value .lol-attribute-value (
 170  border: 1px solid red;}
 171
 172
 173 div.lol-description
 174 br {
 175 clear: left;
 176 }
 177
 178 .clear {clear:left}"
 179
 180 ))
 181
 182     (with-attributes (css-class dom-id) description
 183
 184
 185       (<:table
 186        :class (list (attribute-value css-class) "lol-description" "t")
 187        :id    (attribute-value dom-id)
 188        (funcall next-method)
 189        (<:br :class "clear")))))
 190
 191
 192 (define-layered-method display-html-description
 193   :in-layer #.(defining-description 'inline) (description display object &optional next-method)
 194   (with-attributes (css-class dom-id) description
 195     (<:span
 196      :class (list (attribute-value css-class) "lol-description")
 197      :id    (attribute-value dom-id)
 198      (funcall next-method))))
 199
 200
 201 (define-display
 202   :in-description html-description ((description t)
 203                                     (display ucw-core:component)
 204                                     object)
 205   (display-html-description description display object (lambda ()
 206                                                          (call-next-method))))
 207
 208 (define-layered-method display-html-attribute-value
 209   (object (attribute list-attribute))
 210   (let ((val (attribute-value attribute)))
 211     (when (listp  val)
 212       (<:ul
 213        (arnesi:dolist* (item (attribute-value attribute))
 214
 215          (dletf (((attribute-object attribute) item))
 216            (<:li (apply #'display *display* item (slot-value attribute 'item-args)))))))))