| 1 | (in-package :lisp-on-lines) |
| 2 | |
| 3 | |
| 4 | ;;;; The Standard Layer Hierarchy |
| 5 | (deflayer viewer) |
| 6 | (deflayer editor (viewer)) |
| 7 | (deflayer creator (editor)) |
| 8 | |
| 9 | ;;;; 'Mixin' Layers |
| 10 | (deflayer one-line) |
| 11 | |
| 12 | (deflayer wrap-form) |
| 13 | |
| 14 | (deflayer as-table) |
| 15 | |
| 16 | (define-attributes (contextl-default) |
| 17 | (:viewer viewer) |
| 18 | (:editor editor) |
| 19 | (:creator creator)) |
| 20 | |
| 21 | |
| 22 | (defmacro with-component ((component) &body body) |
| 23 | `(let ((self ,component)) |
| 24 | (flet ((display* (thing &rest args) |
| 25 | (apply #'display ,component thing args))) |
| 26 | ,@body))) |
| 27 | |
| 28 | (defmacro call-display (object &rest args) |
| 29 | `(call-component self (make-instance 'standard-display-component |
| 30 | :display #'(lambda (component) |
| 31 | (with-component (component) |
| 32 | (<:as-html ,object) |
| 33 | (display ,object ,@args)))))) |
| 34 | |
| 35 | (defmethod find-plist (object) |
| 36 | (list)) |
| 37 | ` |
| 38 | (defmethod find-plist ((attribute standard-attribute)) |
| 39 | (attribute.plist attribute)) |
| 40 | |
| 41 | (defmacro with-plist ((plist-form &optional prefix) &body body) |
| 42 | (with-unique-names (p) |
| 43 | (let ((get (intern (string-upcase (if prefix (strcat prefix '-getp) "GETP")))) |
| 44 | (set (intern (string-upcase (if prefix (strcat prefix '-setp) "SETP")))) |
| 45 | (props (intern (string-upcase (if prefix (strcat prefix '-properties) "PROPERTIES"))))) |
| 46 | `(let ((,p ,plist-form)) |
| 47 | (flet ((,get (p) |
| 48 | (getf ,p p)) |
| 49 | (,set (p v) |
| 50 | (setf (getf ,p p) v)) |
| 51 | (,props () |
| 52 | ,p)) |
| 53 | (declare (ignorable #',get #',set #',props)) |
| 54 | ,@body))))) |
| 55 | |
| 56 | |
| 57 | ;;;;; Macros |
| 58 | (defmacro do-attributes ((var occurence attributes) &body body) |
| 59 | (with-unique-names (att plist type) |
| 60 | `(loop for ,att in ,attributes |
| 61 | do (let* ((,att (ensure-list ,att)) |
| 62 | (,plist (rest ,att)) |
| 63 | (,type (getf ,plist :type)) |
| 64 | (,var (if ,type |
| 65 | (make-attribute :name (first ,att) :type ,type :plist ,plist) |
| 66 | (find-attribute ,occurence (first ,att))))) |
| 67 | (with-plist ((plist-union (rest ,att) (find-plist ,var)) ,var) |
| 68 | ,@body))))) |
| 69 | |
| 70 | |
| 71 | (defmacro defdisplay ((&key |
| 72 | (in-layer nil layer-supplied-p) |
| 73 | (combination nil combination-supplied-p) |
| 74 | (description '(occurence standard-occurence) description-supplied-p) |
| 75 | (component 'component) |
| 76 | ((:class object) nil)) |
| 77 | &body body) |
| 78 | (let ((class-spec (if object (if (listp object) object (list object object)) 'object))) |
| 79 | `(define-layered-method display-using-description |
| 80 | ,@(when layer-supplied-p `(:in-layer ,in-layer)) |
| 81 | ,@(when combination-supplied-p `(,combination)) |
| 82 | (,description ,component |
| 83 | ,class-spec properties) |
| 84 | |
| 85 | |
| 86 | (with-plist ((plist-union properties (find-plist ,(car description)))) |
| 87 | |
| 88 | ,(if (not description-supplied-p) |
| 89 | `(flet ((attributes () |
| 90 | (or (getp :attributes) |
| 91 | (list-slots ,(car (ensure-list class-spec)))))) |
| 92 | (declare (ignorable #'attributes)) |
| 93 | |
| 94 | ,@body) |
| 95 | `(progn ,@body)))) ) |
| 96 | ) |
| 97 | |
| 98 | |
| 99 | (define-layered-function display (component object &rest args) |
| 100 | (:documentation |
| 101 | "Displays OBJECT in COMPONENT. |
| 102 | |
| 103 | default action is to FUNCALL-WITH-LAYERS the DISPLAY-USING-DESCRIPTION method.")) |
| 104 | |
| 105 | (define-layered-method display |
| 106 | ((component t) (object standard-class) &rest args &key layers (type 'viewer) &allow-other-keys) |
| 107 | (let* ((occurence (find-occurence object)) |
| 108 | (plist (attribute.plist |
| 109 | (find-attribute occurence (intern (format nil "~A" type) :KEYWORD)))) |
| 110 | (layers (append (when type (loop for ty in (ensure-list type) |
| 111 | nconc `(+ ,ty))) |
| 112 | layers |
| 113 | (getf plist :layers)))) |
| 114 | (funcall-with-layers |
| 115 | layers |
| 116 | #'display-using-description occurence component object (plist-union args plist)))) |
| 117 | |
| 118 | |
| 119 | (define-layered-method display |
| 120 | ((component t) (object t) &rest args &key layers (type 'viewer) &allow-other-keys) |
| 121 | (funcall-with-layers |
| 122 | layers |
| 123 | #'display-using-description t component object args)) |
| 124 | |
| 125 | |
| 126 | (define-layered-function display-using-description (description component object properties) |
| 127 | (:documentation |
| 128 | "Render the object in component, using DESCRIPTION, which is an occurence, and attribute, or something else")) |
| 129 | |
| 130 | (define-layered-method display-using-description (description component object properties) |
| 131 | "The standard display simply prints the object" |
| 132 | (declare (ignore component properties description)) |
| 133 | (<:as-html object)) |
| 134 | |
| 135 | ;;;; * Object Presentations |
| 136 | (define-layered-method display-using-description |
| 137 | ((occurence standard-occurence) component object properties) |
| 138 | |
| 139 | (with-plist (properties o) |
| 140 | (loop for att in (or (o-getp :attributes) (list-slots object)) |
| 141 | do (let* ((att (ensure-list att)) |
| 142 | (attribute (find-attribute occurence (first att)))) |
| 143 | (warn "trying to render ~A in ~A" attribute object) |
| 144 | (with-plist ((plist-union (rest att) (find-plist attribute))) |
| 145 | (<:p :class "attribute" |
| 146 | (<:span :class "label" (<:as-html (getp :label) " ")) |
| 147 | (display-using-description |
| 148 | attribute |
| 149 | component |
| 150 | object |
| 151 | (rest att)))))))) |
| 152 | |
| 153 | ;;;; ** One line |
| 154 | (defdisplay (:in-layer one-line) |
| 155 | (do-attributes (attribute occurence (or (getp :attributes) |
| 156 | (list-slots object))) |
| 157 | (display-using-description attribute component object (attribute-properties)) |
| 158 | (<:as-html " "))) |
| 159 | |
| 160 | ;;;; ** as-table |
| 161 | |
| 162 | (defdisplay (:in-layer as-table) |
| 163 | (<:table |
| 164 | (do-attributes (a occurence (attributes)) |
| 165 | (<:tr |
| 166 | (<:td (<:as-html (a-getp :label))) |
| 167 | (<:td (display-using-description a component object (a-properties))))))) |
| 168 | |
| 169 | ;;;; List Displays |
| 170 | (defdisplay (:class |
| 171 | (list list) |
| 172 | :description (desc t)) |
| 173 | (<:ul |
| 174 | (dolist* (item list) |
| 175 | (<:li (apply #'display component item properties))))) |
| 176 | |
| 177 | |
| 178 | |
| 179 | ;;;; Attributes |
| 180 | (defdisplay (:in-layer |
| 181 | editor |
| 182 | :description (attribute standard-attribute)) |
| 183 | "Legacy editor using UCW presentations" |
| 184 | (let ((p (lol:make-view object :type :editor))) |
| 185 | (present-slot-view p (getf (find-plist attribute) :slot-name)))) |
| 186 | |
| 187 | (define-layered-method display-using-description |
| 188 | ((attribute standard-attribute) component object properties) |
| 189 | (let ((p (lol:make-view object :type 'mewa-viewer)) |
| 190 | (name (attribute.name attribute))) |
| 191 | (when name (present-slot-view p name)))) |
| 192 | |
| 193 | (defdisplay (:class |
| 194 | (button (eql 'standard-form-buttons)) |
| 195 | :description (description t)) |
| 196 | (<ucw:submit :action (ok component) |
| 197 | :value "Ok.")) |
| 198 | |
| 199 | |
| 200 | (defdisplay (:in-layer wrap-form |
| 201 | :combination :around) |
| 202 | (<ucw:form |
| 203 | :action (refresh-component component) |
| 204 | (call-next-method) |
| 205 | (display component 'standard-form-buttons))) |
| 206 | |
| 207 | |
| 208 | (defclass/meta test-class () |
| 209 | ((test-string :initform "test string" :type string)) |
| 210 | (:documentation "foo")) |
| 211 | |
| 212 | (define-attributes (test-class) |
| 213 | (test-string t :label "String :" :editablep t)) |
| 214 | |
| 215 | (defcomponent test-component () |
| 216 | ((display-types :accessor display-types :initform (list 'viewer 'editor 'creator 'one-line 'as-string)) |
| 217 | (current-type :accessor current-type :initform 'viewer) |
| 218 | (instance :accessor instance :initform (make-instance 'test-class)))) |
| 219 | |
| 220 | (defmethod render ((self test-component)) |
| 221 | (let ((test (instance self))) |
| 222 | (<:h1 (<:as-html "Lisp on Lines Test Component")) |
| 223 | (with-component (self) |
| 224 | (<ucw:form |
| 225 | :action (refresh-component self) |
| 226 | (<ucw:select :accessor (current-type self) |
| 227 | (dolist* (type (display-types self)) |
| 228 | (<ucw:option :value type (<:as-html type)))) |
| 229 | (<:input :type "Submit" :value "update") |
| 230 | (<:fieldset |
| 231 | (<:legend (<:as-html (current-type self))) |
| 232 | (display test :type (current-type self))))) |
| 233 | |
| 234 | (<:div |
| 235 | (<:h2 |
| 236 | (<:as-html "UCW Presentation based displays (the old school")) |
| 237 | (dolist (type '(:viewer :editor :creator :one-line :as-string)) |
| 238 | (<:h3 (<:as-html type)) |
| 239 | (present-view (test type self)) |
| 240 | (<ucw:a :action (call-view (test type self)) |
| 241 | (<:as-html "Call to " type)))))) |
| 242 | |
| 243 | |
| 244 | (defcomponent standard-display-component () |
| 245 | ((display-function :accessor display-function :initarg :display))) |
| 246 | |
| 247 | (defmethod render ((self standard-display-component)) |
| 248 | (funcall (display-function self) self)) |
| 249 | |
| 250 | |
| 251 | |
| 252 | |
| 253 | |
| 254 | |