Properties are special now!

Added compatibility with special slots from contextl. also added inline descriptions and
added them in display-attribute where they belong.

darcs-hash:20080125085403-39164-31c580e9f256b6384d7a6d8cae8efcf302784565.gz

diff --git a/lisp-on-lines.asd b/lisp-on-lines.asd
index abecfd6..bb4117b 100644 (file)
--- a/lisp-on-lines.asd
+++ b/lisp-on-lines.asd
@@ -41,6 +41,7 @@ OTHER DEALINGS IN THE SOFTWARE."
                        :components ((:file "contextl-hacks")
                                     (:file "packages")
                                     
                        :components ((:file "contextl-hacks")
                                     (:file "packages")
                                     

+                                    (:file "rofl")

                                     (:file "utilities")
                                     
                                     (:file "display")
                                     (:file "utilities")
                                     
                                     (:file "display")


@@ -54,6 +55,7 @@ OTHER DEALINGS IN THE SOFTWARE."
 
                                    (:module :standard-descriptions
                                              :components ((:file "t")
 
                                    (:module :standard-descriptions
                                              :components ((:file "t")

+                                                          (:file "inline")

                                                           (:file "edit")
                                                           (:file "symbol")
                                                           (:file "list")
                                                           (:file "edit")
                                                           (:file "symbol")
                                                           (:file "list")


@@ -63,7 +65,7 @@ OTHER DEALINGS IN THE SOFTWARE."
                                     
                                     :serial t))
   :serial t
                                     
                                     :serial t))
   :serial t

-  :depends-on (:contextl :arnesi :alexandria))
+  :depends-on (:contextl :arnesi :alexandria :postmodern))

 
 
 
 
 
 

