From b1c8f43be32503f3911e60696dba8c9194f28ca5 Mon Sep 17 00:00:00 2001 From: drewc Date: Wed, 23 Apr 2008 13:07:30 -0700 Subject: [PATCH] Moved description details out of display. darcs-hash:20080423200730-39164-af98029ab0fa2775fa21f8b14fb24658a1ae8ab1.gz --- lisp-on-lines.asd | 2 +- src/description.lisp | 64 ++++++++++++++++++++++++--- src/display.lisp | 42 ++++-------------- src/standard-descriptions/symbol.lisp | 8 ++-- src/standard-descriptions/t.lisp | 7 +-- src/ucw/packages.lisp | 2 +- src/ucw/standard-components.lisp | 17 +++++++ 7 files changed, 93 insertions(+), 49 deletions(-) diff --git a/lisp-on-lines.asd b/lisp-on-lines.asd index b180396..0e32bf7 100644 --- a/lisp-on-lines.asd +++ b/lisp-on-lines.asd @@ -68,7 +68,7 @@ OTHER DEALINGS IN THE SOFTWARE." :serial t :depends-on (:contextl :arnesi :alexandria :parse-number ;;for rofl: - :simple-date :postmodern)) + :cl-postgres :simple-date :postmodern)) diff --git a/src/description.lisp b/src/description.lisp index 710771f..b64f611 100644 --- a/src/description.lisp +++ b/src/description.lisp @@ -1,5 +1,8 @@ (in-package :lisp-on-lines) +(defvar *object* nil) +(defvar *description*) + (define-layered-function description-of (thing) (:method (thing) (find-description 't))) @@ -10,6 +13,21 @@ (defun description-attributes (description) (description-class-attributes (class-of description))) +(defun description-current-attributes (description) + (remove-if-not + (lambda (attribute) + (and + (some #'layer-active-p + (mapcar #'find-layer + (slot-definition-layers + (attribute-effective-attribute-definition attribute)))))) + (description-attributes description))) + +(defun description-active-attributes (description) + (remove-if-not + #'attribute-active-p + (description-attributes description))) + (defun find-attribute (description attribute-name) (find attribute-name (description-attributes description) :key #'attribute-name)) @@ -31,7 +49,7 @@ (let* ((active-attributes (find-attribute description 'active-attributes)) (attributes (when active-attributes - (attribute-value active-attributes)))) + (ignore-errors (attribute-value active-attributes))))) (if attributes (mapcar (lambda (spec) (find-attribute @@ -50,11 +68,45 @@ (description-attributes description)))))) - - - - -;;; A handy macro. +(defun funcall-with-described-object (function object description &rest args) + (setf description (or description (description-of object))) + (let ((*description* description) + (*object* object)) + (dletf (((described-object *description*) object)) + (funcall-with-layer-context + (modify-layer-context + (if (standard-description-p *description*) + (adjoin-layer *description* (current-layer-context)) + (current-layer-context)) + :activate (description-active-descriptions *description*) + :deactivate (description-inactive-descriptions *description*)) + (lambda () (contextl::funcall-with-special-initargs + (loop + :for (key val) :on args :by #'cddr + :collect (list (find key (description-attributes *description*) + :key #'attribute-keyword) + :value val)) + (lambda () + (contextl::funcall-with-special-initargs + (let ((attribute (ignore-errors (find-attribute *description* 'active-attributes)))) + (when attribute + (loop for spec in (attribute-value attribute) + if (listp spec) + collect (cons (or + (find-attribute *description* (car spec)) + (error "No attribute matching ~A" (car spec))) + (cdr spec))))) + 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))) (destructuring-bind (&optional slots &rest options) options diff --git a/src/display.lisp b/src/display.lisp index 423ee8c..a0be611 100644 --- a/src/display.lisp +++ b/src/display.lisp @@ -1,8 +1,8 @@ (in-package :lisp-on-lines) -(defvar *description*) + (defvar *display*) -(defvar *object* nil) + (define-layered-function display-using-description (description display object &rest args) (:documentation @@ -32,37 +32,11 @@ (define-layered-method display-using-description :around (description display object &rest args) (declare (ignorable args)) - (let ((*description* description) - (*display* display) - (*object* object)) -; (<:as-html " " description "Layer Active?: " (layer-active-p (defining-description 'maxclaims::link-to-viewer))) - (dletf (((described-object description) object)) - (flet ((do-display () - (contextl::funcall-with-special-initargs - (loop - :for (key val) :on args :by #'cddr - :collect (list (find key (description-attributes description) - :key #'attribute-keyword) - :value val)) - (lambda () - (contextl::funcall-with-special-initargs - (let ((attribute (ignore-errors (find-attribute description 'active-attributes)))) - (when attribute - (loop for spec in (attribute-value attribute) - if (listp spec) - collect (cons (or - (find-attribute description (car spec)) - (error "No attribute matching ~A" (car spec))) - (cdr spec))))) - (lambda () (call-next-method))))))) - (funcall-with-layer-context - (modify-layer-context - (if (standard-description-p description) - (adjoin-layer description (current-layer-context)) - (current-layer-context)) - :activate (description-active-descriptions description) - :deactivate (description-inactive-descriptions description)) - (function do-display)))))) + (let ((*display* display)) + (apply #'funcall-with-described-object + (lambda () + (call-next-method)) + object description args))) @@ -88,7 +62,7 @@ OMGWTF! If you didn't do this, it's a bug!" description display object args)) (return (destructuring-bind (description-spec &optional (display-spec (gensym)) (object-spec (gensym))) (car tail) - `(define-layered-method + `(define-layered-method display-using-description :in-layer ,(if (eq t description) t diff --git a/src/standard-descriptions/symbol.lisp b/src/standard-descriptions/symbol.lisp index c811d07..e5d2018 100644 --- a/src/standard-descriptions/symbol.lisp +++ b/src/standard-descriptions/symbol.lisp @@ -7,17 +7,17 @@ ((identity :label nil) (name :function #'symbol-name - :label "Name:") + :label "Name") (value - :label "Value:" + :label "Value" :function (lambda (symbol) (if (boundp symbol) (symbol-value symbol) ""))) (package :function #'symbol-package - :label "Package:") - (function :label "Function:" + :label "Package") + (function :label "Function" :function (lambda (symbol) (if (fboundp symbol) diff --git a/src/standard-descriptions/t.lisp b/src/standard-descriptions/t.lisp index fd8a712..4542618 100644 --- a/src/standard-descriptions/t.lisp +++ b/src/standard-descriptions/t.lisp @@ -2,7 +2,7 @@ (define-description T () ((identity :label nil :function #'identity) - (type :label "Type of" :function #'type-of) + (type :label "Type" :function #'type-of) (class :label "Class" :function #'class-of) (active-attributes :label "Attributes" :value nil @@ -21,7 +21,7 @@ :activep nil :keyword :deactivate) (label-formatter :value (lambda (label) - (generic-format *display* "~A " label)) + (generic-format *display* "~A:" label)) :activep nil) (value-formatter :value (curry #'format nil "~A") :activep nil))) @@ -74,7 +74,8 @@ (define-display :around ((description t) (display null) object) (with-output-to-string (*standard-output*) - (call-next-layered-method description t object))) + (call-next-layered-method description t object)) +) diff --git a/src/ucw/packages.lisp b/src/ucw/packages.lisp index 77a0362..7e143ef 100644 --- a/src/ucw/packages.lisp +++ b/src/ucw/packages.lisp @@ -51,7 +51,7 @@ #:*context* #:context.current-frame #:context.window-component - + #:*current-component* ;; Actions #:call diff --git a/src/ucw/standard-components.lisp b/src/ucw/standard-components.lisp index 48eed0d..0fb99f5 100644 --- a/src/ucw/standard-components.lisp +++ b/src/ucw/standard-components.lisp @@ -74,6 +74,23 @@ :component t :initarg :body))) +(defmethod render-html-head ((window standard-window-component)) + (let* ((app (context.application *context*)) + (url-prefix (application.url-prefix app))) + (<:meta :http-equiv "Content-Type" :content (window-component.content-type window)) + (awhen (window-component.title window) + (<:title (if (functionp it) + (funcall it window) + (<:as-html it)))) + (awhen (window-component.icon window) + (<:link :rel "icon" + :type "image/x-icon" + :href (concatenate 'string url-prefix it))) + (dolist (stylesheet (effective-window-stylesheets window)) + (<:link :rel "stylesheet" + :href stylesheet + :type "text/css")))) + (defmethod render-html-body ((window standard-window-component)) (ucw:render (window-body window))) -- 2.20.1