simplified slot access somewhat. layered slots still a little screwy.

darcs-hash:20080119063246-39164-490873a33e876cede72a09ffdad32aaad388fe40.gz

diff --git a/lisp-on-lines-ucw.asd b/lisp-on-lines-ucw.asd
index 6ea3a12..5164fdc 100644 (file)
--- a/lisp-on-lines-ucw.asd
+++ b/lisp-on-lines-ucw.asd
@@ -12,7 +12,8 @@
                        ((:module :ucw
                                  :components ((:file "packages")
                                               (:file "standard-components")
-                                              (:file "lol-tags"))
+                                              (:file "lol-tags")
+                                              (:file "html-description"))
                        
                                  :serial t))))
   :serial t

diff --git a/src/attribute-test.lisp b/src/attribute-test.lisp
index 632cba7..279151f 100644 (file)
--- a/src/attribute-test.lisp
+++ b/src/attribute-test.lisp
@@ -48,15 +48,18 @@
                    (attribute-value nil (find-attribute d 'attribute-2))))
        (is (equalp "VALUE2" (attribute-value nil (find-attribute d 'attribute-1))))))))
 
-(deftest test-attribute-with-different-class ()
+(deftest (test-attribute-with-different-class :compile-before-run t) ()
   (eval '(progn 
 ;;;; We cannot ever redefine this class ic think... 
 ;;; as attributes are also slot meta-objects.
-         (unless (find-class 'test-attribute-class nil) 
-           (define-layered-class
-               test-attribute-class (lol::standard-attribute)
-               ((some-slot :initarg :some-slot :layered-accessor some-slot))))
 
+
+         (define-layered-class
+               test-attribute-class (lol::standard-attribute)
+               ((some-slot :initarg :some-slot 
+                           :layered t 
+                           :layered-accessor some-slot)))
+         
          (define-description test-attribute-with-different-class-description ()
            ((attribute-with-different-class :attribute-class test-attribute-class :some-slot "BRILLANT!")))))
 

diff --git a/src/attribute.lisp b/src/attribute.lisp
index ba012b7..6d47657 100644 (file)
--- a/src/attribute.lisp
+++ b/src/attribute.lisp
@@ -143,33 +143,17 @@
 (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)
-  
-  (when (not (slot-boundp-using-class class attribute property))
-    ;; If the slot is unbound, we search for its layered-function
-    
-    (let ((fn (property-layered-function 
-              (attribute-description attribute)
 
-                       (attribute-name attribute)
-                       (closer-mop:slot-definition-name property))))
-      (dprint ".. not bound yet, have function ~A" fn)
-      (if (generic-function-methods fn)
-         (let ((*bypass-property-layered-function* t))
-          ; (dprint " This shit has been bound!. We gona set the _real_ slot to the generic function like.")
-           (setf (slot-value-using-class class attribute property) fn))
-         (progn 
-           ;(dprint "This shit aint never been bound nowhere! checking for initfunction...")
-           (when (slot-definition-initfunction property)
-             ;(dprint "At least we have an initfunction. sweeet")
-             (let ((*bypass-property-layered-function* nil))
-               (setf (slot-value attribute (slot-definition-name property)) 
-                   (funcall (slot-definition-initfunction property)))))))))
-
-  ;(dprint "If we're here, the slot should be bound")
+  ;;  (dprint "Getting the slot value of ~A" property) 
   
-    
-   (if (and 
+  ;; 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)))
+
+  (if (and 
        (contextl::slot-definition-layeredp property)
        (not *bypass-property-layered-function*))
       (let ((fn (call-next-method)))
@@ -177,26 +161,33 @@
       (funcall fn layer  (attribute-description attribute)))
       (call-next-method)))
 
+(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)
-  (when (not 
-        (let ((*bypass-property-layered-function* t))
-          (slot-boundp-using-class class attribute property)))
-    ;; If the slot is unbound, we search for its layered-function
-
-    (let ((fn (property-layered-function 
-              (attribute-description attribute)
-
+  (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))))
+                       (closer-mop:slot-definition-name property))))))
+    (dprint "Slot was bound? ~A" really-bound-p)
+    ;; If the slot is unbound, we search for its layered-function
       (if (generic-function-methods fn)
-         (let ((*bypass-property-layered-function* t))
-           (setf (slot-value-using-class class attribute property) fn))
-         NIL))))
+         T
+         NIL)))
     
