From f56d6e7e926f9c3f968325e244794ff748435ac3 Mon Sep 17 00:00:00 2001 From: drewc Date: Tue, 9 Jun 2009 11:13:00 -0700 Subject: [PATCH] tons of small changes to bring this up to date with maxclaims 2.0 darcs-hash:20090609181300-39164-c6b993650d1b1dcb650cc7acb7a7bc6bbcc4b15b.gz --- src/description-class.lisp | 8 ++++ src/description.lisp | 8 +--- src/display.lisp | 14 ++++-- src/packages.lisp | 4 ++ src/standard-descriptions/inline.lisp | 14 +++++- src/standard-descriptions/list.lisp | 3 +- src/standard-descriptions/t.lisp | 3 +- src/standard-descriptions/validate.lisp | 1 - src/ucw/html-description.lisp | 63 +++++++------------------ src/ucw/standard-components.lisp | 4 +- 10 files changed, 57 insertions(+), 65 deletions(-) diff --git a/src/description-class.lisp b/src/description-class.lisp index e599444..bba188e 100644 --- a/src/description-class.lisp +++ b/src/description-class.lisp @@ -96,6 +96,14 @@ (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 diff --git a/src/description.lisp b/src/description.lisp index 073dc94..2ce2c81 100644 --- a/src/description.lisp +++ b/src/description.lisp @@ -101,13 +101,7 @@ 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))) diff --git a/src/display.lisp b/src/display.lisp index 7de1c63..6078e83 100644 --- a/src/display.lisp +++ b/src/display.lisp @@ -17,10 +17,18 @@ (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 @@ -42,8 +50,6 @@ - - (defun display/d (&rest args) (apply #'display-using-description args)) diff --git a/src/packages.lisp b/src/packages.lisp index e456cf0..07ff448 100644 --- a/src/packages.lisp +++ b/src/packages.lisp @@ -14,6 +14,7 @@ #:find-description #:description-of #:define-description + #:defining-description #:described-object #:with-described-object #:described-class @@ -39,12 +40,15 @@ #: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 diff --git a/src/standard-descriptions/inline.lisp b/src/standard-descriptions/inline.lisp index b04914e..3f349dd 100644 --- a/src/standard-descriptions/inline.lisp +++ b/src/standard-descriptions/inline.lisp @@ -15,6 +15,16 @@ () ()) +(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)) diff --git a/src/standard-descriptions/list.lisp b/src/standard-descriptions/list.lisp index 1d5737d..0beb994 100644 --- a/src/standard-descriptions/list.lisp +++ b/src/standard-descriptions/list.lisp @@ -12,8 +12,7 @@ (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)) diff --git a/src/standard-descriptions/t.lisp b/src/standard-descriptions/t.lisp index 5baf369..223261f 100644 --- a/src/standard-descriptions/t.lisp +++ b/src/standard-descriptions/t.lisp @@ -46,6 +46,7 @@ (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 @@ -103,7 +104,7 @@ (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 diff --git a/src/standard-descriptions/validate.lisp b/src/standard-descriptions/validate.lisp index 5a5fb62..6bfeaeb 100644 --- a/src/standard-descriptions/validate.lisp +++ b/src/standard-descriptions/validate.lisp @@ -64,7 +64,6 @@ t))) - (defun validp (object) (with-described-object (object nil) (every #'identity (mapcar (lambda (attribute) diff --git a/src/ucw/html-description.lisp b/src/ucw/html-description.lisp index 83847ed..94a8add 100644 --- a/src/ucw/html-description.lisp +++ b/src/ucw/html-description.lisp @@ -24,6 +24,7 @@ ((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 @@ -47,26 +48,26 @@ (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) @@ -79,8 +80,10 @@ :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) @@ -137,47 +140,15 @@ (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 diff --git a/src/ucw/standard-components.lisp b/src/ucw/standard-components.lisp index 9aea34d..8ffe33d 100644 --- a/src/ucw/standard-components.lisp +++ b/src/ucw/standard-components.lisp @@ -7,7 +7,7 @@ (: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) @@ -22,7 +22,7 @@ (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) -- 2.20.1