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
  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     (let ((label (attribute-label attribute)))
  37            (<:label
  38             :class "lol-attribute-label"
  39             (when label
  40               (<:as-html
  41                (with-output-to-string (*display*)
  42                  (display-attribute-label attribute)))))))
  43   (:method
  44       :in-layer #.(defining-description 'inline)
  45       (object attribute)
  46     (let ((label (attribute-label attribute)))
  47       (when label
  48                  (<:as-html
  49           (with-output-to-string (*display*)
  50             (display-attribute-label attribute)))))))
  51
  52 (define-layered-function display-html-attribute-value (object attribute)
  53   (:method (object attribute)
  54     (<:span
  55         :class "lol-attribute-value"
  56         (<:as-html
  57          (display-attribute-value attribute))))
  58
  59   (:method
  60     :in-layer #.(defining-description 'inline) (object attribute)
  61     (display-attribute-value attribute)))
  62
  63 (define-layered-function display-html-attribute (object attribute)
  64
  65   (:method (object attribute)
  66     (<:div
  67      :class (attribute-css-class attribute)
  68      (when (attribute-dom-id attribute)
  69        :id (attribute-dom-id attribute))
  70      (display-html-attribute-label object attribute)
  71      (display-html-attribute-value object attribute)))
  72
  73   (:method
  74       :in-layer #.(defining-description 'inline)
  75       (object attribute)
  76       (<:span
  77        :class (attribute-css-class attribute)
  78        (when (attribute-dom-id attribute)
  79          :id (attribute-dom-id attribute))
  80        (display-html-attribute-label object attribute)
  81        (display-html-attribute-value object attribute))))
  82
  83 (define-layered-method display-using-description
  84   :in-layer #.(defining-description 'html-description)
  85   :around ((attribute standard-attribute) display object &rest args)
  86  (declare (ignore args))
  87  (display-html-attribute object attribute))
  88
  89
  90 (defun make-attribute-value-writer (attribute)
  91  (let ((obj (described-object (attribute-description attribute))))
  92    (lambda (val)
  93      (dletf (((described-object attribute) obj))
  94        (setf (attribute-value attribute)
  95              (parse-attribute-value attribute val))))))
  96
  97
  98 (defmethod display-html-attribute-editor (attribute editor)
  99   (<lol:input :type "text"
 100               :reader (attribute-value attribute)
 101               :writer (make-attribute-value-writer attribute)))
 102
 103 (defmethod display-html-attribute-editor (attribute (editor password-attribute-editor))
 104   (<lol:input :type "password"
 105               :reader (attribute-value attribute)
 106               :writer (make-attribute-value-writer attribute)))
 107
 108
 109 (define-layered-method display-attribute-editor
 110    :in-layer #.(defining-description 'html-description) (attribute)
 111    (display-html-attribute-editor attribute (attribute-editor attribute)))
 112
 113
 114 (define-layered-method display-html-attribute-value
 115   :in-layer #.(defining-description 'editable) (object attribute)
 116
 117     (<:span
 118         :class "lol-attribute-value"
 119     (if (attribute-editp attribute)
 120         (display-attribute-editor attribute)
 121
 122         (call-next-method))))
 123
 124 (define-layered-function display-html-description (description display object &optional next-method)
 125   (:method (description display object &optional (next-method #'display-using-description))
 126     (<:style
 127      (<:as-html "
 128
 129 div.lol-description .lol-attribute-label,
 130 div.lol-description .lol-attribute-value {
 131       display: block;
 132       width: 69%;
 133       float: left;
 134       margin-bottom: 1em;
 135
 136 }
 137 div.lol-description
 138 .lol-attribute-label {
 139      text-align: right;
 140      width: 24%;
 141      padding-right: 20px;
 142 }
 143
 144
 145 div.lol-description
 146 br {
 147 clear: left;
 148 }"))
 149
 150     (with-attributes (css-class dom-id) description
 151
 152
 153       (<:div
 154        :class (list (attribute-value css-class) "lol-description" "t")
 155        :id    (attribute-value dom-id)
 156        (funcall next-method)))))
 157
 158
 159 (define-layered-method display-html-description
 160   :in-layer #.(defining-description 'inline) (description display object &optional next-method)
 161   (with-attributes (css-class dom-id) description
 162     (<:span
 163      :class (list (attribute-value css-class) "lol-description")
 164      :id    (attribute-value dom-id)
 165      (funcall next-method))))
 166
 167
 168 (define-display
 169   :in-description html-description ((description t)
 170                                     (display lol-ucw:component)
 171                                     object)
 172   (display-html-description description display object (lambda ()
 173                                                          (call-next-method))))
 174
 175
 176
 177
 178
 179
 180
 181
 182
 183