-#+nil(define-layered-method slot-boundp-using-layer  
+(define-layered-method slot-boundp-using-layer  
   :in-layer (layer t)
   :around (class (attribute standard-attribute) property reader)
   (if *bypass-property-layered-function*

diff --git a/src/description-class.lisp b/src/description-class.lisp
index ac05535..5297dfd 100644 (file)
--- a/src/description-class.lisp
+++ b/src/description-class.lisp
@@ -72,10 +72,10 @@
 
 (defun description-class-name  (description-class)
     (read-from-string (symbol-name (class-name description-class))))
-
+  
 (defun initialize-description-class (class)
 
-;;; HACK: initialization does not happen properly 
+;;; HACK: initialization does not happ   en properly 
 ;;; when compiling and loading or something like that.
 ;;; Obviously i'm not sure why.
 ;;; So we're going to explicitly initialize things.
@@ -107,9 +107,15 @@
                            (find (slot-definition-name direct-slot) 
                                  attribute-objects 
                                  :key #'attribute-name)))
+                      (dprint "Re-initing")
                       (apply #'reinitialize-instance attribute 
-                             (direct-attribute-properties direct-slot))
-                      (apply #'change-class attribute (attribute-class attribute) (direct-attribute-properties direct-slot))
+                             (print (direct-attribute-properties direct-slot)))
+                      (when (not (eq (find-class (attribute-class attribute))
+                                 (class-of attribute)))
+                          
+                          (apply #'change-class attribute  (attribute-class attribute) 
+                                 (direct-attribute-properties direct-slot)))
+                      
 
                       (setf (slot-value description (attribute-name attribute))
                             attribute))))))))

diff --git a/src/standard-descriptions/clos.lisp b/src/standard-descriptions/clos.lisp
index 33a4cce..ec80d86 100644 (file)
--- a/src/standard-descriptions/clos.lisp
+++ b/src/standard-descriptions/clos.lisp
@@ -4,6 +4,13 @@
   ((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)))
+
+(define-layered-method attribute-value (object (attribute slot-definition-attribute))
+  (slot-value object (attribute-slot-name attribute)))
+                      
+                     
 (define-layered-method description-of ((object standard-object))
  (find-description 'standard-object))
 

diff --git a/src/standard-descriptions/edit.lisp b/src/standard-descriptions/edit.lisp
index d4a913e..2d8c42c 100644 (file)
--- a/src/standard-descriptions/edit.lisp
+++ b/src/standard-descriptions/edit.lisp
@@ -54,7 +54,7 @@
   ((attribute standard-attribute) display object &rest args)
   
   (declare (ignore args))
-  (format t "Editabpe? ~A ~A" (attribute-label attribute) attribute))
+  (format t "Editable? ~A ~A" (attribute-label attribute) (attribute-editp object attribute)))
 
 
                       
\ No newline at end of file

diff --git a/src/ucw/html-description.lisp b/src/ucw/html-description.lisp
index 8dae20a..a77c24a 100644 (file)
--- a/src/ucw/html-description.lisp
+++ b/src/ucw/html-description.lisp
@@ -1,18 +1,17 @@
 (in-package :lisp-on-lines)
 
-(export '(html-description))
+(export '(html-description) (find-package :lisp-on-lines))
 
 (define-description html-description ()
+  ())
+
+
+(define-description t ()
   ((css-class  :value "lol-description")
    (dom-id :function (lambda (x)
                       (declare (ignore x))
                       (symbol-name 
                        (gensym "DOM-ID-")))))
-  (:mixinp t))
-
-
-(define-description t (html-description)
-  ()
   (:in-description html-description))
 
 (define-layered-class html-attribute ()
@@ -28,21 +27,47 @@
 (define-display 
   :in-description html-description ((description t))
  (with-attributes (css-class dom-id) description
-   
+   (<:style
+    (<:as-html "
+
+.lol-attribute-label, .lol-attribute-value {
+      display: block;
+      width: 70%;
+      float: left;
+      margin-bottom: 10px;
+
+}
+.lol-attribute-label {
+     text-align: right;
+     width: 24%;
+     padding-right: 20px;
+}
+
+.lol-attribute-value {
+  
+  }
+
+br {
+clear: left;
+}"))
+
    (<:div 
-    :class (attribute-value* css-class)
+    :class (list (attribute-value* css-class) "lol-description")
     :id    (attribute-value* dom-id)
     (dolist (attribute (attributes description))
       (<:div 
        :class (attribute-css-class attribute)
        (when (attribute-dom-id attribute) 
         :id (attribute-dom-id attribute))
-       (<:span 
-       :class "lol-attribute-label"
-       (<:as-html (attribute-label attribute)))
+       (let ((label (attribute-label attribute)))
+        (when label
+          (<:label 
+           :class "lol-attribute-label"
+           (<:as-html label))))
        (<:span 
        :class "lol-attribute-value"
-       (<:as-html (attribute-value* attribute))))))))
+       (<:as-html (format nil "~A" (attribute-value* attribute))))
+       (<:br))))))