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 lol-ucw:component) string &rest args)
   8   (<:as-html (with-output-to-string (stream)
   9                (apply #'call-next-method stream string args))))
  10
  11
  12 (define-description html-description ()
  13   ())
  14
  15 (define-description t ()
  16   ((css-class  :value "lol-description" :activep nil)
  17    (dom-id :function (lambda (x)
  18                        (declare (ignore x))
  19                        (symbol-name
  20                         (gensym "DOM-ID-")))
  21            :activep nil))
  22   (:in-description html-description))
  23
  24 (define-layered-class html-attribute ()
  25   ((css-class :accessor attribute-css-class
  26               :initform "lol-attribute")
  27    (dom-id :accessor attribute-dom-id :initform nil)
  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
  52           (with-output-to-string (*display*)
  53             (display-attribute-label attribute)))))))
  54
  55 (define-layered-function display-html-attribute-value (object attribute)
  56   (:method (object attribute)
  57     (<:td
  58         :class "lol-attribute-value"
  59         (<:as-html
  60          (display-attribute-value attribute))))
  61
  62   (:method
  63     :in-layer #.(defining-description 'inline) (object attribute)
  64     (display-attribute-value attribute)))
  65
  66 (define-layered-function display-html-attribute (object attribute)
  67
  68   (:method (object attribute)
  69     (<:tr
  70      :class (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        (display-html-attribute-label object attribute)
  84        (display-html-attribute-value object attribute))))
  85
  86 (define-layered-method display-using-description
  87   :in-layer #.(defining-description 'html-description)
  88   :around ((attribute standard-attribute) display object &rest args)
  89  (declare (ignore args))
  90  (display-html-attribute object attribute))
  91
  92
  93 (defun capture-description (attribute function)
  94    (let ((obj (described-object (attribute-description attribute))))
  95    (lambda (&rest args)
  96      (dletf (((described-object attribute) obj))
  97        (apply function args)))))
  98
  99 (defun make-attribute-value-writer (attribute)
 100  (let ((obj (described-object (attribute-description attribute)))
 101        (value (attribute-value attribute)))
 102    (lambda (val)
 103      (dletf (((described-object attribute) obj))
 104        (with-active-descriptions (editable)
 105          (unless (and (unbound-slot-value-p value)
 106                       (equal "" val))
 107          (setf (attribute-value attribute)
 108              (parse-attribute-value attribute val))))))))
 109
 110
 111 (defmethod html-attribute-value (attribute)
 112   (let ((val (attribute-value attribute)))
 113     (if (unbound-slot-value-p val)
 114         ""
 115         val)))
 116
 117 (defmethod display-html-attribute-editor (attribute editor)
 118   (<lol:input :type "text"
 119               :reader (html-attribute-value attribute)
 120               :writer (make-attribute-value-writer attribute)))
 121
 122 (defmethod display-html-attribute-editor ((attribute slot-definition-attribute) editor)
 123   (call-next-method))
 124
 125 (defmethod display-html-attribute-editor (attribute (editor password-attribute-editor))
 126   (<lol:input :type "password"
 127               :reader (html-attribute-value attribute)
 128               :writer (make-attribute-value-writer attribute)))
 129
 130
 131
 132
 133 (define-layered-method display-attribute-editor
 134    :in-layer #.(defining-description 'html-description) (attribute)
 135    (display-html-attribute-editor attribute (attribute-editor attribute)))
 136
 137
 138 (define-layered-method display-html-attribute-value
 139   :in-layer #.(defining-description 'editable) (object attribute)
 140
 141     (<:td
 142         :class "lol-attribute-value"
 143     (if (attribute-editp attribute)
 144         (display-attribute-editor attribute)
 145         (call-next-method))))
 146
 147 (define-layered-function display-html-description (description display object &optional next-method)
 148   (:method (description display object &optional (next-method #'display-using-description))
 149     (<:style
 150      (<:as-html "
 151
 152
 153
 154 div.lol-description .lol-attribute-label,
 155 div.lol-description .lol-attribute-value {
 156       display: block;
 157       width: 69%;
 158       float: left;
 159       margin-bottom: 1em;
 160 border:1px solid black;
 161
 162 }
 163 div.lol-description
 164 .lol-attribute-label {
 165      text-align: right;
 166      width: 24%;
 167      padding-right: 1em;
 168 }
 169
 170 span.lol-attribute-value .lol-attribute-value (
 171  border: 1px solid red;}
 172
 173
 174 div.lol-description
 175 br {
 176 clear: left;
 177 }
 178
 179 .clear {clear:left}"
 180
 181 ))
 182
 183     (with-attributes (css-class dom-id) description
 184
 185
 186       (<:table
 187        :class (list (attribute-value css-class) "lol-description" "t")
 188        :id    (attribute-value dom-id)
 189        (funcall next-method)
 190        (<:br :class "clear")))))
 191
 192
 193 (define-layered-method display-html-description
 194   :in-layer #.(defining-description 'inline) (description display object &optional next-method)
 195   (with-attributes (css-class dom-id) description
 196     (<:span
 197      :class (list (attribute-value css-class) "lol-description")
 198      :id    (attribute-value dom-id)
 199      (funcall next-method))))
 200
 201
 202 (define-display
 203   :in-description html-description ((description t)
 204                                     (display lol-ucw:component)
 205                                     object)
 206   (display-html-description description display object (lambda ()
 207                                                          (call-next-method))))
 208
 209 (define-layered-method display-html-attribute-value
 210   (object (attribute list-attribute))
 211   (let ((val (attribute-value attribute)))
 212     (when (listp  val)
 213       (<:ul
 214        (arnesi:dolist* (item (attribute-value attribute))
 215          (<:li (apply #'display *display* item (slot-value attribute 'item-args))))))))