| 1 | (in-package :lisp-on-lines) |
| 2 | |
| 3 | ;;;; The Standard Layers |
| 4 | (deflayer viewer) |
| 5 | (deflayer editor) |
| 6 | |
| 7 | (define-layered-method label (anything) |
| 8 | nil) |
| 9 | |
| 10 | (defdisplay |
| 11 | :in-layer editor :around (description object) |
| 12 | "It is useful to remove the viewer layer when in the editing layer. |
| 13 | This allows us to dispatch to a subclasses editor." |
| 14 | (with-inactive-layers (viewer) |
| 15 | (call-next-method))) |
| 16 | |
| 17 | ;;;; These layers affect the layout of the object |
| 18 | (deflayer one-line) |
| 19 | (deflayer as-table) |
| 20 | (deflayer as-string) |
| 21 | |
| 22 | (defdisplay |
| 23 | :in-layer as-string (d o) |
| 24 | (with-inactive-layers (editor viewer one-line as-table show-attribute-labels) |
| 25 | (do-attributes (a d) |
| 26 | (display-attribute a o) |
| 27 | (<:as-is " ")))) |
| 28 | |
| 29 | (defmethod list-slots (thing) |
| 30 | (list 'identity)) |
| 31 | |
| 32 | |
| 33 | ;;;; TODO : this doesn't work |
| 34 | |
| 35 | (defaction call-display-with-context ((from component) object context &rest properties) |
| 36 | (call-component self (make-instance 'standard-display-component |
| 37 | :context context |
| 38 | :object object |
| 39 | :args (if (cdr properties) |
| 40 | properties |
| 41 | (car properties))))) |
| 42 | |
| 43 | (defmacro call-display (component object &rest properties) |
| 44 | `(let () |
| 45 | (call-display-with-context ,component ,object nil ,@properties))) |
| 46 | |
| 47 | (defcomponent standard-display-component () |
| 48 | ((context :accessor context :initarg :context) |
| 49 | (object :accessor object-of :initarg :object) |
| 50 | (args :accessor args :initarg :args))) |
| 51 | |
| 52 | (defmethod render ((self standard-display-component)) |
| 53 | |
| 54 | (apply #'display self (object-of self) (args self))) |
| 55 | |
| 56 | |
| 57 | ;;;; * Object displays. |
| 58 | |
| 59 | |
| 60 | |
| 61 | ;;;; TODO: all lisp types should have occurences and attributes defined for them. |
| 62 | |
| 63 | (defdisplay ((description t) lisp-value) |
| 64 | (<:as-html lisp-value)) |
| 65 | |
| 66 | (defdisplay (description (object string)) |
| 67 | (<:as-html object)) |
| 68 | |
| 69 | (defdisplay (description object (component t)) |
| 70 | "The default display for CLOS objects" |
| 71 | (print (class-name (class-of object))) |
| 72 | (dolist* (slot-name (list-slots object)) |
| 73 | |
| 74 | (let ((boundp (slot-boundp object slot-name))) |
| 75 | (format t "~A~A : ~A" (strcat slot-name) |
| 76 | (if boundp |
| 77 | "" |
| 78 | "(unbound)") |
| 79 | (if boundp |
| 80 | (slot-value object slot-name) ""))))) |
| 81 | |
| 82 | (defdisplay ((description t) object) |
| 83 | "The default display for CLOS objects in UCW components" |
| 84 | (dolist* (slot-name (list-slots object)) |
| 85 | |
| 86 | (let ((boundp (slot-boundp object slot-name))) |
| 87 | (<:label :class "lol-label" |
| 88 | (display-attribute 'label (strcat slot-name)) |
| 89 | (if boundp |
| 90 | "" |
| 91 | "(unbound)")) |
| 92 | (<:as-html |
| 93 | (if boundp |
| 94 | (slot-value object slot-name) ""))))) |
| 95 | |
| 96 | ;;;; ** The default displays for objects with a MEWA occurence |
| 97 | |
| 98 | (defdisplay (description object) |
| 99 | (<:div |
| 100 | :class "lol-display" |
| 101 | (when (label description) |
| 102 | (<:span |
| 103 | :class "title" |
| 104 | (<:as-html (label description)))) |
| 105 | (do-attributes (attribute description) |
| 106 | (<:div |
| 107 | :class "attribute" |
| 108 | (display-attribute attribute object))))) |
| 109 | |
| 110 | ;;;; ** One line |
| 111 | (defdisplay |
| 112 | :in-layer one-line (description object) |
| 113 | "The one line presentation just displays the attributes with a #\Space between them" |
| 114 | (do-attributes (attribute description) |
| 115 | (display-attribute attribute object) |
| 116 | (<:as-html " "))) |
| 117 | |
| 118 | ;;;; ** as-table |
| 119 | |
| 120 | (defdisplay :in-layer as-table (description object) |
| 121 | (<:table |
| 122 | (do-attributes (a description) |
| 123 | (<:tr |
| 124 | (<:td :class "lol-label" (<:as-html (label a))) |
| 125 | (<:td (display-attribute a object)))))) |
| 126 | |
| 127 | ;;;; List Displays |
| 128 | |
| 129 | (deflayer list-display-layer) |
| 130 | |
| 131 | (define-layered-class description |
| 132 | :in-layer list-display-layer () |
| 133 | ((list-item :initarg :list-item :initform nil :special t :accessor list-item))) |
| 134 | |
| 135 | (defdisplay (desc (list list)) |
| 136 | (with-active-layers (list-display-layer) |
| 137 | |
| 138 | (<:ul |
| 139 | (dolist* (item list) |
| 140 | (<:li (apply #'display* item (list-item desc))))))) |
| 141 | |
| 142 | ;;;; Attributes |
| 143 | (defdisplay |
| 144 | :in-layer editor |
| 145 | ((attribute standard-attribute) object) |
| 146 | "Legacy editor using UCW presentations" |
| 147 | |
| 148 | (warn "USING LEGACY EDITOR FOR ~A" (slot-name attribute))) |
| 149 | |
| 150 | (define-layered-method display-using-description |
| 151 | ((attribute standard-attribute) object component) |
| 152 | (with-component (component) |
| 153 | (<ucw:a :action (call 'info-message :message (strcat (symbol-package (description.type attribute))":/::" (description.type attribute))) |
| 154 | (<:as-html "*" ))) |
| 155 | (<:as-html (attribute-value object attribute))) |
| 156 | |
| 157 | |
| 158 | |
| 159 | |
| 160 | |
| 161 | |
| 162 | |
| 163 | |
| 164 | |
| 165 | |
| 166 | |