| 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)))))))) |