(remove 'described-object (class-slots (class-of description))
:key #'slot-definition-name)))
+(defmacro with-described-object ((object description &rest args)
+ &body body)
+ `(funcall-with-described-object
+ (lambda () ,@body)
+ ,object
+ ,description
+ ,@args))
+
(defun initialize-effective-attribute-values-for-description-class (class description attribute-objects)
(loop
function))))))))
-(defmacro with-described-object ((object description &rest args)
- &body body)
- `(funcall-with-described-object
- (lambda () ,@body)
- ,object
- ,description
- ,@args))
+
(defmacro define-description (name &optional superdescriptions &body options)
(let ((description-name (defining-description name)))
(dolist (d activate context)
(setf context (adjoin-layer (find-description d)
context))))
-
-
+(defun funcall-with-attribute-context (attribute thunk)
+ (funcall-with-layer-context
+ (modify-layer-context (current-layer-context)
+ :activate (attribute-active-descriptions attribute)
+ :deactivate (attribute-inactive-descriptions attribute))
+ thunk))
+(defmacro with-attribute-context ((attribute) &body body)
+ `(funcall-with-attribute-context ,attribute (lambda () ,@body)))
+
+
(defun display (display object &rest args &key deactivate activate &allow-other-keys)
(funcall-with-layer-context
-
-
(defun display/d (&rest args)
(apply #'display-using-description args))
#:find-description
#:description-of
#:define-description
+ #:defining-description
#:described-object
#:with-described-object
#:described-class
#:attribute-delimiter
#:attribute-slot-name
#:label
+ #:attribute-active-p
#:attribute-function
#:attribute-value
#:display-attribute-value
#:active-attributes
#:attribute-delimiter
#:standard-attribute
+ #:funcall-with-attribute-context
+ #:with-attribute-context
;; Standard Library
()
())
+(defun display-inline (object &rest args)
+ (with-active-descriptions (inline)
+ (apply #'display *display* object args)))
+
+(defun display-inline-attribute (attribute value)
+ (if (ignore-errors (lol::attribute-active-attributes attribute))
+ (handler-case (display-inline value :attributes (lol::attribute-active-attributes attribute))
+ (error ()
+ (display-inline value)))
+ (display-inline value)))
+
+
-(define-display :in-description inline ((description t))
- (call-next-method))
(loop
:for cons :on list
:do (let ((item (first cons
-)))
- (break "Display T ~A" item)
+)))
(dletf (((attribute-object attribute) item))
(apply #'display *display* item (slot-value attribute 'item-args))
(unless (endp (cdr cons))
(funcall (attribute-label-formatter attribute) (attribute-label attribute))))
(define-layered-function display-attribute-value (attribute)
+ (:method-combination arnesi:wrapping-standard)
(:method (attribute)
(flet ((disp (val &rest args)
(apply #'display *display* val
(define-display ((description t))
(let ((attributes (attributes description)))
- (display-attribute (first attributes))
+ (when (first attributes)(display-attribute (first attributes)))
(dolist (attribute (rest attributes) (values))
(generic-format *display*
(attribute-value
t)))
-
(defun validp (object)
(with-described-object (object nil)
(every #'identity (mapcar (lambda (attribute)
((css-class :accessor attribute-css-class
:initform "lol-attribute")
(dom-id :accessor attribute-dom-id :initform nil)
+ (value-tag :accessor attribute-html-tag :initform nil :initarg :html-tag)
(display-empty-label :accessor attribute-display-empty-label-p :initarg :display-empty-label-p :initform t)))
(define-layered-class standard-attribute
(object attribute)
(let ((label (attribute-label attribute)))
(when label
- (<:as-html
- (with-output-to-string (*display*)
- (display-attribute-label attribute)))))))
+ (<:as-html (display-attribute-label attribute))))))
(define-layered-function display-html-attribute-value (object attribute)
(:method (object attribute)
+
(<:td
- :class "lol-attribute-value"
- (<:as-html
- (display-attribute-value attribute))))
+ :class "lol-attribute-value"
+ (<:as-html
+ (display-attribute-value attribute))))
(:method
:in-layer #.(defining-description 'inline) (object attribute)
(display-attribute-value attribute)))
+
(define-layered-function display-html-attribute (object attribute)
(:method (object attribute)
(<:tr
- :class (attribute-css-class attribute)
+ :class (format nil "~A lol-attribute" (attribute-css-class attribute))
(when (attribute-dom-id attribute)
:id (attribute-dom-id attribute))
(display-html-attribute-label object attribute)
:class (attribute-css-class attribute)
(when (attribute-dom-id attribute)
:id (attribute-dom-id attribute))
- (display-html-attribute-label object attribute)
- (display-html-attribute-value object attribute))))
+ (<:span :class "lol-attribute-label"
+ (display-html-attribute-label object attribute))
+ (<:span :class "lol-attribute-value"
+ (display-html-attribute-value object attribute)))))
(define-layered-method display-using-description
:in-layer #.(defining-description 'html-description)
(define-layered-method display-html-attribute-value
:in-layer #.(defining-description 'editable) (object attribute)
- (<:td
- :class "lol-attribute-value"
+
(if (attribute-editp attribute)
- (display-attribute-editor attribute)
- (call-next-method))))
+ (<:td
+ :class "lol-attribute-value"(display-attribute-editor attribute))
+ (call-next-method)))
(define-layered-function display-html-description (description display object &optional next-method)
(:method (description display object &optional (next-method #'display-using-description))
- (<:style
- (<:as-html "
-
-
-
-div.lol-description .lol-attribute-label,
-div.lol-description .lol-attribute-value {
- display: block;
- width: 69%;
- float: left;
- margin-bottom: 1em;
-border:1px solid black;
-
-}
-div.lol-description
-.lol-attribute-label {
- text-align: right;
- width: 24%;
- padding-right: 1em;
-}
-
-span.lol-attribute-value .lol-attribute-value (
- border: 1px solid red;}
-
-
-div.lol-description
-br {
-clear: left;
-}
-
-.clear {clear:left}"
-
-))
+
(with-attributes (css-class dom-id) description
(:metaclass closer-mop:funcallable-standard-class))
-(setf ucw-standard::*default-action-class* 'lisp-on-lines-action)
+(setf ucw-core::*default-action-class* 'lisp-on-lines-action)
(defmethod ucw-core:call-action :around ((action lisp-on-lines-action) application session frame)
(funcall next-method)))
))
-(defmethod ucw-core:handle-action :around ((action lisp-on-lines-action) application session frame)
+(defmethod ucw-core:handle-action :wrap-around ((action lisp-on-lines-action) application session frame)
(let ((lol::*invalid-objects* (make-hash-table)))
(handler-bind ((lol::validation-condition
(lambda (c)