diff --git a/src/attribute.lisp b/src/attribute.lisp
dissimilarity index 77%
index e502859..2b66d42 100644 (file)
--- a/src/attribute.lisp
+++ b/src/attribute.lisp
@@ -1,229 +1,288 @@
-(in-package :lisp-on-lines)
-
-(define-layered-class direct-attribute-definition-class 
- (special-layered-direct-slot-definition contextl::singleton-direct-slot-definition)
-  ((attribute-properties :accessor direct-attribute-properties
-                    :documentation "This is an plist to hold the values of the attribute's properties as described by this direct attrbiute definition.")))
-
-(defmethod initialize-instance :after ((attribute direct-attribute-definition-class) &rest initargs)
-  (setf (direct-attribute-properties attribute)  initargs))
-
-(define-layered-class effective-attribute-definition-class (special-layered-effective-slot-definition) 
-  ((direct-attributes :accessor attribute-direct-attributes)
-   (attribute-object :accessor attribute-object
-                    :documentation "")
-   (attribute-object-initargs :accessor attribute-object-initargs)))
-
-
-(define-layered-function attribute-value (object attribute))
-
-(define-layered-method attribute-value (object attribute)
-                      
- (let ((fn (handler-case (attribute-function attribute)
-            (unbound-slot () nil))))
-   (if fn 
-       (funcall fn object)
-       (%attribute-value attribute))))
-
-(defmethod attribute-description (attribute)
-  ;(break "description for ~A is (slot-value attribute 'description-name)")
-  (find-layer (slot-value attribute 'description-class))
-#+nil  (let ((name (slot-value attribute 'description-name)))
-    (when name 
-      (find-description name))))
-
-
-(define-layered-class standard-attribute ()
-                     
-  ((effective-attribute-definition :initarg effective-attribute
-                                  :accessor attribute-effective-attribute-definition)
-   (description-name)
-   (description-class :initarg description-class)
-   (initfunctions :initform nil)
-   (attribute-class :accessor attribute-class 
-                   :initarg :attribute-class 
-                   :initform 'standard-attribute
-                   :layered t)
-   (name :layered-accessor attribute-name 
-         :initarg :name)
-   (label :layered-accessor attribute-label 
-         :initarg :label
-         :initform nil
-         :layered t
-         :special t
-         )
-   (function 
-    :initarg :function 
-    :layered-accessor attribute-function
-    :layered t)
-   (value :layered-accessor %attribute-value 
-         :initarg :value
-         :layered t)))
-
-(defmethod print-object ((object standard-attribute) stream)
-  (print-unreadable-object (object stream :type nil :identity t)
-    (format stream "ATTRIBUTE ~A" (or (ignore-errors (attribute-name object)) "+unnamed-attribute+"))))
-
-(defgeneric eval-property-initarg (att initarg)
-  (:method ((attribute standard-attribute) initarg)
-  nil)
-  (:method ((attribute standard-attribute) (initarg (eql :function)))
-    t))
-
-(defun prepare-initargs (att args)
-  (loop 
-     :for (key arg) 
-     :on args :by #'cddr 
-     :nconc (list key 
-                 (if (eval-property-initarg att key)
-                     (eval arg)
-                     arg))))
-
-(defvar *bypass-property-layered-function* nil)
-
-(define-layered-function property-layered-function (description attribute-name property-name)
-  (:method  (description attribute-name property-name)
-    ;(dprint "First Time PLFunction for ~A ~A ~A" description attribute-name property-name)
-    (ensure-layered-function 
-     (defining-description (intern (format nil "~A-~A-~A" 
-                   (description-print-name description)
-                    attribute-name
-                    property-name)))
-
-     :lambda-list '(description))))
-
-
-(define-layered-method (setf slot-value-using-layer)
-  :in-layer (context t)
-  :around
-  (new-value class (attribute standard-attribute) property writer)
-
-  (when (or *bypass-property-layered-function* )
-    
-    (return-from slot-value-using-layer (call-next-method)))
-
-  (let ((layer
-        ;;FIXME: this is wrong for so many reasons
-        (find-layer (first (remove nil (closer-mop::class-precedence-list (class-of context))
-                                   :key #'class-name))))
-       (boundp (slot-boundp-using-class class attribute property))
-       (val (real-slot-value-using-class class attribute property)))
-     
-    (when (special-symbol-p val)
-      (return-from slot-value-using-layer (call-next-method)))
-
-    (when (not boundp)
-      ;; * This slot has never been set before.
-      ;; create a method on property-layered-function
-      ;; so subclasses can see this new property.
-      (ensure-layered-method 
-       (layered-function-definer 'property-layered-function)
-       `(lambda (description attribute property)
-         (declare (ignore description attribute property))
-         ,val)
-       :in-layer layer
-       :specializers  
-       (list (class-of  
-             (attribute-description attribute))
-            (closer-mop:intern-eql-specializer 
-             (attribute-name attribute))
-            (closer-mop:intern-eql-specializer 
-             (closer-mop:slot-definition-name property)))))
-
-    ;; specialize this property to this description.
-
-    (ensure-layered-method 
-     val
-     `(lambda (description)
-       (funcall ,(lambda()
-                        new-value)))
-     :in-layer layer 
-     :specializers (list (class-of (attribute-description attribute))))
-
-    ;; and return the set value as is custom
-    (slot-value-using-class class attribute property)))
-        
-
-(define-layered-method slot-value-using-layer 
-  :in-layer (layer t)
-  :around (class (attribute standard-attribute) property reader)
-
-  ;;  (dprint "Getting the slot value of ~A" property) 
-  
-  ;; We do some magic in here and i thought it 
-  ;; would be called magically in call-next-method.
-  ;; This explicit call is good enough for now.
-
-  (unless (slot-boundp-using-class class attribute property)
-    (slot-unbound class attribute (slot-definition-name property)))
-  
-  (let ((val (print (call-next-method))))
-    
-  (if (and 
-       ;; Not special access 
-       (not (symbolp val))
-       (contextl::slot-definition-layeredp property)
-       (not *bypass-property-layered-function*))
-      (let ((fn val))
-       ;(dprint "... using fn ~A to get value" fn)
-      (funcall fn layer  (attribute-description attribute)))
-      val)))
-
-(defmacro define-bypass-function (name function-name)
-  `(defun ,name (&rest args)
-     (let ((*bypass-property-layered-function* t))
-       (apply (function ,function-name) args))))
-
-(define-bypass-function real-slot-boundp-using-class slot-boundp-using-class)
-(define-bypass-function real-slot-value-using-class slot-value-using-class)
-(define-bypass-function (setf real-slot-value-using-class) (setf slot-value-using-class))
-  
-(defun slot-boundp-using-property-layered-function (class attribute property)
-  ;(dprint "plf boundp:")
-  (let* ((really-bound-p 
-         (real-slot-boundp-using-class class attribute property))
-        (fn (if really-bound-p 
-                (real-slot-value-using-class class attribute property)
-                (setf (real-slot-value-using-class class attribute property)
-                      (property-layered-function 
-                       (attribute-description attribute)
-                       (attribute-name attribute)
-                       (closer-mop:slot-definition-name property))))))
-
-       (if (generic-function-methods fn)
-           T
-           NIL)))
-    
-(define-layered-method slot-boundp-using-layer  
-  :in-layer (layer t)
-  :around (class (attribute standard-attribute) property reader)
-  (if (or *bypass-property-layered-function* *symbol-access*)
-      (call-next-method)
-      (slot-boundp-using-property-layered-function class attribute property)))
-        
-(defun attribute-value* (attribute)
-  (attribute-value *object* attribute))
-
-(defmacro with-attributes (names description &body body)
-  `(with-slots ,names ,description ,@body))  
-
-(defun display-attribute (attribute)
-  (display-using-description attribute *display* *object*))
-
-(define-layered-method display-using-description 
-  ((attribute standard-attribute) display object &rest args)
-  (declare (ignore args))
-  (when (attribute-label attribute)
-    (format display "~A " (attribute-label attribute)))
-  (format display "~A" (attribute-value object attribute)))
-
-
-
-
-
-
-
-                      
-       
-
-
+(in-package :lisp-on-lines)
+
+(define-layered-class direct-attribute-definition-class 
+  (special-layered-direct-slot-definition 
+   contextl::singleton-direct-slot-definition)
+  ((attribute-properties 
+    :accessor direct-attribute-properties
+    :documentation "This is an plist to hold the values of 
+    the attribute's properties as described by this direct 
+    attribute definition.")))
+
+(defmethod initialize-instance 
+    :after ((attribute direct-attribute-definition-class) 
+           &rest initargs)
+  (setf (direct-attribute-properties attribute) initargs))
+
+(define-layered-class effective-attribute-definition-class 
+    (special-layered-effective-slot-definition) 
+  ((direct-attributes 
+    :accessor attribute-direct-attributes)
+   (attribute-object 
+    :accessor attribute-object)
+   (attribute-object-initargs 
+    :accessor attribute-object-initargs)))
+
+(defvar *function-access* nil
+  "set/get a place's property function instead of its symbol value
+   when this is set to a non-nil value")
+
+(defmacro with-function-access (&body body)
+  "executes body in an environment with *function-access* set to t"
+  `(let ((*function-access* t))
+     ,@body))
+
+(defmacro without-function-access (&body body)
+  "executes body in an environment with *function-access* set to nil"
+  `(let ((*function-access* nil))
+     ,@body))
+
+(define-layered-function property-access-function (description attribute-name property-name)
+  (:method  (description attribute-name property-name)
+    (ensure-layered-function 
+     (defining-description 
+        (intern (format nil "~A-~A-~A" 
+                        (description-print-name description)
+                        attribute-name
+                        property-name)))
+        :lambda-list '(description))))
+
+
+(define-layered-class standard-attribute ()
+ ((description-class :initarg description-class)
+  (name 
+   :layered-accessor attribute-name 
+   :initarg :name)
+  (effective-attribute-definition 
+    :initarg effective-attribute
+    :accessor attribute-effective-attribute-definition)
+  (attribute-class 
+   :accessor attribute-class 
+   :initarg :attribute-class 
+   :initform 'standard-attribute
+   :layered t)
+  (label 
+   :layered-accessor attribute-label 
+   :initarg :label
+   :initform nil
+   :layered t
+   :special t)
+  (function 
+   :initarg :function 
+   :layered-accessor attribute-function
+   :layered t
+   :special t)
+   (value 
+    :layered-accessor %attribute-value 
+    :initarg :value
+    :layered t
+    :special t)
+  (activep 
+   :layered-accessor attribute-active-p
+   :initarg :activep
+   :initform t
+   :layered t
+   :special t)
+  (keyword
+   :layered-accessor attribute-keyword
+   :initarg :keyword
+   :initform nil
+   :layered t)
+))
+
+(defun ensure-access-function (class attribute property)
+  (with-function-access 
+    (if (slot-definition-specialp property)
+       (let ((slot-symbol 
+              (with-symbol-access
+                (slot-value-using-class 
+                 class attribute property))))
+         (if (fboundp slot-symbol)
+             (symbol-function slot-symbol)
+             (setf (symbol-function slot-symbol)
+                   (property-access-function
+                    (attribute-description attribute)
+                    (attribute-name attribute)
+                    (slot-definition-name property)))))
+       (if (slot-boundp-using-class class attribute property)
+           (slot-value-using-class class attribute property)
+           (setf (slot-value-using-class class attribute property)
+                 (property-access-function
+                  (attribute-description attribute)
+                  (attribute-name attribute)
+                  (slot-definition-name property)))))))
+
+(define-layered-method slot-boundp-using-layer  
+  :in-layer (layer t)
+  :around (class (attribute standard-attribute) property reader)
+
+; (dprint "Checking boundp ~A ~A" (attribute-name attribute)
+       ; (slot-definition-name property))
+
+  (if (or *symbol-access* *function-access*)
+      (call-next-method)
+      (or (when (slot-definition-specialp property)
+           (with-function-access
+          (slot-boundp-using-class class attribute property)))
+         (if (generic-function-methods 
+              (ensure-access-function class attribute property))
+             T
+             NIL))))
+
+(define-layered-method (setf slot-value-using-layer)
+  :in-layer (context t)
+  :around
+  (new-value class (attribute standard-attribute) property writer)
+  
+;;  (dprint "Setting ~A ~A to : ~A" attribute property new-value)
+
+  (if (or *symbol-access* *function-access*)
+      (call-next-method)
+            
+      (if (and (slot-definition-specialp property)
+              (with-function-access
+                (without-symbol-access (slot-boundp-using-class class attribute property))))
+         (with-function-access
+           (call-next-method))
+         (let ((layer
+                ;;FIXME: this is wrong for so many reasons
+                (find-layer (first (remove nil (closer-mop::class-precedence-list (class-of context))
+                                           :key #'class-name))))
+               (boundp (slot-boundp-using-class class attribute property))
+               (fn  (ensure-access-function class attribute property)))
+
+           (when (not boundp)
+             ;; * This slot has never been set before.
+             ;; create a method on property-accessor-function
+             ;; so subclasses can see this new property.
+             (ensure-layered-method 
+              (layered-function-definer 'property-access-function)
+              `(lambda (description attribute property)
+                 (declare (ignore description attribute property))
+                 ,fn)
+              :in-layer layer
+              :specializers  
+              (list (class-of  
+                     (attribute-description attribute))
+                    (closer-mop:intern-eql-specializer 
+                     (attribute-name attribute))
+                    (closer-mop:intern-eql-specializer 
+                     (closer-mop:slot-definition-name property)))))
+
+           ;; specialize this property to this description.
+           ;;(dprint "actrually specializering")
+           (ensure-layered-method 
+            fn
+            `(lambda (description)
+               (funcall ,(lambda()
+                                new-value)))
+            :in-layer layer 
+            :specializers (list (class-of (attribute-description attribute))))
+
+           ;;  and return the set value as is custom
+           new-value))))
+                     
+(define-layered-method slot-value-using-layer 
+  :in-layer (layer t)
+  :around (class (attribute standard-attribute) property reader)
+  
+;  ;(dprint "Getting the slot value of ~A" property)   
+  (if (or *symbol-access* *function-access*)
+      (call-next-method)
+      (let ((fn (ensure-access-function class attribute property)))
+
+       (unless (slot-boundp-using-class class attribute property)
+         (slot-unbound class attribute (slot-definition-name property)))
+
+       (if (slot-definition-specialp property)
+           (if (with-function-access
+                 (slot-boundp-using-class class attribute property))
+               (with-function-access 
+                 (slot-value-using-class class attribute property))
+               (funcall fn layer (attribute-description attribute)))
+           (funcall fn layer (attribute-description attribute))))))
+                   
+             
+
+ (define-layered-function attribute-value (object attribute))
+
+ (define-layered-method attribute-value (object attribute)
+                      
+                          (let ((fn (handler-case (attribute-function attribute)
+                                      (unbound-slot () nil))))
+                            (if fn 
+                                (funcall fn object)
+                                (%attribute-value attribute))))
+
+(defmethod attribute-description (attribute)
+                                       ;(break "description for ~A is (slot-value attribute 'description-name)")
+      (find-layer (slot-value attribute 'description-class))
+      #+nil  (let ((name (slot-value attribute 'description-name)))
+              (when name 
+                (find-description name))))
+
+
+
+(defmethod print-object ((object standard-attribute) stream)
+  (print-unreadable-object (object stream :type nil :identity t)
+    (format stream "ATTRIBUTE ~A" (or (ignore-errors (attribute-name object)) "+unnamed-attribute+"))))
+
+(defgeneric eval-property-initarg (att initarg)
+  (:method ((attribute standard-attribute) initarg)
+    nil)
+  (:method ((attribute standard-attribute) (initarg (eql :function)))
+    t))
+
+(defun prepare-initargs (att args)
+  (loop 
+     :for (key arg) 
+     :on args :by #'cddr 
+     :nconc (list key 
+                 (if (eval-property-initarg att key)
+                     (eval arg)
+                     arg))))
+
+
+(defun attribute-value* (attribute)
+  (attribute-value *object* attribute))
+
+(defmacro with-attributes (names description &body body)
+  `(with-slots ,names ,description ,@body))  
+
+(define-layered-function display-attribute (object attribute)
+  (:method (object attribute)
+    (display-using-description attribute *display* object)))
+
+(define-layered-function display-attribute-label (object attribute)
+  (:method (object attribute)
+        (format *display* "~A " (attribute-label attribute))
+))
+
+(define-layered-function display-attribute-value (object attribute)
+  (:method (object attribute)
+    (let ((val (attribute-value object attribute)))
+      (if (eq val object)
+         (format *display* "~A " val)
+                 (with-active-descriptions (inline)
+                   (display *display* val )
+
+                   )
+         ))))
+
+(define-layered-method display-using-description 
+  ((attribute standard-attribute) display object &rest args)
+  (declare (ignore args))
+  (when (attribute-label attribute)
+    (display-attribute-label object attribute))
+  (display-attribute-value object attribute))
+
+
+
+
+
+
+
+                      
+       
+
+

diff --git a/src/contextl-hacks.lisp b/src/contextl-hacks.lisp
index ec78c35..ee4e38a 100644 (file)
--- a/src/contextl-hacks.lisp
+++ b/src/contextl-hacks.lisp
@@ -40,4 +40,25 @@
                      (list 
                      (find-class 'special-object)))
              initargs)))
                      (list 
                      (find-class 'special-object)))
              initargs)))

-     (call-next-method))
\ No newline at end of file
+     (call-next-method))
+
+
+
+(defun funcall-with-special-initargs (bindings thunk)
+  (let ((arg-count 0))
+  (special-symbol-progv
+      (loop for (object . initargs) in bindings
+            for initarg-keys = (loop for key in initargs by #'cddr 
+                                    collect key into keys
+                                   count t into count
+                                   finally (incf arg-count count)
+                                           (return keys))
+            nconc (loop for slot in (class-slots (class-of object))
+                        when (and (slot-definition-specialp slot)
+                                  (intersection initarg-keys (slot-definition-initargs slot)))
+                        collect (with-symbol-access
+                                  (slot-value object (slot-definition-name slot)))))
+      (make-list arg-count :initial-element nil)
+    (loop for (object . initargs) in bindings
+          do (apply #'shared-initialize object nil :allow-other-keys t initargs))
+    (funcall thunk))))
\ No newline at end of file

diff --git a/src/description-class.lisp b/src/description-class.lisp
index 895c7ed..0669167 100644 (file)
--- a/src/description-class.lisp
+++ b/src/description-class.lisp
@@ -68,7 +68,8 @@
             (superclass standard-class))
   t)
 
             (superclass standard-class))
   t)
 

-(defclass standard-description-object (standard-layer-object) ())
+(defclass standard-description-object (standard-layer-object) 
+  ())

 
 (defun description-class-name  (description-class)
     (read-from-string (symbol-name (class-name description-class))))
 
 (defun description-class-name  (description-class)
     (read-from-string (symbol-name (class-name description-class))))


@@ -82,7 +83,7 @@
 ;;; For now. --drewc
 
   (pushnew class *defined-descriptions*)
 ;;; For now. --drewc
 
   (pushnew class *defined-descriptions*)

-  
+

 ;;; ENDHACK.
 
   (let* ((description (find-layer class)) 
 ;;; ENDHACK.
 
   (let* ((description (find-layer class)) 

diff --git a/src/description.lisp b/src/description.lisp
index c06a6f4..d19b92e 100644 (file)
--- a/src/description.lisp
+++ b/src/description.lisp
@@ -8,7 +8,8 @@
   (description-class-name (class-of description)))
 
 (defun find-attribute (description attribute-name)
   (description-class-name (class-of description)))
 
 (defun find-attribute (description attribute-name)

-  (slot-value description attribute-name))
+  (when (slot-exists-p description attribute-name) 
+    (slot-value description attribute-name)))

 
 
 (defun description-attributes (description)
 
 
 (defun description-attributes (description)


@@ -18,21 +19,34 @@
           description) 
          (class-slots (class-of description))))
 
           description) 
          (class-slots (class-of description))))
 

-(defvar *display-attributes* nil)
-(defun attribute-active-p (attribute)
-  (or (null *display-attributes*)
-      (find (attribute-name attribute) *display-attributes*)))
+

 
 (define-layered-function attributes (description)
   (:method (description)
 
 (define-layered-function attributes (description)
   (:method (description)

-    (remove-if-not 
-     (lambda (attribute)
-       (and (attribute-active-p attribute)
-           (some #'layer-active-p 
-            (mapcar #'find-layer 
-                    (slot-definition-layers 
-                     (attribute-effective-attribute-definition attribute))))))
-     (description-attributes description))))
+    (let* ((active-attributes 
+           (find-attribute description 'active-attributes))
+          (attributes (when active-attributes
+            (attribute-value *object* active-attributes))))
+      (if attributes
+         (mapcar (lambda (spec)                    
+                   (find-attribute 
+                    description
+                    (if (listp spec)
+                        (car spec)
+                        spec)))
+                 attributes)
+         (remove-if-not 
+          (lambda (attribute)
+            (and (attribute-active-p attribute)                     
+                 (some #'layer-active-p 
+                       (mapcar #'find-layer 
+                               (slot-definition-layers 
+                                (attribute-effective-attribute-definition attribute))))))
+          (description-attributes description))))))
+         
+
+
+  

 
   
 ;;; A handy macro.
 
   
 ;;; A handy macro.

diff --git a/src/display.lisp b/src/display.lisp
index 5888f0b..28957a9 100644 (file)
--- a/src/display.lisp
+++ b/src/display.lisp
@@ -2,7 +2,8 @@
 
 (defvar *description*)
 (defvar *display*)
 
 (defvar *description*)
 (defvar *display*)

-(defvar *object*)
+(defvar *object* nil)
+

 
 (deflayer display-layer)
 
 
 (deflayer display-layer)
 


@@ -12,7 +13,7 @@
 
 (defun display (display object &rest args &key attributes )
   (let ((*display-attributes* attributes))
 
 (defun display (display object &rest args &key attributes )
   (let ((*display-attributes* attributes))

-    (display-using-description (description-of object) display object args)))
+    (apply #'display-using-description (description-of object) display object args)))

 
 (define-layered-method display-using-description 
   :around (description display object &rest args)
 
 (define-layered-method display-using-description 
   :around (description display object &rest args)


@@ -20,20 +21,35 @@
   (let ((*description* description)
        (*display* display)
        (*object*  object))
   (let ((*description* description)
        (*display* display)
        (*object*  object))

-    (call-next-method)))
+    (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 (find-attribute description 'active-attributes)))     
+          (when attribute
+            (loop for spec in (attribute-value object 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)))))))
+                             
+

 
 (defun display/d (&rest args)
   (apply #'display-using-description args))
 
 
 (defun display/d (&rest args)
   (apply #'display-using-description args))
 

-
-

 (define-layered-method display-using-description (description display object &rest args)
  (error "No DISPLAY-USING-DESCRIPTION methods are specified for: ~%  DESCRIPTION: ~A ~%  DISPLAY: ~A ~%  OBJECT: ~A ~%  ARGS: ~S
 
 OMGWTF! If you didn't do this, it's a bug!" description display object args))
 
 (define-layered-method display-using-description (description display object &rest args)
  (error "No DISPLAY-USING-DESCRIPTION methods are specified for: ~%  DESCRIPTION: ~A ~%  DISPLAY: ~A ~%  OBJECT: ~A ~%  ARGS: ~S
 
 OMGWTF! If you didn't do this, it's a bug!" description display object args))
 

-
-

 (defmacro define-display (&body body)
   (loop with in-descriptionp = (eq (car body) :in-description)
        with description = (if in-descriptionp (cadr body) 't)
 (defmacro define-display (&body body)
   (loop with in-descriptionp = (eq (car body) :in-description)
        with description = (if in-descriptionp (cadr body) 't)

diff --git a/src/packages.lisp b/src/packages.lisp
index e65ff7c..2bca20d 100644 (file)
--- a/src/packages.lisp
+++ b/src/packages.lisp
@@ -3,13 +3,20 @@
    :common-lisp
    #:contextl
    #:closer-mop
    :common-lisp
    #:contextl
    #:closer-mop

+   #:postmodern

    #:alexandria)
   (:nicknames #:lol)
   (:export
    #:alexandria)
   (:nicknames #:lol)
   (:export

-   
+
+;; ROFL stuff here temporarily
+   #:standard-db-access-class
+   #:make-dao-from-row
+   #:described-db-access-class
+

 ;; Descriptions
    #:find-description
    #:define-description
 ;; Descriptions
    #:find-description
    #:define-description

+   #:described-class

    #:with-active-descriptions
 
    ;; Displays
    #:with-active-descriptions
 
    ;; Displays

diff --git a/src/rofl.lisp b/src/rofl.lisp
new file mode 100644 (file)
index 0000000..48cc0cc
--- /dev/null
+++ b/src/rofl.lisp
@@ -0,0 +1,223 @@
+(in-package :lisp-on-lines)
+
+
+(defclass db-access-slot-definition ()
+  ((column-name  :initform nil :initarg :db-name :accessor slot-definition-column-name
+               :documentation
+              "If non-NIL, contains the name of the column this slot is representing.")
+   (primary-key :initform nil 
+               :initarg :primary-key 
+               :accessor slot-definition-primary-key-p)
+   (transient  :initform nil :initarg :transient :accessor slot-definition-transient-p
+               :documentation
+              "If non-NIL, this slot should be treated as transient and
+ignored in all database related operations.")
+   (not-null :initform nil :initarg :not-null :accessor slot-definition-not-null-p
+             :documentation "If non-NIL, a NON NULL database
+constrained will be introduced.")
+   (foreign-type 
+    :initform nil 
+    :initarg :foreign-type
+    :initarg :references
+    :accessor slot-definition-foreign-type)
+   (unique :initform nil :initarg :unique :accessor slot-definition-unique)
+   
+
+   (on-delete :initform :cascade :initarg :on-delete :accessor slot-definition-on-delete
+              :documentation "Action to be performed for this slot
+when the refering row in the database ceases to exist. Possible
+values: :CASCADE, :RESTRICT, :SET-NULL, :SET-DEFAULT. If this slot is
+not a foreign key, it does nothing.")
+   (delayed-constraint :initform nil :accessor slot-definition-delayed-constraint
+                        :documentation "Closures adding constraints
+that, for some reason, could not be executed. If there's a slot with
+this attribute not-NIL in a class definition, then there's something
+wrong with its SQL counterpart.")))
+
+(defmethod slot-definition-column-name :around (slotd)
+  (or (call-next-method) (slot-definition-name slotd)))
+
+
+(defclass db-access-class (standard-class)
+  ((table-name :initarg :table-name :initform nil :accessor class-table-name)
+   (indices :initarg :indices :initform () :reader class-indices)
+   (unique :initarg :unique :initform () :reader class-unique)
+   #+not!(connection-spec :initarg :connection-spec :initform nil :reader db-class-connection-spec)
+   
+   (unfinished-classes :initform nil :allocation :class :accessor class-unfinished-classes
+                       :documentation "A class allocated slot
+containing classes for whom not all the constraints could be
+applied.")
+   (foreign-keys :initform nil :accessor class-foreign-keys
+                 :documentation "List of foreign-key slots.")
+   (unique-keys :initform nil :accessor class-unique-keys
+                :documentation "List of slots whose value should be unique."))
+  (:documentation "Metaclass for PostgreSQL aware classes. It takes
+two additional arguments in DEFTABLE: :INDICES (which slots are used
+as indices) and :CONNECTION-SPEC, which specifies how the class should
+connect to the database (its format is the same as in
+POSTMODERN:CONNECT-TOPLEVEL). If :CONNECTION-SPEC is not provided,
+SUBMARINE assumes it is a class created just for the sake of
+inheritance and does not create any tables for it."))
+
+(defmethod validate-superclass
+           ((class db-access-class)
+            (superclass standard-class))
+  t)
+
+
+(defclass db-access-direct-slot-definition (standard-direct-slot-definition
+                                           db-access-slot-definition)
+  ())
+
+(defmethod direct-slot-definition-class
+           ((class db-access-class) &key &allow-other-keys)
+  (find-class 'db-access-direct-slot-definition))
+
+(defclass db-access-effective-slot-definition 
+    (standard-effective-slot-definition
+     db-access-slot-definition)
+  ())
+
+(defmethod effective-slot-definition-class
+           ((class db-access-class) &key &allow-other-keys)
+  (find-class 'db-access-effective-slot-definition))
+
+(defmethod compute-effective-slot-definition
+           ((class db-access-class) name direct-slot-definitions)
+  (declare (ignore name))
+  (let ((slotd (call-next-method)))
+    (setf (slot-definition-primary-key-p slotd) 
+         (some #'slot-definition-primary-key-p direct-slot-definitions)
+         (slot-definition-transient-p slotd) 
+         (every #'slot-definition-transient-p direct-slot-definitions)
+         (slot-definition-foreign-type slotd) 
+         (slot-definition-foreign-type (car direct-slot-definitions))
+         (slot-definition-not-null-p slotd) 
+         (slot-definition-not-null-p (car direct-slot-definitions))
+         (slot-definition-unique slotd) (slot-definition-unique (car direct-slot-definitions))
+         (slot-definition-type slotd) (slot-definition-type (car direct-slot-definitions)))
+    slotd))
+
+(defun class-id-slot-definition (class)
+  (find-if #'slot-definition-primary-key-p 
+          (class-slots class)))
+
+(defmethod class-table-name :around (class)
+  (or (call-next-method) 
+      (class-name class)))
+
+(defclass standard-db-access-class (db-access-class)
+  ())
+
+(defun dao-id-column-name (class)
+  (slot-definition-column-name
+   (or (class-id-slot-definition class)
+       (error "No ID slot (primary key) for ~A" class))))
+
+(defclass described-db-access-class (standard-db-access-class described-class)
+  ())
+
+(defmethod initialize-instance :around ((class standard-db-access-class) &rest initargs &key (direct-superclasses '()))
+  (declare (dynamic-extent initargs))
+  (if (loop for direct-superclass in direct-superclasses
+        thereis (ignore-errors (subtypep direct-superclass 'standard-db-access-object)))
+      (call-next-method)
+      (apply #'call-next-method
+            class
+            :direct-superclasses
+            (append direct-superclasses
+                    (list (find-class 'standard-db-access-object)))
+            initargs)))
+
+(defmethod reinitialize-instance :around ((class standard-db-access-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p))
+  (declare (dynamic-extent initargs))
+  (if (or (not direct-superclasses-p)
+         (loop for direct-superclass in direct-superclasses
+            thereis (ignore-errors (subtypep direct-superclass 'standard-db-access-object))))
+      (call-next-method)
+      (apply #'call-next-method
+            class
+            :direct-superclasses
+            (append direct-superclasses
+                    (list (find-class 'standard-db-access-object)))
+            initargs)))
+
+(defclass standard-db-access-object (standard-object)
+  ())
+
+
+
+(defun find-dao (type id 
+                &key (table (class-table-name (find-class type)))
+                     id-column-name)
+                            
+  "Get the dao corresponding to the given primary key,
+or return nil if it does not exist."
+  (let ((row (first (query 
+             (:select '* 
+              :from table 
+               :where (:= id (or id-column-name
+                                (dao-id-column-name 
+                                 (find-class type)))))))))
+    (make-dao-from-row type row)))
+
+(defmethod shared-initialize :after ((dao standard-db-access-object) 
+                                    slots &rest initargs)
+  (let ((class (class-of dao)))
+    (dolist (slotd (class-slots class))
+      (with-slots (foreign-type) slotd
+       (when foreign-type
+         (if (slot-boundp-using-class class dao slotd)
+             (let ((value (slot-value-using-class class dao slotd)))           
+               (unless (typep value foreign-type)
+                 (if (connected-p *database*)
+                     (setf (slot-value-using-class class dao slotd)
+                           (find-dao foreign-type value))
+                     (let ((obj (make-instance foreign-type)))
+                       (setf (slot-value-using-class 
+                              (class-of obj)
+                              obj
+                              (class-id-slot-definition (class-of obj)))
+                             value)))))))))))
+                              
+(defgeneric dao-id (dao)
+  (:method ((dao standard-db-access-object))
+    (let ((class (class-of dao)))
+      
+      (slot-value-using-class class dao (class-id-slot-definition class)))))
+
+(defun make-dao-from-row (type row &key slots)
+  (let* ((class (find-class type))
+        (dao (make-instance class))
+        (slotds (class-slots class)))
+    (loop 
+        :for val :in row 
+        :for slotd 
+       :in (or 
+           (loop 
+              :for slot :in slots 
+              :collect (find slot slotds 
+                             :key #'slot-definition-name))
+           slotds)
+        :do (setf (slot-value-using-class class dao slotd) val)
+        :finally (return (reinitialize-instance dao)))))
+  
+;(defgeneric make-dao (type &rest initargs)
+#+nil(defun make-dao (type initargs)
+  "Create a DAO of the given `TYPE' and initialize it according
+  to the values of the alist `INITARGS'. `Initargs' may contain
+  additional values, not used in the initialization proccess."
+  (let ((instance (make-instance type)))
+    (iter (for slot in (slots-of instance))
+         (setf (slot-value instance (slot-definition-name slot))
+               (let ((the-value (cdr (assoc (intern (symbol-name (slot-definition-name slot)) 'keyword) initargs))))
+                 (if (foreign-type-p slot)
+                     (make-instance (sb-pcl:slot-definition-type slot) :id the-value)
+                     the-value))))
+    instance))
+
+
+
+
+

diff --git a/src/standard-descriptions/clos.lisp b/src/standard-descriptions/clos.lisp
index 2824c2e..8531b22 100644 (file)
--- a/src/standard-descriptions/clos.lisp
+++ b/src/standard-descriptions/clos.lisp
@@ -1,32 +1,80 @@
 (in-package :lisp-on-lines)
 
 (in-package :lisp-on-lines)
 

+(defstruct unbound-slot-value (s))
+
+(defvar +unbound-slot+ (make-unbound-slot-value))
+
+(defmethod print-object ((object unbound-slot-value) stream)
+  (print-unreadable-object (object stream)
+    (format stream "UNBOUND")))
+

 (define-description standard-object ()
 (define-description standard-object ()

-  ((class-slots :label "Slots" 
+  ((editp :value t)
+   (class-slots :label "Slots" 

                :function (compose 'class-slots 'class-of))))
 
 (define-layered-class slot-definition-attribute (standard-attribute)
  ((slot-name :initarg :slot-name :accessor attribute-slot-name)))
 
                :function (compose 'class-slots 'class-of))))
 
 (define-layered-class slot-definition-attribute (standard-attribute)
  ((slot-name :initarg :slot-name :accessor attribute-slot-name)))
 

+(defmethod shared-initialize :around ((object slot-definition-attribute) 
+                                     slots &rest args)
+  (prog1 (call-next-method)
+    (unless (attribute-setter object)
+      (setf (attribute-setter object) 
+           (lambda (v o)
+             (setf (slot-value o (attribute-slot-name object)) v))))))
+                 
+

 (define-layered-method attribute-value (object (attribute slot-definition-attribute))
   (if (slot-boundp object (attribute-slot-name attribute))
                       
       (slot-value object (attribute-slot-name attribute))
       (gensym "UNBOUND-SLOT-")))
 
 (define-layered-method attribute-value (object (attribute slot-definition-attribute))
   (if (slot-boundp object (attribute-slot-name attribute))
                       
       (slot-value object (attribute-slot-name attribute))
       (gensym "UNBOUND-SLOT-")))
 

-(defmacro define-description-for-class (class-name &optional (name (intern (format nil "DESCRIPTION-FOR-~A" class-name))))
-  `(progn 
-     (define-description ,name (standard-object)
-       ,(loop :for slot in (class-slots (find-class class-name))
-         :collect `(,(slot-definition-name slot) 
-                   :attribute-class slot-definition-attribute
-                   :slot-name ,(slot-definition-name slot)
-                   :label ,(slot-definition-name slot)))
-       (:mixinp t))
-     (unless (ignore-errors (find-description ',class-name))
-       (define-description ,class-name (,name) ()))))
+(defun ensure-description-for-class (class &optional (name (intern (format nil "DESCRIPTION-FOR-~A" (class-name class)))))
+  (let ((desc-class 
+        (ensure-class (defining-description name) 
+               :direct-superclasses (list (class-of (find-description 'standard-object)))
+               :direct-slots (loop :for slot in (class-slots class)
+                                :collect `(:name ,(slot-definition-name slot) 
+                                           :attribute-class slot-definition-attribute
+                                           :slot-name ,(slot-definition-name slot)
+                                           :label ,(slot-definition-name slot))
+                                :into slots
+                                :collect (slot-definition-name slot) :into names
+                                :finally (return (cons `(:name active-attributes
+                                                         :value ,names)
+                                                       slots)))        
+               :metaclass 'standard-description-class)))

     
     

-                      
-                     
+    (unless (ignore-errors (find-description (class-name class)))
+      (ensure-class (defining-description (class-name class))
+                   :direct-superclasses (list desc-class)
+                       :metaclass 'standard-description-class))
+  (find-description name)))
+
+(defclass described-class ()
+  ())
+
+(defmethod validate-superclass
+           ((class described-class)
+            (superclass standard-class))
+  t)
+
+(defmethod initialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '()))
+  (declare (dynamic-extent initargs))
+  (finalize-inheritance class)
+  (ensure-description-for-class class))
+
+
+(defmethod reinitialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p))
+  (declare (dynamic-extent initargs))
+  (finalize-inheritance class)
+  (ensure-description-for-class class))
+
+
+  
+  

 (define-layered-method description-of ((object standard-object))
   (or (ignore-errors (find-description (class-name (class-of object))))
       (find-description 'standard-object)))
 (define-layered-method description-of ((object standard-object))
   (or (ignore-errors (find-description (class-name (class-of object))))
       (find-description 'standard-object)))

diff --git a/src/standard-descriptions/inline.lisp b/src/standard-descriptions/inline.lisp
new file mode 100644 (file)
index 0000000..9d05b65
--- /dev/null
+++ b/src/standard-descriptions/inline.lisp
@@ -0,0 +1,16 @@
+(in-package :lisp-on-lines)
+
+(define-description inline ())
+
+(define-description t ()
+  ((identity :label nil)
+   (active-attributes :value (identity)))
+  (:in-description inline))
+
+(define-display :in-description inline ((description t))
+  (format *display* "~{~A ~}" 
+         (mapcar 
+          (lambda (attribute)
+            (with-output-to-string (*display*)
+              (display-attribute *object* attribute)))
+          (attributes description))))

diff --git a/src/standard-descriptions/symbol.lisp b/src/standard-descriptions/symbol.lisp
index 300b481..c811d07 100644 (file)
--- a/src/standard-descriptions/symbol.lisp
+++ b/src/standard-descriptions/symbol.lisp
@@ -4,7 +4,7 @@
   (find-description 'symbol))
 
 (define-description symbol ()
   (find-description 'symbol))
 
 (define-description symbol ()

-  ((identity :label "Symbol:")
+  ((identity :label nil)

    (name 
     :function #'symbol-name
     :label "Name:")
    (name 
     :function #'symbol-name
     :label "Name:")

diff --git a/src/standard-descriptions/t.lisp b/src/standard-descriptions/t.lisp
index fe4864f..2980e31 100644 (file)
--- a/src/standard-descriptions/t.lisp
+++ b/src/standard-descriptions/t.lisp
@@ -3,7 +3,11 @@
 (define-description T ()
   ((identity :label nil :function #'identity)
    (type :label "Type" :function #'type-of)
 (define-description T ()
   ((identity :label nil :function #'identity)
    (type :label "Type" :function #'type-of)

-   (class :label "Class" :function #'class-of)))
+   (class :label "Class" :function #'class-of)
+   (active-attributes :label "Attributes"
+                     :value nil
+                     :activep nil
+                     :keyword :attributes)))

 
 (define-layered-method description-of (any-lisp-object)
   (find-description 't))
 
 (define-layered-method description-of (any-lisp-object)
   (find-description 't))


@@ -13,6 +17,8 @@
          (mapcar 
           (lambda (attribute)
             (with-output-to-string (*display*)
          (mapcar 
           (lambda (attribute)
             (with-output-to-string (*display*)

-              (display-attribute attribute)))
+              (display-attribute *object* attribute)))

           (attributes description))))
 
           (attributes description))))
 

+
+

diff --git a/src/ucw/html-description.lisp b/src/ucw/html-description.lisp
index a77c24a..57c8125 100644 (file)
--- a/src/ucw/html-description.lisp
+++ b/src/ucw/html-description.lisp
@@ -7,11 +7,12 @@
 
 
 (define-description t ()
 
 
 (define-description t ()

-  ((css-class  :value "lol-description")
+  ((css-class  :value "lol-description" :activep nil)

    (dom-id :function (lambda (x)
                       (declare (ignore x))
                       (symbol-name 
    (dom-id :function (lambda (x)
                       (declare (ignore x))
                       (symbol-name 

-                       (gensym "DOM-ID-")))))
+                       (gensym "DOM-ID-")))
+          :activep nil))

   (:in-description html-description))
 
 (define-layered-class html-attribute ()
   (:in-description html-description))
 
 (define-layered-class html-attribute ()


@@ -24,50 +25,110 @@
  (html-attribute)
  ())
 
  (html-attribute)
  ())
 

-(define-display 
-  :in-description html-description ((description t))
- (with-attributes (css-class dom-id) description
-   (<:style
-    (<:as-html "
+(define-layered-function display-html-attribute-label (object attribute)
+  (:method (object attribute)
+    (let ((label (attribute-label attribute)))
+          (<:label 
+           :class "lol-attribute-label"
+           (when label 
+             (<:as-html 
+              (with-output-to-string (*display*)
+                (display-attribute-label object attribute))))))))
+
+(define-layered-function display-html-attribute-value (object attribute)
+  (:method (object attribute)
+    (<:span 
+       :class "lol-attribute-value"
+       (<:as-html   (with-output-to-string (*display*)
+                (display-attribute-value object attribute))))
+))
+
+(define-layered-function display-html-attribute (object attribute)
+  (:method (object attribute)
+ (<:div 
+       :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)
+       (<:br)))
+  (:method :in-layer #.(defining-description 'inline) 
+          (object attribute)
+ (<:span 
+       :class (attribute-css-class attribute)
+       (when (attribute-dom-id attribute) 
+        :id (attribute-dom-id attribute))
+       (display-html-attribute-label object attribute)
+       (<:as-html " ")
+       (display-html-attribute-value object attribute)
+       (<:as-html " "))))
+
+(define-layered-method display-html-attribute-value 
+  :in-layer #.(defining-description 'editable) (object attribute)
+
+    (<:span 
+       :class "lol-attribute-value"
+    (if (attribute-editp object attribute)     
+    (<lol:input :reader (attribute-value object attribute)
+               :writer (lambda (val)
+                         (setf (attribute-value object attribute) val)))
+    (call-next-method))
+))             
+
+(define-layered-function display-html-description (description display object)
+  (:method (description display object)
+    (<:style
+     (<:as-html "

 
 

-.lol-attribute-label, .lol-attribute-value {
+div.lol-description .lol-attribute-label, 
+div.lol-description .lol-attribute-value {

       display: block;
       display: block;

-      width: 70%;
+      width: 69%;

       float: left;
       float: left;

-      margin-bottom: 10px;
+      margin-bottom: 1em;

 
 }
 
 }

+div.lol-description 

 .lol-attribute-label {
      text-align: right;
      width: 24%;
      padding-right: 20px;
 }
 
 .lol-attribute-label {
      text-align: right;
      width: 24%;
      padding-right: 20px;
 }
 

-.lol-attribute-value {
-  
-  }

 
 

+div.lol-description 

 br {
 clear: left;
 }"))
 br {
 clear: left;
 }"))

+                      
+    (with-attributes (css-class dom-id) description
+   

 
 

-   (<:div 
-    :class (list (attribute-value* css-class) "lol-description")
-    :id    (attribute-value* dom-id)
-    (dolist (attribute (attributes description))

       (<:div 
       (<:div 

-       :class (attribute-css-class attribute)
-       (when (attribute-dom-id attribute) 
-        :id (attribute-dom-id attribute))
-       (let ((label (attribute-label attribute)))
-        (when label
-          (<:label 
-           :class "lol-attribute-label"
-           (<:as-html label))))
-       (<:span 
-       :class "lol-attribute-value"
-       (<:as-html (format nil "~A" (attribute-value* attribute))))
-       (<:br))))))
+       :class (list (attribute-value* css-class) "lol-description" "t")
+       :id    (attribute-value* dom-id)
+       (unless *object* (error "Object is nil .. why?"))
+       (dolist (attribute (attributes description))
+        (display-html-attribute *object* attribute))))))
+                      
+
+(define-layered-method display-html-description 
+  :in-layer #.(defining-description 'inline) (description display object)
+  
+  (with-attributes (css-class dom-id) description
+   
+
+    (<:span
+     :class (list (attribute-value* css-class) "lol-description")
+     :id    (attribute-value* dom-id)
+     (unless *object* (error "Object is nil .. why?"))
+     (dolist (attribute (attributes description))
+       (display-html-attribute *object* attribute))))
+  )
+
+(define-display 
+  :in-description html-description ((description t) (display lol-ucw:component) object )
+  (display-html-description description display object))

      
       
   
      
       
   

diff --git a/src/ucw/packages.lisp b/src/ucw/packages.lisp
index 3f43698..172bff9 100644 (file)
--- a/src/ucw/packages.lisp
+++ b/src/ucw/packages.lisp
@@ -36,6 +36,8 @@
    #:shutdown-server
 
 
    #:shutdown-server
 
 

+   ;; Sessions
+   #:get-session-value

    ;; Standard Application
    #:standard-application
    #:register-application
    ;; Standard Application
    #:standard-application
    #:register-application


@@ -62,8 +64,14 @@
 
    ;; Standard Components
    #:render
 
    ;; Standard Components
    #:render

+   #:render-html-body

    #:component
    #:component

+

    #:standard-component-class
    #:standard-component-class

+   #:described-component-class
+
+   #:container
+   #:find-component

    
    #:standard-window-component ;*
    #:window-body
    
    #:standard-window-component ;*
    #:window-body

diff --git a/src/ucw/standard-components.lisp b/src/ucw/standard-components.lisp
index 1dabaa4..dd39293 100644 (file)
--- a/src/ucw/standard-components.lisp
+++ b/src/ucw/standard-components.lisp
@@ -1,5 +1,8 @@
 (in-package :lisp-on-lines-ucw)
 
 (in-package :lisp-on-lines-ucw)
 

+(defclass described-component-class (standard-component-class described-class)
+  ())
+

 (defmacro defaction (&rest args-and-body)
   `(arnesi:defmethod/cc ,@args-and-body))
 
 (defmacro defaction (&rest args-and-body)
   `(arnesi:defmethod/cc ,@args-and-body))
 


@@ -42,5 +45,5 @@
     :component t
     :initarg :body)))
 
     :component t
     :initarg :body)))
 

-(defmethod ucw:render-html-body ((window standard-window-component))
+(defmethod render-html-body ((window standard-window-component))

   (ucw:render (window-body window)))
   (ucw:render (window-body window)))