Moved description details out of display.

darcs-hash:20080423200730-39164-af98029ab0fa2775fa21f8b14fb24658a1ae8ab1.gz

diff --git a/lisp-on-lines.asd b/lisp-on-lines.asd
index b180396..0e32bf7 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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)
          "<UNBOUND>")))
    (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 (file)
--- 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 (file)
--- 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 (file)
--- 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)))